------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ U T I L -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2020, 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 Treepr; -- ???For debugging code below with Casing; use Casing; with Checks; use Checks; with Debug; use Debug; with Elists; use Elists; with Errout; use Errout; with Erroutc; use Erroutc; with Exp_Ch3; use Exp_Ch3; with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; with Fname; use Fname; with Freeze; use Freeze; with Itypes; use Itypes; with Lib; use Lib; with Lib.Xref; use Lib.Xref; with Namet.Sp; use Namet.Sp; with Nlists; use Nlists; with Nmake; use Nmake; with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Attr; use Sem_Attr; with Sem_Cat; use Sem_Cat; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Warn; use Sem_Warn; with Sem_Type; use Sem_Type; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; use Stand; with Style; with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uname; use Uname; with GNAT.Heap_Sort_G; with GNAT.HTable; use GNAT.HTable; package body Sem_Util is --------------------------- -- Local Data Structures -- --------------------------- Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty); -- A collection to hold the entities of the variables declared in package -- System.Scalar_Values which describe the invalid values of scalar types. Invalid_Binder_Values_Set : Boolean := False; -- This flag prevents multiple attempts to initialize Invalid_Binder_Values Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal); -- A collection to hold the invalid values of float types as specified by -- pragma Initialize_Scalars. Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint); -- A collection to hold the invalid values of integer types as specified -- by pragma Initialize_Scalars. ----------------------- -- Local Subprograms -- ----------------------- function Build_Component_Subtype (C : List_Id; Loc : Source_Ptr; T : Entity_Id) return Node_Id; -- This function builds the subtype for Build_Actual_Subtype_Of_Component -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, -- Loc is the source location, T is the original subtype. procedure Examine_Array_Bounds (Typ : Entity_Id; All_Static : out Boolean; Has_Empty : out Boolean); -- Inspect the index constraints of array type Typ. Flag All_Static is set -- when all ranges are static. Flag Has_Empty is set only when All_Static -- is set and indicates that at least one range is empty. function Has_Enabled_Property (Item_Id : Entity_Id; Property : Name_Id) return Boolean; -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled. -- Determine whether the state abstraction, object, or type denoted by -- entity Item_Id has enabled property Property. function Has_Null_Extension (T : Entity_Id) return Boolean; -- T is a derived tagged type. Check whether the type extension is null. -- If the parent type is fully initialized, T can be treated as such. function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean; -- Determine whether arbitrary entity Id denotes an atomic object as per -- RM C.6(7). function Is_Container_Aggregate (Exp : Node_Id) return Boolean; -- Is the given expression a container aggregate? generic with function Is_Effectively_Volatile_Entity (Id : Entity_Id) return Boolean; -- Function to use on object and type entities function Is_Effectively_Volatile_Object_Shared (N : Node_Id) return Boolean; -- Shared function used to detect effectively volatile objects and -- effectively volatile objects for reading. function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type -- with discriminants whose default values are static, examine only the -- components in the selected variant to determine whether all of them -- have a default. function Is_Preelaborable_Function (Id : Entity_Id) return Boolean; -- Ada 2020: Determine whether the specified function is suitable as the -- name of a call in a preelaborable construct (RM 10.2.1(7/5)). type Null_Status_Kind is (Is_Null, -- This value indicates that a subexpression is known to have a null -- value at compile time. Is_Non_Null, -- This value indicates that a subexpression is known to have a non-null -- value at compile time. Unknown); -- This value indicates that it cannot be determined at compile time -- whether a subexpression yields a null or non-null value. function Null_Status (N : Node_Id) return Null_Status_Kind; -- Determine whether subexpression N of an access type yields a null value, -- a non-null value, or the value cannot be determined at compile time. The -- routine does not take simple flow diagnostics into account, it relies on -- static facts such as the presence of null exclusions. function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean; function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean; -- ???We retain the old and new algorithms for Requires_Transient_Scope for -- the time being. New_Requires_Transient_Scope is used by default; the -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope -- instead. The intent is to use this temporarily to measure before/after -- efficiency. Note: when this temporary code is removed, the documentation -- of dQ in debug.adb should be removed. procedure Results_Differ (Id : Entity_Id; Old_Val : Boolean; New_Val : Boolean); -- ???Debugging code. Called when the Old_Val and New_Val differ. This -- routine will be removed eventially when New_Requires_Transient_Scope -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is -- eliminated. function Subprogram_Name (N : Node_Id) return String; -- Return the fully qualified name of the enclosing subprogram for the -- given node N, with file:line:col information appended, e.g. -- "subp:file:line:col", corresponding to the source location of the -- body of the subprogram. ------------------------------ -- Abstract_Interface_List -- ------------------------------ function Abstract_Interface_List (Typ : Entity_Id) return List_Id is Nod : Node_Id; begin if Is_Concurrent_Type (Typ) then -- If we are dealing with a synchronized subtype, go to the base -- type, whose declaration has the interface list. Nod := Declaration_Node (Base_Type (Typ)); if Nkind (Nod) in N_Full_Type_Declaration | N_Private_Type_Declaration then return Empty_List; end if; elsif Ekind (Typ) = E_Record_Type_With_Private then if Nkind (Parent (Typ)) = N_Full_Type_Declaration then Nod := Type_Definition (Parent (Typ)); elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then if Present (Full_View (Typ)) and then Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration then Nod := Type_Definition (Parent (Full_View (Typ))); -- If the full-view is not available we cannot do anything else -- here (the source has errors). else return Empty_List; end if; -- Support for generic formals with interfaces is still missing ??? elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then return Empty_List; else pragma Assert (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); Nod := Parent (Typ); end if; elsif Ekind (Typ) = E_Record_Subtype then Nod := Type_Definition (Parent (Etype (Typ))); elsif Ekind (Typ) = E_Record_Subtype_With_Private then -- Recurse, because parent may still be a private extension. Also -- note that the full view of the subtype or the full view of its -- base type may (both) be unavailable. return Abstract_Interface_List (Etype (Typ)); elsif Ekind (Typ) = E_Record_Type then if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then Nod := Formal_Type_Definition (Parent (Typ)); else Nod := Type_Definition (Parent (Typ)); end if; -- Otherwise the type is of a kind which does not implement interfaces else return Empty_List; end if; 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) 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 dynamic 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. ---------------------------------- -- Innermost_Master_Scope_Depth -- ---------------------------------- function Innermost_Master_Scope_Depth (N : Node_Id) return Uint is Encl_Scop : 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 dynamic 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 if Present (Defining_Entity (Node_Par, Empty_On_Errors => True)) then Encl_Scop := Nearest_Dynamic_Scope (Defining_Entity (Node_Par)); -- Ignore transient scopes made during expansion if Comes_From_Source (Node_Par) then return Scope_Depth (Encl_Scop) + Master_Lvl_Modifier; 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 and then Ekind (Current_Scope) = E_Function then return Scope_Depth (Current_Scope); -- 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 (Type_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 (Type_Access_Level (Etype (N))); -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3) else 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 library accessibility level to null -- out the check on the side of the caller. if In_Return_Value (N) or else In_Return_Context then return Make_Level_Literal (Subprogram_Access_Level (Current_Subprogram)); end if; 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 (Type_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 accessiblity 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 : Entity_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 (Type_Access_Level (Etype (Pre))); -- Anonymous access types elsif Nkind (Pre) in N_Has_Entity 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 Level /= Dynamic_Level and then (In_Return_Value (Expr) or else In_Return_Context) 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 not Present (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; return New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc); -- Initialization procedures have a special extra accessitility -- parameter associated with the level at which the object -- begin 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 return Make_Level_Literal (Type_Access_Level (E) + 1); -- Move up the renamed entity if it came from source since -- expansion may have created a dummy renaming under certain -- circumstances. elsif Present (Renamed_Object (E)) and then Comes_From_Source (Renamed_Object (E)) then return Accessibility_Level (Renamed_Object (E)); -- Named access types get their level from their associated type elsif Is_Named_Access_Type (Etype (E)) then return Make_Level_Literal (Type_Access_Level (Etype (E))); -- When E is a component of the current instance of a -- protected type, we assume the level to be deeper than that of -- the type itself. elsif not Is_Overloadable (E) and then Ekind (Scope (E)) = E_Protected_Type and then Comes_From_Source (Scope (E)) then return Make_Level_Literal (Scope_Depth (Enclosing_Dynamic_Scope (E)) + 1); -- 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 => Pre := Original_Node (Prefix (E)); -- 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 (Type_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 (Type_Access_Level (Etype (E))); -- A non-discriminant 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). 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) then return Make_Level_Literal (Type_Access_Level (Etype (Prefix (E)))); -- Similar to the previous case - arrays featuring components of -- anonymous access components get their corresponding level from -- their containing type's declaration. elsif 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 return Make_Level_Literal (Type_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 (Type_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 (Type_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 (Type_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 (Type_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 -- ---------------------------------- function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String is S : constant String := To_String (Strval (Str_Lit)); begin if S = "" then return ""; else -- Put "*" before or after or both, if it's not already there declare F : constant Boolean := S (S'First) = '*'; L : constant Boolean := S (S'Last) = '*'; begin if F then if L then return S; else return S & "*"; end if; else if L then return "*" & S; else return "*" & S & "*"; end if; end if; end; end if; end Acquire_Warning_Match_String; -------------------------------- -- Add_Access_Type_To_Process -- -------------------------------- procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is L : Elist_Id; begin Ensure_Freeze_Node (E); L := Access_Types_To_Process (Freeze_Node (E)); if No (L) then L := New_Elmt_List; Set_Access_Types_To_Process (Freeze_Node (E), L); end if; Append_Elmt (A, L); end Add_Access_Type_To_Process; -------------------------- -- Add_Block_Identifier -- -------------------------- procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is Loc : constant Source_Ptr := Sloc (N); begin pragma Assert (Nkind (N) = N_Block_Statement); -- The block already has a label, return its entity if Present (Identifier (N)) then Id := Entity (Identifier (N)); -- Create a new block label and set its attributes else Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); Set_Etype (Id, Standard_Void_Type); Set_Parent (Id, N); Set_Identifier (N, New_Occurrence_Of (Id, Loc)); Set_Block_Node (Id, Identifier (N)); end if; end Add_Block_Identifier; ---------------------------- -- Add_Global_Declaration -- ---------------------------- procedure Add_Global_Declaration (N : Node_Id) is Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); begin if No (Declarations (Aux_Node)) then Set_Declarations (Aux_Node, New_List); end if; Append_To (Declarations (Aux_Node), N); Analyze (N); end Add_Global_Declaration; -------------------------------- -- Address_Integer_Convert_OK -- -------------------------------- function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is begin if Allow_Integer_Address and then ((Is_Descendant_Of_Address (T1) and then Is_Private_Type (T1) and then Is_Integer_Type (T2)) or else (Is_Descendant_Of_Address (T2) and then Is_Private_Type (T2) and then Is_Integer_Type (T1))) then return True; else return False; end if; end Address_Integer_Convert_OK; ------------------- -- Address_Value -- ------------------- function Address_Value (N : Node_Id) return Node_Id is Expr : Node_Id := N; begin loop -- For constant, get constant expression if Is_Entity_Name (Expr) and then Ekind (Entity (Expr)) = E_Constant then Expr := Constant_Value (Entity (Expr)); -- For unchecked conversion, get result to convert elsif Nkind (Expr) = N_Unchecked_Type_Conversion then Expr := Expression (Expr); -- For (common case) of To_Address call, get argument elsif Nkind (Expr) = N_Function_Call and then Is_Entity_Name (Name (Expr)) and then Is_RTE (Entity (Name (Expr)), RE_To_Address) then Expr := First (Parameter_Associations (Expr)); if Nkind (Expr) = N_Parameter_Association then Expr := Explicit_Actual_Parameter (Expr); end if; -- We finally have the real expression else exit; end if; end loop; return Expr; end Address_Value; ----------------- -- Addressable -- ----------------- function Addressable (V : Uint) return Boolean is begin return V = Uint_8 or else V = Uint_16 or else V = Uint_32 or else V = Uint_64 or else (V = Uint_128 and then System_Max_Integer_Size = 128); end Addressable; function Addressable (V : Int) return Boolean is begin return V = 8 or else V = 16 or else V = 32 or else V = 64 or else V = System_Max_Integer_Size; end Addressable; --------------------------------- -- Aggregate_Constraint_Checks -- --------------------------------- procedure Aggregate_Constraint_Checks (Exp : Node_Id; Check_Typ : Entity_Id) is Exp_Typ : constant Entity_Id := Etype (Exp); begin if Raises_Constraint_Error (Exp) then return; end if; -- Ada 2005 (AI-230): Generate a conversion to an anonymous access -- component's type to force the appropriate accessibility checks. -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to -- force the corresponding run-time check if Is_Access_Type (Check_Typ) and then Is_Local_Anonymous_Access (Check_Typ) then Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); Analyze_And_Resolve (Exp, Check_Typ); Check_Unset_Reference (Exp); end if; -- What follows is really expansion activity, so check that expansion -- is on and is allowed. In GNATprove mode, we also want check flags to -- be added in the tree, so that the formal verification can rely on -- those to be present. In GNATprove mode for formal verification, some -- treatment typically only done during expansion needs to be performed -- on the tree, but it should not be applied inside generics. Otherwise, -- this breaks the name resolution mechanism for generic instances. if not Expander_Active and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) then return; end if; if Is_Access_Type (Check_Typ) and then Can_Never_Be_Null (Check_Typ) and then not Can_Never_Be_Null (Exp_Typ) then Install_Null_Excluding_Check (Exp); end if; -- First check if we have to insert discriminant checks if Has_Discriminants (Exp_Typ) then Apply_Discriminant_Check (Exp, Check_Typ); -- Next emit length checks for array aggregates elsif Is_Array_Type (Exp_Typ) then Apply_Length_Check (Exp, Check_Typ); -- Finally emit scalar and string checks. If we are dealing with a -- scalar literal we need to check by hand because the Etype of -- literals is not necessarily correct. elsif Is_Scalar_Type (Exp_Typ) and then Compile_Time_Known_Value (Exp) then if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then Apply_Compile_Time_Constraint_Error (Exp, "value not in range of}??", CE_Range_Check_Failed, Ent => Base_Type (Check_Typ), Typ => Base_Type (Check_Typ)); elsif Is_Out_Of_Range (Exp, Check_Typ) then Apply_Compile_Time_Constraint_Error (Exp, "value not in range of}??", CE_Range_Check_Failed, Ent => Check_Typ, Typ => Check_Typ); elsif not Range_Checks_Suppressed (Check_Typ) then Apply_Scalar_Range_Check (Exp, Check_Typ); end if; -- Verify that target type is also scalar, to prevent view anomalies -- in instantiations. elsif (Is_Scalar_Type (Exp_Typ) or else Nkind (Exp) = N_String_Literal) and then Is_Scalar_Type (Check_Typ) and then Exp_Typ /= Check_Typ then if Is_Entity_Name (Exp) and then Ekind (Entity (Exp)) = E_Constant then -- If expression is a constant, it is worthwhile checking whether -- it is a bound of the type. if (Is_Entity_Name (Type_Low_Bound (Check_Typ)) and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ))) or else (Is_Entity_Name (Type_High_Bound (Check_Typ)) and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ))) then return; else Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); Analyze_And_Resolve (Exp, Check_Typ); Check_Unset_Reference (Exp); end if; -- Could use a comment on this case ??? else Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); Analyze_And_Resolve (Exp, Check_Typ); Check_Unset_Reference (Exp); end if; end if; end Aggregate_Constraint_Checks; ----------------------- -- Alignment_In_Bits -- ----------------------- function Alignment_In_Bits (E : Entity_Id) return Uint is begin return Alignment (E) * System_Storage_Unit; end Alignment_In_Bits; -------------------------------------- -- All_Composite_Constraints_Static -- -------------------------------------- function All_Composite_Constraints_Static (Constr : Node_Id) return Boolean is begin if No (Constr) or else Error_Posted (Constr) then return True; end if; case Nkind (Constr) is when N_Subexpr => if Nkind (Constr) in N_Has_Entity and then Present (Entity (Constr)) then if Is_Type (Entity (Constr)) then return not Is_Discrete_Type (Entity (Constr)) or else Is_OK_Static_Subtype (Entity (Constr)); end if; elsif Nkind (Constr) = N_Range then return Is_OK_Static_Expression (Low_Bound (Constr)) and then Is_OK_Static_Expression (High_Bound (Constr)); elsif Nkind (Constr) = N_Attribute_Reference and then Attribute_Name (Constr) = Name_Range then return Is_OK_Static_Expression (Type_Low_Bound (Etype (Prefix (Constr)))) and then Is_OK_Static_Expression (Type_High_Bound (Etype (Prefix (Constr)))); end if; return not Present (Etype (Constr)) -- previous error or else not Is_Discrete_Type (Etype (Constr)) or else Is_OK_Static_Expression (Constr); when N_Discriminant_Association => return All_Composite_Constraints_Static (Expression (Constr)); when N_Range_Constraint => return All_Composite_Constraints_Static (Range_Expression (Constr)); when N_Index_Or_Discriminant_Constraint => declare One_Cstr : Entity_Id; begin One_Cstr := First (Constraints (Constr)); while Present (One_Cstr) loop if not All_Composite_Constraints_Static (One_Cstr) then return False; end if; Next (One_Cstr); end loop; end; return True; when N_Subtype_Indication => return All_Composite_Constraints_Static (Subtype_Mark (Constr)) and then All_Composite_Constraints_Static (Constraint (Constr)); when others => raise Program_Error; end case; end All_Composite_Constraints_Static; ------------------------ -- Append_Entity_Name -- ------------------------ procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is Temp : Bounded_String; procedure Inner (E : Entity_Id); -- Inner recursive routine, keep outer routine nonrecursive to ease -- debugging when we get strange results from this routine. ----------- -- Inner -- ----------- procedure Inner (E : Entity_Id) is Scop : Node_Id; begin -- If entity has an internal name, skip by it, and print its scope. -- Note that we strip a final R from the name before the test; this -- is needed for some cases of instantiations. declare E_Name : Bounded_String; begin Append (E_Name, Chars (E)); if E_Name.Chars (E_Name.Length) = 'R' then E_Name.Length := E_Name.Length - 1; end if; if Is_Internal_Name (E_Name) then Inner (Scope (E)); return; end if; end; Scop := Scope (E); -- Just print entity name if its scope is at the outer level if Scop = Standard_Standard then null; -- If scope comes from source, write scope and entity elsif Comes_From_Source (Scop) then Append_Entity_Name (Temp, Scop); Append (Temp, '.'); -- If in wrapper package skip past it elsif Present (Scop) and then Is_Wrapper_Package (Scop) then Append_Entity_Name (Temp, Scope (Scop)); Append (Temp, '.'); -- Otherwise nothing to output (happens in unnamed block statements) else null; end if; -- Output the name declare E_Name : Bounded_String; begin Append_Unqualified_Decoded (E_Name, Chars (E)); -- Remove trailing upper-case letters from the name (useful for -- dealing with some cases of internal names generated in the case -- of references from within a generic). while E_Name.Length > 1 and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z' loop E_Name.Length := E_Name.Length - 1; end loop; -- Adjust casing appropriately (gets name from source if possible) Adjust_Name_Case (E_Name, Sloc (E)); Append (Temp, E_Name); end; end Inner; -- Start of processing for Append_Entity_Name begin Inner (E); Append (Buf, Temp); end Append_Entity_Name; --------------------------------- -- Append_Inherited_Subprogram -- --------------------------------- procedure Append_Inherited_Subprogram (S : Entity_Id) is Par : constant Entity_Id := Alias (S); -- The parent subprogram Scop : constant Entity_Id := Scope (Par); -- The scope of definition of the parent subprogram Typ : constant Entity_Id := Defining_Entity (Parent (S)); -- The derived type of which S is a primitive operation Decl : Node_Id; Next_E : Entity_Id; begin if Ekind (Current_Scope) = E_Package and then In_Private_Part (Current_Scope) and then Has_Private_Declaration (Typ) and then Is_Tagged_Type (Typ) and then Scop = Current_Scope then -- The inherited operation is available at the earliest place after -- the derived type declaration (RM 7.3.1 (6/1)). This is only -- relevant for type extensions. If the parent operation appears -- after the type extension, the operation is not visible. Decl := First (Visible_Declarations (Package_Specification (Current_Scope))); while Present (Decl) loop if Nkind (Decl) = N_Private_Extension_Declaration and then Defining_Entity (Decl) = Typ then if Sloc (Decl) > Sloc (Par) then Next_E := Next_Entity (Par); Link_Entities (Par, S); Link_Entities (S, Next_E); return; else exit; end if; end if; Next (Decl); end loop; end if; -- If partial view is not a type extension, or it appears before the -- subprogram declaration, insert normally at end of entity list. Append_Entity (S, Current_Scope); end Append_Inherited_Subprogram; ----------------------------------------- -- Apply_Compile_Time_Constraint_Error -- ----------------------------------------- procedure Apply_Compile_Time_Constraint_Error (N : Node_Id; Msg : String; Reason : RT_Exception_Code; Ent : Entity_Id := Empty; Typ : Entity_Id := Empty; Loc : Source_Ptr := No_Location; Rep : Boolean := True; Warn : Boolean := False) is Stat : constant Boolean := Is_Static_Expression (N); R_Stat : constant Node_Id := Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); Rtyp : Entity_Id; begin if No (Typ) then Rtyp := Etype (N); else Rtyp := Typ; end if; Discard_Node (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); -- In GNATprove mode, do not replace the node with an exception raised. -- In such a case, either the call to Compile_Time_Constraint_Error -- issues an error which stops analysis, or it issues a warning in -- a few cases where a suitable check flag is set for GNATprove to -- generate a check message. if not Rep or GNATprove_Mode then return; end if; -- Now we replace the node by an N_Raise_Constraint_Error node -- This does not need reanalyzing, so set it as analyzed now. Rewrite (N, R_Stat); Set_Analyzed (N, True); Set_Etype (N, Rtyp); Set_Raises_Constraint_Error (N); -- Now deal with possible local raise handling Possible_Local_Raise (N, Standard_Constraint_Error); -- If the original expression was marked as static, the result is -- still marked as static, but the Raises_Constraint_Error flag is -- always set so that further static evaluation is not attempted. if Stat then Set_Is_Static_Expression (N); end if; end Apply_Compile_Time_Constraint_Error; --------------------------- -- Async_Readers_Enabled -- --------------------------- function Async_Readers_Enabled (Id : Entity_Id) return Boolean is begin return Has_Enabled_Property (Id, Name_Async_Readers); end Async_Readers_Enabled; --------------------------- -- Async_Writers_Enabled -- --------------------------- function Async_Writers_Enabled (Id : Entity_Id) return Boolean is begin return Has_Enabled_Property (Id, Name_Async_Writers); end Async_Writers_Enabled; -------------------------------------- -- Available_Full_View_Of_Component -- -------------------------------------- function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is ST : constant Entity_Id := Scope (T); SCT : constant Entity_Id := Scope (Component_Type (T)); begin return In_Open_Scopes (ST) and then In_Open_Scopes (SCT) and then Scope_Depth (ST) >= Scope_Depth (SCT); end Available_Full_View_Of_Component; ------------------- -- Bad_Attribute -- ------------------- procedure Bad_Attribute (N : Node_Id; Nam : Name_Id; Warn : Boolean := False) is begin Error_Msg_Warn := Warn; Error_Msg_N ("unrecognized attribute&<<", N); -- Check for possible misspelling Error_Msg_Name_1 := First_Attribute_Name; while Error_Msg_Name_1 <= Last_Attribute_Name loop if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then Error_Msg_N -- CODEFIX ("\possible misspelling of %<<", N); exit; end if; Error_Msg_Name_1 := Error_Msg_Name_1 + 1; end loop; end Bad_Attribute; -------------------------------- -- Bad_Predicated_Subtype_Use -- -------------------------------- procedure Bad_Predicated_Subtype_Use (Msg : String; N : Node_Id; Typ : Entity_Id; Suggest_Static : Boolean := False) is Gen : Entity_Id; begin -- Avoid cascaded errors if Error_Posted (N) then return; end if; if Inside_A_Generic then Gen := Current_Scope; while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop Gen := Scope (Gen); end loop; if No (Gen) then return; end if; if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then Set_No_Predicate_On_Actual (Typ); end if; elsif Has_Predicates (Typ) then if Is_Generic_Actual_Type (Typ) then -- The restriction on loop parameters is only that the type -- should have no dynamic predicates. if Nkind (Parent (N)) = N_Loop_Parameter_Specification and then not Has_Dynamic_Predicate_Aspect (Typ) and then Is_OK_Static_Subtype (Typ) then return; end if; Gen := Current_Scope; while not Is_Generic_Instance (Gen) loop Gen := Scope (Gen); end loop; pragma Assert (Present (Gen)); if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then Error_Msg_Warn := SPARK_Mode /= On; Error_Msg_FE (Msg & "<<", N, Typ); Error_Msg_F ("\Program_Error [<<", N); Insert_Action (N, Make_Raise_Program_Error (Sloc (N), Reason => PE_Bad_Predicated_Generic_Type)); else Error_Msg_FE (Msg, N, Typ); end if; else Error_Msg_FE (Msg, N, Typ); end if; -- Emit an optional suggestion on how to remedy the error if the -- context warrants it. if Suggest_Static and then Has_Static_Predicate (Typ) then Error_Msg_FE ("\predicate of & should be marked static", N, Typ); end if; end if; end Bad_Predicated_Subtype_Use; ----------------------------------------- -- Bad_Unordered_Enumeration_Reference -- ----------------------------------------- function Bad_Unordered_Enumeration_Reference (N : Node_Id; T : Entity_Id) return Boolean is begin return Is_Enumeration_Type (T) and then Warn_On_Unordered_Enumeration_Type and then not Is_Generic_Type (T) and then Comes_From_Source (N) and then not Has_Pragma_Ordered (T) and then not In_Same_Extended_Unit (N, T); end Bad_Unordered_Enumeration_Reference; ---------------------------- -- Begin_Keyword_Location -- ---------------------------- function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is HSS : Node_Id; begin pragma Assert (Nkind (N) in N_Block_Statement | N_Entry_Body | N_Package_Body | N_Subprogram_Body | N_Task_Body); HSS := Handled_Statement_Sequence (N); -- When the handled sequence of statements comes from source, the -- location of the "begin" keyword is that of the sequence itself. -- Note that an internal construct may inherit a source sequence. if Comes_From_Source (HSS) then return Sloc (HSS); -- The parser generates an internal handled sequence of statements to -- capture the location of the "begin" keyword if present in the source. -- Since there are no source statements, the location of the "begin" -- keyword is effectively that of the "end" keyword. elsif Comes_From_Source (N) then return Sloc (HSS); -- Otherwise the construct is internal and should carry the location of -- the original construct which prompted its creation. else return Sloc (N); end if; end Begin_Keyword_Location; -------------------------- -- Build_Actual_Subtype -- -------------------------- function Build_Actual_Subtype (T : Entity_Id; N : Node_Or_Entity_Id) return Node_Id is Loc : Source_Ptr; -- Normally Sloc (N), but may point to corresponding body in some cases Constraints : List_Id; Decl : Node_Id; Discr : Entity_Id; Hi : Node_Id; Lo : Node_Id; Subt : Entity_Id; Disc_Type : Entity_Id; Obj : Node_Id; begin Loc := Sloc (N); if Nkind (N) = N_Defining_Identifier then Obj := New_Occurrence_Of (N, Loc); -- If this is a formal parameter of a subprogram declaration, and -- we are compiling the body, we want the declaration for the -- actual subtype to carry the source position of the body, to -- prevent anomalies in gdb when stepping through the code. if Is_Formal (N) then declare Decl : constant Node_Id := Unit_Declaration_Node (Scope (N)); begin if Nkind (Decl) = N_Subprogram_Declaration and then Present (Corresponding_Body (Decl)) then Loc := Sloc (Corresponding_Body (Decl)); end if; end; end if; else Obj := N; end if; if Is_Array_Type (T) then Constraints := New_List; for J in 1 .. Number_Dimensions (T) loop -- Build an array subtype declaration with the nominal subtype and -- the bounds of the actual. Add the declaration in front of the -- local declarations for the subprogram, for analysis before any -- reference to the formal in the body. Lo := Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), Attribute_Name => Name_First, Expressions => New_List ( Make_Integer_Literal (Loc, J))); Hi := Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), Attribute_Name => Name_Last, Expressions => New_List ( Make_Integer_Literal (Loc, J))); Append (Make_Range (Loc, Lo, Hi), Constraints); end loop; -- If the type has unknown discriminants there is no constrained -- subtype to build. This is never called for a formal or for a -- lhs, so returning the type is ok ??? elsif Has_Unknown_Discriminants (T) then return T; else Constraints := New_List; -- Type T is a generic derived type, inherit the discriminants from -- the parent type. if Is_Private_Type (T) and then No (Full_View (T)) -- T was flagged as an error if it was declared as a formal -- derived type with known discriminants. In this case there -- is no need to look at the parent type since T already carries -- its own discriminants. and then not Error_Posted (T) then Disc_Type := Etype (Base_Type (T)); else Disc_Type := T; end if; Discr := First_Discriminant (Disc_Type); while Present (Discr) loop Append_To (Constraints, Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr_No_Checks (Obj), Selector_Name => New_Occurrence_Of (Discr, Loc))); Next_Discriminant (Discr); end loop; end if; Subt := Make_Temporary (Loc, 'S', Related_Node => N); Set_Is_Internal (Subt); Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Subt, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (T, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constraints))); Mark_Rewrite_Insertion (Decl); return Decl; end Build_Actual_Subtype; --------------------------------------- -- Build_Actual_Subtype_Of_Component -- --------------------------------------- function Build_Actual_Subtype_Of_Component (T : Entity_Id; N : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); P : constant Node_Id := Prefix (N); D : Elmt_Id; Id : Node_Id; Index_Typ : Entity_Id; Sel : Entity_Id := Empty; Desig_Typ : Entity_Id; -- This is either a copy of T, or if T is an access type, then it is -- the directly designated type of this access type. function Build_Access_Record_Constraint (C : List_Id) return List_Id; -- If the record component is a constrained access to the current -- record, the subtype has not been constructed during analysis of -- the enclosing record type (see Analyze_Access). In that case, build -- a constrained access subtype after replacing references to the -- enclosing discriminants with the corresponding discriminant values -- of the prefix. function Build_Actual_Array_Constraint return List_Id; -- If one or more of the bounds of the component depends on -- discriminants, build actual constraint using the discriminants -- of the prefix, as above. function Build_Actual_Record_Constraint return List_Id; -- Similar to previous one, for discriminated components constrained -- by the discriminant of the enclosing object. function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id; -- Copy the subtree rooted at N and insert an explicit dereference if it -- is of an access type. ----------------------------------- -- Build_Actual_Array_Constraint -- ----------------------------------- function Build_Actual_Array_Constraint return List_Id is Constraints : constant List_Id := New_List; Indx : Node_Id; Hi : Node_Id; Lo : Node_Id; Old_Hi : Node_Id; Old_Lo : Node_Id; begin Indx := First_Index (Desig_Typ); while Present (Indx) loop Old_Lo := Type_Low_Bound (Etype (Indx)); Old_Hi := Type_High_Bound (Etype (Indx)); if Denotes_Discriminant (Old_Lo) then Lo := Make_Selected_Component (Loc, Prefix => Copy_And_Maybe_Dereference (P), Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); else Lo := New_Copy_Tree (Old_Lo); -- The new bound will be reanalyzed in the enclosing -- declaration. For literal bounds that come from a type -- declaration, the type of the context must be imposed, so -- insure that analysis will take place. For non-universal -- types this is not strictly necessary. Set_Analyzed (Lo, False); end if; if Denotes_Discriminant (Old_Hi) then Hi := Make_Selected_Component (Loc, Prefix => Copy_And_Maybe_Dereference (P), Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); else Hi := New_Copy_Tree (Old_Hi); Set_Analyzed (Hi, False); end if; Append (Make_Range (Loc, Lo, Hi), Constraints); Next_Index (Indx); end loop; return Constraints; end Build_Actual_Array_Constraint; ------------------------------------ -- Build_Actual_Record_Constraint -- ------------------------------------ function Build_Actual_Record_Constraint return List_Id is Constraints : constant List_Id := New_List; D : Elmt_Id; D_Val : Node_Id; begin D := First_Elmt (Discriminant_Constraint (Desig_Typ)); while Present (D) loop if Denotes_Discriminant (Node (D)) then D_Val := Make_Selected_Component (Loc, Prefix => Copy_And_Maybe_Dereference (P), Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); else D_Val := New_Copy_Tree (Node (D)); end if; Append (D_Val, Constraints); Next_Elmt (D); end loop; return Constraints; end Build_Actual_Record_Constraint; ------------------------------------ -- Build_Access_Record_Constraint -- ------------------------------------ function Build_Access_Record_Constraint (C : List_Id) return List_Id is Constraints : constant List_Id := New_List; D : Node_Id; D_Val : Node_Id; begin -- Retrieve the constraint from the component declaration, because -- the component subtype has not been constructed and the component -- type is an unconstrained access. D := First (C); while Present (D) loop if Nkind (D) = N_Discriminant_Association and then Denotes_Discriminant (Expression (D)) then D_Val := New_Copy_Tree (D); Set_Expression (D_Val, Make_Selected_Component (Loc, Prefix => Copy_And_Maybe_Dereference (P), Selector_Name => New_Occurrence_Of (Entity (Expression (D)), Loc))); elsif Denotes_Discriminant (D) then D_Val := Make_Selected_Component (Loc, Prefix => Copy_And_Maybe_Dereference (P), Selector_Name => New_Occurrence_Of (Entity (D), Loc)); else D_Val := New_Copy_Tree (D); end if; Append (D_Val, Constraints); Next (D); end loop; return Constraints; end Build_Access_Record_Constraint; -------------------------------- -- Copy_And_Maybe_Dereference -- -------------------------------- function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id is New_N : constant Node_Id := New_Copy_Tree (N); begin if Is_Access_Type (Etype (N)) then return Make_Explicit_Dereference (Sloc (Parent (N)), New_N); else return New_N; end if; end Copy_And_Maybe_Dereference; -- Start of processing for Build_Actual_Subtype_Of_Component begin -- The subtype does not need to be created for a selected component -- in a Spec_Expression. if In_Spec_Expression then return Empty; -- More comments for the rest of this body would be good ??? elsif Nkind (N) = N_Explicit_Dereference then if Is_Composite_Type (T) and then not Is_Constrained (T) and then not (Is_Class_Wide_Type (T) and then Is_Constrained (Root_Type (T))) and then not Has_Unknown_Discriminants (T) then -- If the type of the dereference is already constrained, it is an -- actual subtype. if Is_Array_Type (Etype (N)) and then Is_Constrained (Etype (N)) then return Empty; else Remove_Side_Effects (P); return Build_Actual_Subtype (T, N); end if; else return Empty; end if; elsif Nkind (N) = N_Selected_Component then -- The entity of the selected component allows us to retrieve -- the original constraint from its component declaration. Sel := Entity (Selector_Name (N)); if Nkind (Parent (Sel)) /= N_Component_Declaration then return Empty; end if; end if; if Is_Access_Type (T) then Desig_Typ := Designated_Type (T); else Desig_Typ := T; end if; if Ekind (Desig_Typ) = E_Array_Subtype then Id := First_Index (Desig_Typ); -- Check whether an index bound is constrained by a discriminant while Present (Id) loop Index_Typ := Underlying_Type (Etype (Id)); if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) or else Denotes_Discriminant (Type_High_Bound (Index_Typ)) then Remove_Side_Effects (P); return Build_Component_Subtype (Build_Actual_Array_Constraint, Loc, Base_Type (T)); end if; Next_Index (Id); end loop; elsif Is_Composite_Type (Desig_Typ) and then Has_Discriminants (Desig_Typ) and then not Is_Empty_Elmt_List (Discriminant_Constraint (Desig_Typ)) and then not Has_Unknown_Discriminants (Desig_Typ) then if Is_Private_Type (Desig_Typ) and then No (Discriminant_Constraint (Desig_Typ)) then Desig_Typ := Full_View (Desig_Typ); end if; D := First_Elmt (Discriminant_Constraint (Desig_Typ)); while Present (D) loop if Denotes_Discriminant (Node (D)) then Remove_Side_Effects (P); return Build_Component_Subtype ( Build_Actual_Record_Constraint, Loc, Base_Type (T)); end if; Next_Elmt (D); end loop; -- Special processing for an access record component that is -- the target of an assignment. If the designated type is an -- unconstrained discriminated record we create its actual -- subtype now. elsif Ekind (T) = E_Access_Type and then Present (Sel) and then Has_Per_Object_Constraint (Sel) and then Nkind (Parent (N)) = N_Assignment_Statement and then N = Name (Parent (N)) -- and then not Inside_Init_Proc -- and then Has_Discriminants (Desig_Typ) -- and then not Is_Constrained (Desig_Typ) then declare S_Indic : constant Node_Id := (Subtype_Indication (Component_Definition (Parent (Sel)))); Discs : List_Id; begin if Nkind (S_Indic) = N_Subtype_Indication then Discs := Constraints (Constraint (S_Indic)); Remove_Side_Effects (P); return Build_Component_Subtype (Build_Access_Record_Constraint (Discs), Loc, T); else return Empty; end if; end; end if; -- If none of the above, the actual and nominal subtypes are the same return Empty; end Build_Actual_Subtype_Of_Component; --------------------------------- -- Build_Class_Wide_Clone_Body -- --------------------------------- procedure Build_Class_Wide_Clone_Body (Spec_Id : Entity_Id; Bod : Node_Id) is Loc : constant Source_Ptr := Sloc (Bod); Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); Clone_Body : Node_Id; Assoc_List : constant Elist_Id := New_Elmt_List; begin -- The declaration of the class-wide clone was created when the -- corresponding class-wide condition was analyzed. -- The body of the original condition may contain references to -- the formals of Spec_Id. In the body of the class-wide clone, -- these must be replaced with the corresponding formals of -- the clone. declare Spec_Formal_Id : Entity_Id := First_Formal (Spec_Id); Clone_Formal_Id : Entity_Id := First_Formal (Clone_Id); begin while Present (Spec_Formal_Id) loop Append_Elmt (Spec_Formal_Id, Assoc_List); Append_Elmt (Clone_Formal_Id, Assoc_List); Next_Formal (Spec_Formal_Id); Next_Formal (Clone_Formal_Id); end loop; end; Clone_Body := Make_Subprogram_Body (Loc, Specification => Copy_Subprogram_Spec (Parent (Clone_Id)), Declarations => Declarations (Bod), Handled_Statement_Sequence => New_Copy_Tree (Handled_Statement_Sequence (Bod), Map => Assoc_List)); -- The new operation is internal and overriding indicators do not apply -- (the original primitive may have carried one). Set_Must_Override (Specification (Clone_Body), False); -- If the subprogram body is the proper body of a stub, insert the -- subprogram after the stub, i.e. the same declarative region as -- the original sugprogram. if Nkind (Parent (Bod)) = N_Subunit then Insert_After (Corresponding_Stub (Parent (Bod)), Clone_Body); else Insert_Before (Bod, Clone_Body); end if; Analyze (Clone_Body); end Build_Class_Wide_Clone_Body; --------------------------------- -- Build_Class_Wide_Clone_Call -- --------------------------------- function Build_Class_Wide_Clone_Call (Loc : Source_Ptr; Decls : List_Id; Spec_Id : Entity_Id; Spec : Node_Id) return Node_Id is Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id); Actuals : List_Id; Call : Node_Id; Formal : Entity_Id; New_Body : Node_Id; New_F_Spec : Entity_Id; New_Formal : Entity_Id; begin Actuals := Empty_List; Formal := First_Formal (Spec_Id); New_F_Spec := First (Parameter_Specifications (Spec)); -- Build parameter association for call to class-wide clone. while Present (Formal) loop New_Formal := Defining_Identifier (New_F_Spec); -- If controlling argument and operation is inherited, add conversion -- to parent type for the call. if Etype (Formal) = Par_Type and then not Is_Empty_List (Decls) then Append_To (Actuals, Make_Type_Conversion (Loc, New_Occurrence_Of (Par_Type, Loc), New_Occurrence_Of (New_Formal, Loc))); else Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); end if; Next_Formal (Formal); Next (New_F_Spec); end loop; if Ekind (Spec_Id) = E_Procedure then Call := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Clone_Id, Loc), Parameter_Associations => Actuals); else Call := Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (Clone_Id, Loc), Parameter_Associations => Actuals)); end if; New_Body := Make_Subprogram_Body (Loc, Specification => Copy_Subprogram_Spec (Spec), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Call), End_Label => Make_Identifier (Loc, Chars (Spec_Id)))); return New_Body; end Build_Class_Wide_Clone_Call; --------------------------------- -- Build_Class_Wide_Clone_Decl -- --------------------------------- procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is Loc : constant Source_Ptr := Sloc (Spec_Id); Clone_Id : constant Entity_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (Spec_Id), Suffix => "CL")); Decl : Node_Id; Spec : Node_Id; begin Spec := Copy_Subprogram_Spec (Parent (Spec_Id)); Set_Must_Override (Spec, False); Set_Must_Not_Override (Spec, False); Set_Defining_Unit_Name (Spec, Clone_Id); Decl := Make_Subprogram_Declaration (Loc, Spec); Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id))); -- Link clone to original subprogram, for use when building body and -- wrapper call to inherited operation. Set_Class_Wide_Clone (Spec_Id, Clone_Id); -- Inherit debug info flag from Spec_Id to Clone_Id to allow debugging -- of the class-wide clone subprogram. if Needs_Debug_Info (Spec_Id) then Set_Debug_Info_Needed (Clone_Id); end if; end Build_Class_Wide_Clone_Decl; ----------------------------- -- Build_Component_Subtype -- ----------------------------- function Build_Component_Subtype (C : List_Id; Loc : Source_Ptr; T : Entity_Id) return Node_Id is Subt : Entity_Id; Decl : Node_Id; begin -- Unchecked_Union components do not require component subtypes if Is_Unchecked_Union (T) then return Empty; end if; Subt := Make_Temporary (Loc, 'S'); Set_Is_Internal (Subt); Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Subt, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => C))); Mark_Rewrite_Insertion (Decl); return Decl; end Build_Component_Subtype; ----------------------------- -- Build_Constrained_Itype -- ----------------------------- procedure Build_Constrained_Itype (N : Node_Id; Typ : Entity_Id; New_Assoc_List : List_Id) is Constrs : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (N); Def_Id : Entity_Id; Indic : Node_Id; New_Assoc : Node_Id; Subtyp_Decl : Node_Id; begin New_Assoc := First (New_Assoc_List); while Present (New_Assoc) loop -- There is exactly one choice in the component association (and -- it is either a discriminant, a component or the others clause). pragma Assert (List_Length (Choices (New_Assoc)) = 1); -- Duplicate expression for the discriminant and put it on the -- list of constraints for the itype declaration. if Is_Entity_Name (First (Choices (New_Assoc))) and then Ekind (Entity (First (Choices (New_Assoc)))) = E_Discriminant then Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc))); end if; Next (New_Assoc); end loop; if Has_Unknown_Discriminants (Typ) and then Present (Underlying_Record_View (Typ)) then Indic := Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Underlying_Record_View (Typ), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constrs)); else Indic := Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constrs)); end if; Def_Id := Create_Itype (Ekind (Typ), N); Subtyp_Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Def_Id, Subtype_Indication => Indic); Set_Parent (Subtyp_Decl, Parent (N)); -- Itypes must be analyzed with checks off (see itypes.ads) Analyze (Subtyp_Decl, Suppress => All_Checks); Set_Etype (N, Def_Id); end Build_Constrained_Itype; --------------------------- -- Build_Default_Subtype -- --------------------------- function Build_Default_Subtype (T : Entity_Id; N : Node_Id) return Entity_Id is Loc : constant Source_Ptr := Sloc (N); Disc : Entity_Id; Bas : Entity_Id; -- The base type that is to be constrained by the defaults begin if not Has_Discriminants (T) or else Is_Constrained (T) then return T; end if; Bas := Base_Type (T); -- If T is non-private but its base type is private, this is the -- completion of a subtype declaration whose parent type is private -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants -- are to be found in the full view of the base. Check that the private -- status of T and its base differ. if Is_Private_Type (Bas) and then not Is_Private_Type (T) and then Present (Full_View (Bas)) then Bas := Full_View (Bas); end if; Disc := First_Discriminant (T); if No (Discriminant_Default_Value (Disc)) then return T; end if; declare Act : constant Entity_Id := Make_Temporary (Loc, 'S'); Constraints : constant List_Id := New_List; Decl : Node_Id; begin while Present (Disc) loop Append_To (Constraints, New_Copy_Tree (Discriminant_Default_Value (Disc))); Next_Discriminant (Disc); end loop; Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Act, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Bas, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constraints))); Insert_Action (N, Decl); -- If the context is a component declaration the subtype declaration -- will be analyzed when the enclosing type is frozen, otherwise do -- it now. if Ekind (Current_Scope) /= E_Record_Type then Analyze (Decl); end if; return Act; end; end Build_Default_Subtype; -------------------------------------------- -- Build_Discriminal_Subtype_Of_Component -- -------------------------------------------- function Build_Discriminal_Subtype_Of_Component (T : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (T); D : Elmt_Id; Id : Node_Id; function Build_Discriminal_Array_Constraint return List_Id; -- If one or more of the bounds of the component depends on -- discriminants, build actual constraint using the discriminants -- of the prefix. function Build_Discriminal_Record_Constraint return List_Id; -- Similar to previous one, for discriminated components constrained by -- the discriminant of the enclosing object. ---------------------------------------- -- Build_Discriminal_Array_Constraint -- ---------------------------------------- function Build_Discriminal_Array_Constraint return List_Id is Constraints : constant List_Id := New_List; Indx : Node_Id; Hi : Node_Id; Lo : Node_Id; Old_Hi : Node_Id; Old_Lo : Node_Id; begin Indx := First_Index (T); while Present (Indx) loop Old_Lo := Type_Low_Bound (Etype (Indx)); Old_Hi := Type_High_Bound (Etype (Indx)); if Denotes_Discriminant (Old_Lo) then Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); else Lo := New_Copy_Tree (Old_Lo); end if; if Denotes_Discriminant (Old_Hi) then Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); else Hi := New_Copy_Tree (Old_Hi); end if; Append (Make_Range (Loc, Lo, Hi), Constraints); Next_Index (Indx); end loop; return Constraints; end Build_Discriminal_Array_Constraint; ----------------------------------------- -- Build_Discriminal_Record_Constraint -- ----------------------------------------- function Build_Discriminal_Record_Constraint return List_Id is Constraints : constant List_Id := New_List; D : Elmt_Id; D_Val : Node_Id; begin D := First_Elmt (Discriminant_Constraint (T)); while Present (D) loop if Denotes_Discriminant (Node (D)) then D_Val := New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); else D_Val := New_Copy_Tree (Node (D)); end if; Append (D_Val, Constraints); Next_Elmt (D); end loop; return Constraints; end Build_Discriminal_Record_Constraint; -- Start of processing for Build_Discriminal_Subtype_Of_Component begin if Ekind (T) = E_Array_Subtype then Id := First_Index (T); while Present (Id) loop if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else Denotes_Discriminant (Type_High_Bound (Etype (Id))) then return Build_Component_Subtype (Build_Discriminal_Array_Constraint, Loc, T); end if; Next_Index (Id); end loop; elsif Ekind (T) = E_Record_Subtype and then Has_Discriminants (T) and then not Has_Unknown_Discriminants (T) then D := First_Elmt (Discriminant_Constraint (T)); while Present (D) loop if Denotes_Discriminant (Node (D)) then return Build_Component_Subtype (Build_Discriminal_Record_Constraint, Loc, T); end if; Next_Elmt (D); end loop; end if; -- If none of the above, the actual and nominal subtypes are the same return Empty; end Build_Discriminal_Subtype_Of_Component; ------------------------------ -- Build_Elaboration_Entity -- ------------------------------ procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); Decl : Node_Id; Elab_Ent : Entity_Id; procedure Set_Package_Name (Ent : Entity_Id); -- Given an entity, sets the fully qualified name of the entity in -- Name_Buffer, with components separated by double underscores. This -- is a recursive routine that climbs the scope chain to Standard. ---------------------- -- Set_Package_Name -- ---------------------- procedure Set_Package_Name (Ent : Entity_Id) is begin if Scope (Ent) /= Standard_Standard then Set_Package_Name (Scope (Ent)); declare Nam : constant String := Get_Name_String (Chars (Ent)); begin Name_Buffer (Name_Len + 1) := '_'; Name_Buffer (Name_Len + 2) := '_'; Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam; Name_Len := Name_Len + Nam'Length + 2; end; else Get_Name_String (Chars (Ent)); end if; end Set_Package_Name; -- Start of processing for Build_Elaboration_Entity begin -- Ignore call if already constructed if Present (Elaboration_Entity (Spec_Id)) then return; -- Do not generate an elaboration entity in GNATprove move because the -- elaboration counter is a form of expansion. elsif GNATprove_Mode then return; -- See if we need elaboration entity -- We always need an elaboration entity when preserving control flow, as -- we want to remain explicit about the unit's elaboration order. elsif Opt.Suppress_Control_Flow_Optimizations then null; -- We always need an elaboration entity for the dynamic elaboration -- model, since it is needed to properly generate the PE exception for -- access before elaboration. elsif Dynamic_Elaboration_Checks then null; -- For the static model, we don't need the elaboration counter if this -- unit is sure to have no elaboration code, since that means there -- is no elaboration unit to be called. Note that we can't just decide -- after the fact by looking to see whether there was elaboration code, -- because that's too late to make this decision. elsif Restriction_Active (No_Elaboration_Code) then return; -- Similarly, for the static model, we can skip the elaboration counter -- if we have the No_Multiple_Elaboration restriction, since for the -- static model, that's the only purpose of the counter (to avoid -- multiple elaboration). elsif Restriction_Active (No_Multiple_Elaboration) then return; end if; -- Here we need the elaboration entity -- Construct name of elaboration entity as xxx_E, where xxx is the unit -- name with dots replaced by double underscore. We have to manually -- construct this name, since it will be elaborated in the outer scope, -- and thus will not have the unit name automatically prepended. Set_Package_Name (Spec_Id); Add_Str_To_Name_Buffer ("_E"); -- Create elaboration counter Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find); Set_Elaboration_Entity (Spec_Id, Elab_Ent); Decl := Make_Object_Declaration (Loc, Defining_Identifier => Elab_Ent, Object_Definition => New_Occurrence_Of (Standard_Short_Integer, Loc), Expression => Make_Integer_Literal (Loc, Uint_0)); Push_Scope (Standard_Standard); Add_Global_Declaration (Decl); Pop_Scope; -- Reset True_Constant indication, since we will indeed assign a value -- to the variable in the binder main. We also kill the Current_Value -- and Last_Assignment fields for the same reason. Set_Is_True_Constant (Elab_Ent, False); Set_Current_Value (Elab_Ent, Empty); Set_Last_Assignment (Elab_Ent, Empty); -- We do not want any further qualification of the name (if we did not -- do this, we would pick up the name of the generic package in the case -- of a library level generic instantiation). Set_Has_Qualified_Name (Elab_Ent); Set_Has_Fully_Qualified_Name (Elab_Ent); end Build_Elaboration_Entity; -------------------------------- -- Build_Explicit_Dereference -- -------------------------------- procedure Build_Explicit_Dereference (Expr : Node_Id; Disc : Entity_Id) is Loc : constant Source_Ptr := Sloc (Expr); I : Interp_Index; It : Interp; begin -- An entity of a type with a reference aspect is overloaded with -- both interpretations: with and without the dereference. Now that -- the dereference is made explicit, set the type of the node properly, -- to prevent anomalies in the backend. Same if the expression is an -- overloaded function call whose return type has a reference aspect. if Is_Entity_Name (Expr) then Set_Etype (Expr, Etype (Entity (Expr))); -- The designated entity will not be examined again when resolving -- the dereference, so generate a reference to it now. Generate_Reference (Entity (Expr), Expr); elsif Nkind (Expr) = N_Function_Call then -- If the name of the indexing function is overloaded, locate the one -- whose return type has an implicit dereference on the desired -- discriminant, and set entity and type of function call. if Is_Overloaded (Name (Expr)) then Get_First_Interp (Name (Expr), I, It); while Present (It.Nam) loop if Ekind ((It.Typ)) = E_Record_Type and then First_Entity ((It.Typ)) = Disc then Set_Entity (Name (Expr), It.Nam); Set_Etype (Name (Expr), Etype (It.Nam)); exit; end if; Get_Next_Interp (I, It); end loop; end if; -- Set type of call from resolved function name. Set_Etype (Expr, Etype (Name (Expr))); end if; Set_Is_Overloaded (Expr, False); -- The expression will often be a generalized indexing that yields a -- container element that is then dereferenced, in which case the -- generalized indexing call is also non-overloaded. if Nkind (Expr) = N_Indexed_Component and then Present (Generalized_Indexing (Expr)) then Set_Is_Overloaded (Generalized_Indexing (Expr), False); end if; Rewrite (Expr, Make_Explicit_Dereference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Relocate_Node (Expr), Selector_Name => New_Occurrence_Of (Disc, Loc)))); Set_Etype (Prefix (Expr), Etype (Disc)); Set_Etype (Expr, Designated_Type (Etype (Disc))); end Build_Explicit_Dereference; --------------------------- -- Build_Overriding_Spec -- --------------------------- function Build_Overriding_Spec (Op : Entity_Id; Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op); Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op)); Formal_Spec : Node_Id; Formal_Type : Node_Id; New_Spec : Node_Id; begin New_Spec := Copy_Subprogram_Spec (Spec); Formal_Spec := First (Parameter_Specifications (New_Spec)); while Present (Formal_Spec) loop Formal_Type := Parameter_Type (Formal_Spec); if Is_Entity_Name (Formal_Type) and then Entity (Formal_Type) = Par_Typ then Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc)); end if; -- Nothing needs to be done for access parameters Next (Formal_Spec); end loop; return New_Spec; end Build_Overriding_Spec; ------------------- -- Build_Subtype -- ------------------- function Build_Subtype (Related_Node : Node_Id; Loc : Source_Ptr; Typ : Entity_Id; Constraints : List_Id) return Entity_Id is Indic : Node_Id; Subtyp_Decl : Node_Id; Def_Id : Entity_Id; Btyp : Entity_Id := Base_Type (Typ); begin -- The Related_Node better be here or else we won't be able to -- attach new itypes to a node in the tree. pragma Assert (Present (Related_Node)); -- If the view of the component's type is incomplete or private -- with unknown discriminants, then the constraint must be applied -- to the full type. if Has_Unknown_Discriminants (Btyp) and then Present (Underlying_Type (Btyp)) then Btyp := Underlying_Type (Btyp); end if; Indic := Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Btyp, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints)); Def_Id := Create_Itype (Ekind (Typ), Related_Node); Subtyp_Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Def_Id, Subtype_Indication => Indic); Set_Parent (Subtyp_Decl, Parent (Related_Node)); -- Itypes must be analyzed with checks off (see package Itypes) Analyze (Subtyp_Decl, Suppress => All_Checks); if Is_Itype (Def_Id) and then Has_Predicates (Typ) then Inherit_Predicate_Flags (Def_Id, Typ); -- Indicate where the predicate function may be found if Is_Itype (Typ) then if Present (Predicate_Function (Def_Id)) then null; elsif Present (Predicate_Function (Typ)) then Set_Predicate_Function (Def_Id, Predicate_Function (Typ)); else Set_Predicated_Parent (Def_Id, Predicated_Parent (Typ)); end if; elsif No (Predicate_Function (Def_Id)) then Set_Predicated_Parent (Def_Id, Typ); end if; end if; return Def_Id; end Build_Subtype; ----------------------------------- -- Cannot_Raise_Constraint_Error -- ----------------------------------- function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is begin if Compile_Time_Known_Value (Expr) then return True; elsif Do_Range_Check (Expr) then return False; elsif Raises_Constraint_Error (Expr) then return False; else case Nkind (Expr) is when N_Identifier => return True; when N_Expanded_Name => return True; when N_Selected_Component => return not Do_Discriminant_Check (Expr); when N_Attribute_Reference => if Do_Overflow_Check (Expr) then return False; elsif No (Expressions (Expr)) then return True; else declare N : Node_Id; begin N := First (Expressions (Expr)); while Present (N) loop if Cannot_Raise_Constraint_Error (N) then Next (N); else return False; end if; end loop; return True; end; end if; when N_Type_Conversion => if Do_Overflow_Check (Expr) or else Do_Length_Check (Expr) or else Do_Tag_Check (Expr) then return False; else return Cannot_Raise_Constraint_Error (Expression (Expr)); end if; when N_Unchecked_Type_Conversion => return Cannot_Raise_Constraint_Error (Expression (Expr)); when N_Unary_Op => if Do_Overflow_Check (Expr) then return False; else return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; when N_Op_Divide | N_Op_Mod | N_Op_Rem => if Do_Division_Check (Expr) or else Do_Overflow_Check (Expr) then return False; else return Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) and then Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; when N_Op_Add | N_Op_And | N_Op_Concat | N_Op_Eq | N_Op_Expon | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Multiply | N_Op_Ne | N_Op_Or | N_Op_Rotate_Left | N_Op_Rotate_Right | N_Op_Shift_Left | N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic | N_Op_Subtract | N_Op_Xor => if Do_Overflow_Check (Expr) then return False; else return Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) and then Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; when others => return False; end case; end if; end Cannot_Raise_Constraint_Error; ------------------------------- -- Check_Ambiguous_Aggregate -- ------------------------------- procedure Check_Ambiguous_Aggregate (Call : Node_Id) is Actual : Node_Id; begin if Extensions_Allowed then Actual := First_Actual (Call); while Present (Actual) loop if Nkind (Actual) = N_Aggregate then Error_Msg_N ("\add type qualification to aggregate actual", Actual); exit; end if; Next_Actual (Actual); end loop; end if; end Check_Ambiguous_Aggregate; ----------------------------------------- -- Check_Dynamically_Tagged_Expression -- ----------------------------------------- procedure Check_Dynamically_Tagged_Expression (Expr : Node_Id; Typ : Entity_Id; Related_Nod : Node_Id) is begin pragma Assert (Is_Tagged_Type (Typ)); -- In order to avoid spurious errors when analyzing the expanded code, -- this check is done only for nodes that come from source and for -- actuals of generic instantiations. if (Comes_From_Source (Related_Nod) or else In_Generic_Actual (Expr)) and then (Is_Class_Wide_Type (Etype (Expr)) or else Is_Dynamically_Tagged (Expr)) and then not Is_Class_Wide_Type (Typ) then Error_Msg_N ("dynamically tagged expression not allowed!", Expr); end if; end Check_Dynamically_Tagged_Expression; -------------------------- -- Check_Fully_Declared -- -------------------------- procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is begin if Ekind (T) = E_Incomplete_Type then -- Ada 2005 (AI-50217): If the type is available through a limited -- with_clause, verify that its full view has been analyzed. if From_Limited_With (T) and then Present (Non_Limited_View (T)) and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type then -- The non-limited view is fully declared null; else Error_Msg_NE ("premature usage of incomplete}", N, First_Subtype (T)); end if; -- Need comments for these tests ??? elsif Has_Private_Component (T) and then not Is_Generic_Type (Root_Type (T)) and then not In_Spec_Expression then -- Special case: if T is the anonymous type created for a single -- task or protected object, use the name of the source object. if Is_Concurrent_Type (T) and then not Comes_From_Source (T) and then Nkind (N) = N_Object_Declaration then Error_Msg_NE ("type of& has incomplete component", N, Defining_Identifier (N)); else Error_Msg_NE ("premature usage of incomplete}", N, First_Subtype (T)); end if; end if; end Check_Fully_Declared; ------------------------------------------- -- Check_Function_With_Address_Parameter -- ------------------------------------------- procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is F : Entity_Id; T : Entity_Id; begin F := First_Formal (Subp_Id); while Present (F) loop T := Etype (F); if Is_Private_Type (T) and then Present (Full_View (T)) then T := Full_View (T); end if; if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then Set_Is_Pure (Subp_Id, False); exit; end if; Next_Formal (F); end loop; end Check_Function_With_Address_Parameter; ------------------------------------- -- Check_Function_Writable_Actuals -- ------------------------------------- procedure Check_Function_Writable_Actuals (N : Node_Id) is Writable_Actuals_List : Elist_Id := No_Elist; Identifiers_List : Elist_Id := No_Elist; Aggr_Error_Node : Node_Id := Empty; Error_Node : Node_Id := Empty; procedure Collect_Identifiers (N : Node_Id); -- In a single traversal of subtree N collect in Writable_Actuals_List -- all the actuals of functions with writable actuals, and in the list -- Identifiers_List collect all the identifiers that are not actuals of -- functions with writable actuals. If a writable actual is referenced -- twice as writable actual then Error_Node is set to reference its -- second occurrence, the error is reported, and the tree traversal -- is abandoned. ------------------------- -- Collect_Identifiers -- ------------------------- procedure Collect_Identifiers (N : Node_Id) is function Check_Node (N : Node_Id) return Traverse_Result; -- Process a single node during the tree traversal to collect the -- writable actuals of functions and all the identifiers which are -- not writable actuals of functions. function Contains (List : Elist_Id; N : Node_Id) return Boolean; -- Returns True if List has a node whose Entity is Entity (N) ---------------- -- Check_Node -- ---------------- function Check_Node (N : Node_Id) return Traverse_Result is Is_Writable_Actual : Boolean := False; Id : Entity_Id; begin if Nkind (N) = N_Identifier then -- No analysis possible if the entity is not decorated if No (Entity (N)) then return Skip; -- Don't collect identifiers of packages, called functions, etc elsif Ekind (Entity (N)) in E_Package | E_Function | E_Procedure | E_Entry then return Skip; -- For rewritten nodes, continue the traversal in the original -- subtree. Needed to handle aggregates in original expressions -- extracted from the tree by Remove_Side_Effects. elsif Is_Rewrite_Substitution (N) then Collect_Identifiers (Original_Node (N)); return Skip; -- For now we skip aggregate discriminants, since they require -- performing the analysis in two phases to identify conflicts: -- first one analyzing discriminants and second one analyzing -- the rest of components (since at run time, discriminants are -- evaluated prior to components): too much computation cost -- to identify a corner case??? elsif Nkind (Parent (N)) = N_Component_Association and then Nkind (Parent (Parent (N))) in N_Aggregate | N_Extension_Aggregate then declare Choice : constant Node_Id := First (Choices (Parent (N))); begin if Ekind (Entity (N)) = E_Discriminant then return Skip; elsif Expression (Parent (N)) = N and then Nkind (Choice) = N_Identifier and then Ekind (Entity (Choice)) = E_Discriminant then return Skip; end if; end; -- Analyze if N is a writable actual of a function elsif Nkind (Parent (N)) = N_Function_Call then declare Call : constant Node_Id := Parent (N); Actual : Node_Id; Formal : Node_Id; begin Id := Get_Called_Entity (Call); -- In case of previous error, no check is possible if No (Id) then return Abandon; end if; if Ekind (Id) in E_Function | E_Generic_Function and then Has_Out_Or_In_Out_Parameter (Id) then Formal := First_Formal (Id); Actual := First_Actual (Call); while Present (Actual) and then Present (Formal) loop if Actual = N then if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter then Is_Writable_Actual := True; end if; exit; end if; Next_Formal (Formal); Next_Actual (Actual); end loop; end if; end; end if; if Is_Writable_Actual then -- Skip checking the error in non-elementary types since -- RM 6.4.1(6.15/3) is restricted to elementary types, but -- store this actual in Writable_Actuals_List since it is -- needed to perform checks on other constructs that have -- arbitrary order of evaluation (for example, aggregates). if not Is_Elementary_Type (Etype (N)) then if not Contains (Writable_Actuals_List, N) then Append_New_Elmt (N, To => Writable_Actuals_List); end if; -- Second occurrence of an elementary type writable actual elsif Contains (Writable_Actuals_List, N) then -- Report the error on the second occurrence of the -- identifier. We cannot assume that N is the second -- occurrence (according to their location in the -- sources), since Traverse_Func walks through Field2 -- last (see comment in the body of Traverse_Func). declare Elmt : Elmt_Id; begin Elmt := First_Elmt (Writable_Actuals_List); while Present (Elmt) and then Entity (Node (Elmt)) /= Entity (N) loop Next_Elmt (Elmt); end loop; if Sloc (N) > Sloc (Node (Elmt)) then Error_Node := N; else Error_Node := Node (Elmt); end if; Error_Msg_NE ("value may be affected by call to & " & "because order of evaluation is arbitrary", Error_Node, Id); return Abandon; end; -- First occurrence of a elementary type writable actual else Append_New_Elmt (N, To => Writable_Actuals_List); end if; else if Identifiers_List = No_Elist then Identifiers_List := New_Elmt_List; end if; Append_Unique_Elmt (N, Identifiers_List); end if; end if; return OK; end Check_Node; -------------- -- Contains -- -------------- function Contains (List : Elist_Id; N : Node_Id) return Boolean is pragma Assert (Nkind (N) in N_Has_Entity); Elmt : Elmt_Id; begin if List = No_Elist then return False; end if; Elmt := First_Elmt (List); while Present (Elmt) loop if Entity (Node (Elmt)) = Entity (N) then return True; else Next_Elmt (Elmt); end if; end loop; return False; end Contains; ------------------ -- Do_Traversal -- ------------------ procedure Do_Traversal is new Traverse_Proc (Check_Node); -- The traversal procedure -- Start of processing for Collect_Identifiers begin if Present (Error_Node) then return; end if; if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then return; end if; Do_Traversal (N); end Collect_Identifiers; -- Start of processing for Check_Function_Writable_Actuals begin -- The check only applies to Ada 2012 code on which Check_Actuals has -- been set, and only to constructs that have multiple constituents -- whose order of evaluation is not specified by the language. if Ada_Version < Ada_2012 or else not Check_Actuals (N) or else Nkind (N) not in N_Op | N_Membership_Test | N_Range | N_Aggregate | N_Extension_Aggregate | N_Full_Type_Declaration | N_Function_Call | N_Procedure_Call_Statement | N_Entry_Call_Statement or else (Nkind (N) = N_Full_Type_Declaration and then not Is_Record_Type (Defining_Identifier (N))) -- In addition, this check only applies to source code, not to code -- generated by constraint checks. or else not Comes_From_Source (N) then return; end if; -- If a construct C has two or more direct constituents that are names -- or expressions whose evaluation may occur in an arbitrary order, at -- least one of which contains a function call with an in out or out -- parameter, then the construct is legal only if: for each name N that -- is passed as a parameter of mode in out or out to some inner function -- call C2 (not including the construct C itself), there is no other -- name anywhere within a direct constituent of the construct C other -- than the one containing C2, that is known to refer to the same -- object (RM 6.4.1(6.17/3)). case Nkind (N) is when N_Range => Collect_Identifiers (Low_Bound (N)); Collect_Identifiers (High_Bound (N)); when N_Membership_Test | N_Op => declare Expr : Node_Id; begin Collect_Identifiers (Left_Opnd (N)); if Present (Right_Opnd (N)) then Collect_Identifiers (Right_Opnd (N)); end if; if Nkind (N) in N_In | N_Not_In and then Present (Alternatives (N)) then Expr := First (Alternatives (N)); while Present (Expr) loop Collect_Identifiers (Expr); Next (Expr); end loop; end if; end; when N_Full_Type_Declaration => declare function Get_Record_Part (N : Node_Id) return Node_Id; -- Return the record part of this record type definition function Get_Record_Part (N : Node_Id) return Node_Id is Type_Def : constant Node_Id := Type_Definition (N); begin if Nkind (Type_Def) = N_Derived_Type_Definition then return Record_Extension_Part (Type_Def); else return Type_Def; end if; end Get_Record_Part; Comp : Node_Id; Def_Id : Entity_Id := Defining_Identifier (N); Rec : Node_Id := Get_Record_Part (N); begin -- No need to perform any analysis if the record has no -- components if No (Rec) or else No (Component_List (Rec)) then return; end if; -- Collect the identifiers starting from the deepest -- derivation. Done to report the error in the deepest -- derivation. loop if Present (Component_List (Rec)) then Comp := First (Component_Items (Component_List (Rec))); while Present (Comp) loop if Nkind (Comp) = N_Component_Declaration and then Present (Expression (Comp)) then Collect_Identifiers (Expression (Comp)); end if; Next (Comp); end loop; end if; exit when No (Underlying_Type (Etype (Def_Id))) or else Base_Type (Underlying_Type (Etype (Def_Id))) = Def_Id; Def_Id := Base_Type (Underlying_Type (Etype (Def_Id))); Rec := Get_Record_Part (Parent (Def_Id)); end loop; end; when N_Entry_Call_Statement | N_Subprogram_Call => declare Id : constant Entity_Id := Get_Called_Entity (N); Formal : Node_Id; Actual : Node_Id; begin Formal := First_Formal (Id); Actual := First_Actual (N); while Present (Actual) and then Present (Formal) loop if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter then Collect_Identifiers (Actual); end if; Next_Formal (Formal); Next_Actual (Actual); end loop; end; when N_Aggregate | N_Extension_Aggregate => declare Assoc : Node_Id; Choice : Node_Id; Comp_Expr : Node_Id; begin -- Handle the N_Others_Choice of array aggregates with static -- bounds. There is no need to perform this analysis in -- aggregates without static bounds since we cannot evaluate -- if the N_Others_Choice covers several elements. There is -- no need to handle the N_Others choice of record aggregates -- since at this stage it has been already expanded by -- Resolve_Record_Aggregate. if Is_Array_Type (Etype (N)) and then Nkind (N) = N_Aggregate and then Present (Aggregate_Bounds (N)) and then Compile_Time_Known_Bounds (Etype (N)) and then Expr_Value (High_Bound (Aggregate_Bounds (N))) > Expr_Value (Low_Bound (Aggregate_Bounds (N))) then declare Count_Components : Uint := Uint_0; Num_Components : Uint; Others_Assoc : Node_Id := Empty; Others_Choice : Node_Id := Empty; Others_Box_Present : Boolean := False; begin -- Count positional associations if Present (Expressions (N)) then Comp_Expr := First (Expressions (N)); while Present (Comp_Expr) loop Count_Components := Count_Components + 1; Next (Comp_Expr); end loop; end if; -- Count the rest of elements and locate the N_Others -- choice (if any) Assoc := First (Component_Associations (N)); while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) loop if Nkind (Choice) = N_Others_Choice then Others_Assoc := Assoc; Others_Choice := Choice; Others_Box_Present := Box_Present (Assoc); -- Count several components elsif Nkind (Choice) in N_Range | N_Subtype_Indication or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) then declare L, H : Node_Id; begin Get_Index_Bounds (Choice, L, H); pragma Assert (Compile_Time_Known_Value (L) and then Compile_Time_Known_Value (H)); Count_Components := Count_Components + Expr_Value (H) - Expr_Value (L) + 1; end; -- Count single component. No other case available -- since we are handling an aggregate with static -- bounds. else pragma Assert (Is_OK_Static_Expression (Choice) or else Nkind (Choice) = N_Identifier or else Nkind (Choice) = N_Integer_Literal); Count_Components := Count_Components + 1; end if; Next (Choice); end loop; Next (Assoc); end loop; Num_Components := Expr_Value (High_Bound (Aggregate_Bounds (N))) - Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1; pragma Assert (Count_Components <= Num_Components); -- Handle the N_Others choice if it covers several -- components if Present (Others_Choice) and then (Num_Components - Count_Components) > 1 then if not Others_Box_Present then -- At this stage, if expansion is active, the -- expression of the others choice has not been -- analyzed. Hence we generate a duplicate and -- we analyze it silently to have available the -- minimum decoration required to collect the -- identifiers. pragma Assert (Present (Others_Assoc)); if not Expander_Active then Comp_Expr := Expression (Others_Assoc); else Comp_Expr := New_Copy_Tree (Expression (Others_Assoc)); Preanalyze_Without_Errors (Comp_Expr); end if; Collect_Identifiers (Comp_Expr); if Writable_Actuals_List /= No_Elist then -- As suggested by Robert, at current stage we -- report occurrences of this case as warnings. Error_Msg_N ("writable function parameter may affect " & "value in other component because order " & "of evaluation is unspecified??", Node (First_Elmt (Writable_Actuals_List))); end if; end if; end if; end; -- For an array aggregate, a discrete_choice_list that has -- a nonstatic range is considered as two or more separate -- occurrences of the expression (RM 6.4.1(20/3)). elsif Is_Array_Type (Etype (N)) and then Nkind (N) = N_Aggregate and then Present (Aggregate_Bounds (N)) and then not Compile_Time_Known_Bounds (Etype (N)) then -- Collect identifiers found in the dynamic bounds declare Count_Components : Natural := 0; Low, High : Node_Id; begin Assoc := First (Component_Associations (N)); while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) loop if Nkind (Choice) in N_Range | N_Subtype_Indication or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) then Get_Index_Bounds (Choice, Low, High); if not Compile_Time_Known_Value (Low) then Collect_Identifiers (Low); if No (Aggr_Error_Node) then Aggr_Error_Node := Low; end if; end if; if not Compile_Time_Known_Value (High) then Collect_Identifiers (High); if No (Aggr_Error_Node) then Aggr_Error_Node := High; end if; end if; -- The RM rule is violated if there is more than -- a single choice in a component association. else Count_Components := Count_Components + 1; if No (Aggr_Error_Node) and then Count_Components > 1 then Aggr_Error_Node := Choice; end if; if not Compile_Time_Known_Value (Choice) then Collect_Identifiers (Choice); end if; end if; Next (Choice); end loop; Next (Assoc); end loop; end; end if; -- Handle ancestor part of extension aggregates if Nkind (N) = N_Extension_Aggregate then Collect_Identifiers (Ancestor_Part (N)); end if; -- Handle positional associations if Present (Expressions (N)) then Comp_Expr := First (Expressions (N)); while Present (Comp_Expr) loop if not Is_OK_Static_Expression (Comp_Expr) then Collect_Identifiers (Comp_Expr); end if; Next (Comp_Expr); end loop; end if; -- Handle discrete associations if Present (Component_Associations (N)) then Assoc := First (Component_Associations (N)); while Present (Assoc) loop if not Box_Present (Assoc) then Choice := First (Choices (Assoc)); while Present (Choice) loop -- For now we skip discriminants since it requires -- performing the analysis in two phases: first one -- analyzing discriminants and second one analyzing -- the rest of components since discriminants are -- evaluated prior to components: too much extra -- work to detect a corner case??? if Nkind (Choice) in N_Has_Entity and then Present (Entity (Choice)) and then Ekind (Entity (Choice)) = E_Discriminant then null; elsif Box_Present (Assoc) then null; else if not Analyzed (Expression (Assoc)) then Comp_Expr := New_Copy_Tree (Expression (Assoc)); Set_Parent (Comp_Expr, Parent (N)); Preanalyze_Without_Errors (Comp_Expr); else Comp_Expr := Expression (Assoc); end if; Collect_Identifiers (Comp_Expr); end if; Next (Choice); end loop; end if; Next (Assoc); end loop; end if; end; when others => return; end case; -- No further action needed if we already reported an error if Present (Error_Node) then return; end if; -- Check violation of RM 6.20/3 in aggregates if Present (Aggr_Error_Node) and then Writable_Actuals_List /= No_Elist then Error_Msg_N ("value may be affected by call in other component because they " & "are evaluated in unspecified order", Node (First_Elmt (Writable_Actuals_List))); return; end if; -- Check if some writable argument of a function is referenced if Writable_Actuals_List /= No_Elist and then Identifiers_List /= No_Elist then declare Elmt_1 : Elmt_Id; Elmt_2 : Elmt_Id; begin Elmt_1 := First_Elmt (Writable_Actuals_List); while Present (Elmt_1) loop Elmt_2 := First_Elmt (Identifiers_List); while Present (Elmt_2) loop if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then case Nkind (Parent (Node (Elmt_2))) is when N_Aggregate | N_Component_Association | N_Component_Declaration => Error_Msg_N ("value may be affected by call in other " & "component because they are evaluated " & "in unspecified order", Node (Elmt_2)); when N_In | N_Not_In => Error_Msg_N ("value may be affected by call in other " & "alternative because they are evaluated " & "in unspecified order", Node (Elmt_2)); when others => Error_Msg_N ("value of actual may be affected by call in " & "other actual because they are evaluated " & "in unspecified order", Node (Elmt_2)); end case; end if; Next_Elmt (Elmt_2); end loop; Next_Elmt (Elmt_1); end loop; end; end if; end Check_Function_Writable_Actuals; -------------------------------- -- Check_Implicit_Dereference -- -------------------------------- procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is Disc : Entity_Id; Desig : Entity_Id; Nam : Node_Id; begin if Nkind (N) = N_Indexed_Component and then Present (Generalized_Indexing (N)) then Nam := Generalized_Indexing (N); else Nam := N; end if; if Ada_Version < Ada_2012 or else not Has_Implicit_Dereference (Base_Type (Typ)) then return; elsif not Comes_From_Source (N) and then Nkind (N) /= N_Indexed_Component then return; elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then null; else Disc := First_Discriminant (Typ); while Present (Disc) loop if Has_Implicit_Dereference (Disc) then Desig := Designated_Type (Etype (Disc)); Add_One_Interp (Nam, Disc, Desig); -- If the node is a generalized indexing, add interpretation -- to that node as well, for subsequent resolution. if Nkind (N) = N_Indexed_Component then Add_One_Interp (N, Disc, Desig); end if; -- If the operation comes from a generic unit and the context -- is a selected component, the selector name may be global -- and set in the instance already. Remove the entity to -- force resolution of the selected component, and the -- generation of an explicit dereference if needed. if In_Instance and then Nkind (Parent (Nam)) = N_Selected_Component then Set_Entity (Selector_Name (Parent (Nam)), Empty); end if; exit; end if; Next_Discriminant (Disc); end loop; end if; end Check_Implicit_Dereference; ---------------------------------- -- Check_Internal_Protected_Use -- ---------------------------------- procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is S : Entity_Id; Prot : Entity_Id; begin Prot := Empty; S := Current_Scope; while Present (S) loop if S = Standard_Standard then exit; elsif Ekind (S) = E_Function and then Ekind (Scope (S)) = E_Protected_Type then Prot := Scope (S); exit; end if; S := Scope (S); end loop; if Present (Prot) and then Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then -- An indirect function call (e.g. a callback within a protected -- function body) is not statically illegal. If the access type is -- anonymous and is the type of an access parameter, the scope of Nam -- will be the protected type, but it is not a protected operation. if Ekind (Nam) = E_Subprogram_Type and then Nkind (Associated_Node_For_Itype (Nam)) = N_Function_Specification then null; elsif Nkind (N) = N_Subprogram_Renaming_Declaration then Error_Msg_N ("within protected function cannot use protected procedure in " & "renaming or as generic actual", N); elsif Nkind (N) = N_Attribute_Reference then Error_Msg_N ("within protected function cannot take access of protected " & "procedure", N); else Error_Msg_N ("within protected function, protected object is constant", N); Error_Msg_N ("\cannot call operation that may modify it", N); end if; end if; -- Verify that an internal call does not appear within a precondition -- of a protected operation. This implements AI12-0166. -- The precondition aspect has been rewritten as a pragma Precondition -- and we check whether the scope of the called subprogram is the same -- as that of the entity to which the aspect applies. if Convention (Nam) = Convention_Protected then declare P : Node_Id; begin P := Parent (N); while Present (P) loop if Nkind (P) = N_Pragma and then Chars (Pragma_Identifier (P)) = Name_Precondition and then From_Aspect_Specification (P) and then Scope (Entity (Corresponding_Aspect (P))) = Scope (Nam) then Error_Msg_N ("internal call cannot appear in precondition of " & "protected operation", N); return; elsif Nkind (P) = N_Pragma and then Chars (Pragma_Identifier (P)) = Name_Contract_Cases then -- Check whether call is in a case guard. It is legal in a -- consequence. P := N; while Present (P) loop if Nkind (Parent (P)) = N_Component_Association and then P /= Expression (Parent (P)) then Error_Msg_N ("internal call cannot appear in case guard in a " & "contract case", N); end if; P := Parent (P); end loop; return; elsif Nkind (P) = N_Parameter_Specification and then Scope (Current_Scope) = Scope (Nam) and then Nkind (Parent (P)) in N_Entry_Declaration | N_Subprogram_Declaration then Error_Msg_N ("internal call cannot appear in default for formal of " & "protected operation", N); return; end if; P := Parent (P); end loop; end; end if; end Check_Internal_Protected_Use; --------------------------------------- -- Check_Later_Vs_Basic_Declarations -- --------------------------------------- procedure Check_Later_Vs_Basic_Declarations (Decls : List_Id; During_Parsing : Boolean) is Body_Sloc : Source_Ptr; Decl : Node_Id; function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean; -- Return whether Decl is considered as a declarative item. -- When During_Parsing is True, the semantics of Ada 83 is followed. -- When During_Parsing is False, the semantics of SPARK is followed. ------------------------------- -- Is_Later_Declarative_Item -- ------------------------------- function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is begin if Nkind (Decl) in N_Later_Decl_Item then return True; elsif Nkind (Decl) = N_Pragma then return True; elsif During_Parsing then return False; -- In SPARK, a package declaration is not considered as a later -- declarative item. elsif Nkind (Decl) = N_Package_Declaration then return False; -- In SPARK, a renaming is considered as a later declarative item elsif Nkind (Decl) in N_Renaming_Declaration then return True; else return False; end if; end Is_Later_Declarative_Item; -- Start of processing for Check_Later_Vs_Basic_Declarations begin Decl := First (Decls); -- Loop through sequence of basic declarative items Outer : while Present (Decl) loop if Nkind (Decl) not in N_Subprogram_Body | N_Package_Body | N_Task_Body and then Nkind (Decl) not in N_Body_Stub then Next (Decl); -- Once a body is encountered, we only allow later declarative -- items. The inner loop checks the rest of the list. else Body_Sloc := Sloc (Decl); Inner : while Present (Decl) loop if not Is_Later_Declarative_Item (Decl) then if During_Parsing then if Ada_Version = Ada_83 then Error_Msg_Sloc := Body_Sloc; Error_Msg_N ("(Ada 83) decl cannot appear after body#", Decl); end if; end if; end if; Next (Decl); end loop Inner; end if; end loop Outer; end Check_Later_Vs_Basic_Declarations; --------------------------- -- Check_No_Hidden_State -- --------------------------- procedure Check_No_Hidden_State (Id : Entity_Id) is Context : Entity_Id := Empty; Not_Visible : Boolean := False; Scop : Entity_Id; begin pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable); -- Nothing to do for internally-generated abstract states and variables -- because they do not represent the hidden state of the source unit. if not Comes_From_Source (Id) then return; end if; -- Find the proper context where the object or state appears Scop := Scope (Id); while Present (Scop) loop Context := Scop; -- Keep track of the context's visibility Not_Visible := Not_Visible or else In_Private_Part (Context); -- Prevent the search from going too far if Context = Standard_Standard then return; -- Objects and states that appear immediately within a subprogram or -- entry inside a construct nested within a subprogram do not -- introduce a hidden state. They behave as local variable -- declarations. The same is true for elaboration code inside a block -- or a task. elsif Is_Subprogram_Or_Entry (Context) or else Ekind (Context) in E_Block | E_Task_Type then return; end if; -- Stop the traversal when a package subject to a null abstract state -- has been found. if Is_Package_Or_Generic_Package (Context) and then Has_Null_Abstract_State (Context) then exit; end if; Scop := Scope (Scop); end loop; -- At this point we know that there is at least one package with a null -- abstract state in visibility. Emit an error message unconditionally -- if the entity being processed is a state because the placement of the -- related package is irrelevant. This is not the case for objects as -- the intermediate context matters. if Present (Context) and then (Ekind (Id) = E_Abstract_State or else Not_Visible) then Error_Msg_N ("cannot introduce hidden state &", Id); Error_Msg_NE ("\package & has null abstract state", Id, Context); end if; end Check_No_Hidden_State; --------------------------------------------- -- Check_Nonoverridable_Aspect_Consistency -- --------------------------------------------- procedure Check_Inherited_Nonoverridable_Aspects (Inheritor : Entity_Id; Interface_List : List_Id; Parent_Type : Entity_Id) is -- array needed for iterating over subtype values Nonoverridable_Aspects : constant array (Positive range <>) of Nonoverridable_Aspect_Id := (Aspect_Default_Iterator, Aspect_Iterator_Element, Aspect_Implicit_Dereference, Aspect_Constant_Indexing, Aspect_Variable_Indexing, Aspect_Aggregate, Aspect_Max_Entry_Queue_Length -- , Aspect_No_Controlled_Parts ); -- Note that none of these 8 aspects can be specified (for a type) -- via a pragma. For 7 of them, the corresponding pragma does not -- exist. The Pragma_Id enumeration type does include -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to -- specify the aspect for a protected entry or entry family, not for -- a type, and therefore cannot introduce the sorts of inheritance -- issues that we are concerned with in this procedure. type Entity_Array is array (Nat range <>) of Entity_Id; function Ancestor_Entities return Entity_Array; -- Returns all progenitors (including parent type, if present) procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors (Aspect : Nonoverridable_Aspect_Id; Ancestor_1 : Entity_Id; Aspect_Spec_1 : Node_Id; Ancestor_2 : Entity_Id; Aspect_Spec_2 : Node_Id); -- A given aspect has been specified for each of two ancestors; -- check that the two aspect specifications are compatible (see -- RM 13.1.1(18.5) and AI12-0211). ----------------------- -- Ancestor_Entities -- ----------------------- function Ancestor_Entities return Entity_Array is Ifc_Count : constant Nat := List_Length (Interface_List); Ifc_Ancestors : Entity_Array (1 .. Ifc_Count); Ifc : Node_Id := First (Interface_List); begin for Idx in Ifc_Ancestors'Range loop Ifc_Ancestors (Idx) := Entity (Ifc); pragma Assert (Present (Ifc_Ancestors (Idx))); Ifc := Next (Ifc); end loop; pragma Assert (not Present (Ifc)); if Present (Parent_Type) then return Parent_Type & Ifc_Ancestors; else return Ifc_Ancestors; end if; end Ancestor_Entities; ------------------------------------------------------- -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors -- ------------------------------------------------------- procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors (Aspect : Nonoverridable_Aspect_Id; Ancestor_1 : Entity_Id; Aspect_Spec_1 : Node_Id; Ancestor_2 : Entity_Id; Aspect_Spec_2 : Node_Id) is begin if not Is_Confirming (Aspect, Aspect_Spec_1, Aspect_Spec_2) then Error_Msg_Name_1 := Aspect_Names (Aspect); Error_Msg_Name_2 := Chars (Ancestor_1); Error_Msg_Name_3 := Chars (Ancestor_2); Error_Msg ( "incompatible % aspects inherited from ancestors % and %", Sloc (Inheritor)); end if; end Check_Consistency_For_One_Aspect_Of_Two_Ancestors; Ancestors : constant Entity_Array := Ancestor_Entities; -- start of processing for Check_Inherited_Nonoverridable_Aspects begin -- No Ada_Version check here; AI12-0211 is a binding interpretation. if Ancestors'Length < 2 then return; -- Inconsistency impossible; it takes 2 to disagree. elsif In_Instance_Body then return; -- No legality checking in an instance body. end if; for Aspect of Nonoverridable_Aspects loop declare First_Ancestor_With_Aspect : Entity_Id := Empty; First_Aspect_Spec, Current_Aspect_Spec : Node_Id := Empty; begin for Ancestor of Ancestors loop Current_Aspect_Spec := Find_Aspect (Ancestor, Aspect); if Present (Current_Aspect_Spec) then if Present (First_Ancestor_With_Aspect) then Check_Consistency_For_One_Aspect_Of_Two_Ancestors (Aspect => Aspect, Ancestor_1 => First_Ancestor_With_Aspect, Aspect_Spec_1 => First_Aspect_Spec, Ancestor_2 => Ancestor, Aspect_Spec_2 => Current_Aspect_Spec); else First_Ancestor_With_Aspect := Ancestor; First_Aspect_Spec := Current_Aspect_Spec; end if; end if; end loop; end; end loop; end Check_Inherited_Nonoverridable_Aspects; ---------------------------------------- -- Check_Nonvolatile_Function_Profile -- ---------------------------------------- procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is Formal : Entity_Id; begin -- Inspect all formal parameters Formal := First_Formal (Func_Id); while Present (Formal) loop if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then Error_Msg_NE ("nonvolatile function & cannot have a volatile parameter", Formal, Func_Id); end if; Next_Formal (Formal); end loop; -- Inspect the return type if Is_Effectively_Volatile_For_Reading (Etype (Func_Id)) then Error_Msg_NE ("nonvolatile function & cannot have a volatile return type", Result_Definition (Parent (Func_Id)), Func_Id); end if; end Check_Nonvolatile_Function_Profile; ----------------------------- -- Check_Part_Of_Reference -- ----------------------------- procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is function Is_Enclosing_Package_Body (Body_Decl : Node_Id; Obj_Id : Entity_Id) return Boolean; pragma Inline (Is_Enclosing_Package_Body); -- Determine whether package body Body_Decl or its corresponding spec -- immediately encloses the declaration of object Obj_Id. function Is_Internal_Declaration_Or_Body (Decl : Node_Id) return Boolean; pragma Inline (Is_Internal_Declaration_Or_Body); -- Determine whether declaration or body denoted by Decl is internal function Is_Single_Declaration_Or_Body (Decl : Node_Id; Conc_Typ : Entity_Id) return Boolean; pragma Inline (Is_Single_Declaration_Or_Body); -- Determine whether protected/task declaration or body denoted by Decl -- belongs to single concurrent type Conc_Typ. function Is_Single_Task_Pragma (Prag : Node_Id; Task_Typ : Entity_Id) return Boolean; pragma Inline (Is_Single_Task_Pragma); -- Determine whether pragma Prag belongs to single task type Task_Typ ------------------------------- -- Is_Enclosing_Package_Body -- ------------------------------- function Is_Enclosing_Package_Body (Body_Decl : Node_Id; Obj_Id : Entity_Id) return Boolean is Obj_Context : Node_Id; begin -- Find the context of the object declaration Obj_Context := Parent (Declaration_Node (Obj_Id)); if Nkind (Obj_Context) = N_Package_Specification then Obj_Context := Parent (Obj_Context); end if; -- The object appears immediately within the package body if Obj_Context = Body_Decl then return True; -- The object appears immediately within the corresponding spec elsif Nkind (Obj_Context) = N_Package_Declaration and then Unit_Declaration_Node (Corresponding_Spec (Body_Decl)) = Obj_Context then return True; end if; return False; end Is_Enclosing_Package_Body; ------------------------------------- -- Is_Internal_Declaration_Or_Body -- ------------------------------------- function Is_Internal_Declaration_Or_Body (Decl : Node_Id) return Boolean is begin if Comes_From_Source (Decl) then return False; -- A body generated for an expression function which has not been -- inserted into the tree yet (In_Spec_Expression is True) is not -- considered internal. elsif Nkind (Decl) = N_Subprogram_Body and then Was_Expression_Function (Decl) and then not In_Spec_Expression then return False; end if; return True; end Is_Internal_Declaration_Or_Body; ----------------------------------- -- Is_Single_Declaration_Or_Body -- ----------------------------------- function Is_Single_Declaration_Or_Body (Decl : Node_Id; Conc_Typ : Entity_Id) return Boolean is Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl); begin return Present (Anonymous_Object (Spec_Id)) and then Anonymous_Object (Spec_Id) = Conc_Typ; end Is_Single_Declaration_Or_Body; --------------------------- -- Is_Single_Task_Pragma -- --------------------------- function Is_Single_Task_Pragma (Prag : Node_Id; Task_Typ : Entity_Id) return Boolean is Decl : constant Node_Id := Find_Related_Declaration_Or_Body (Prag); begin -- To qualify, the pragma must be associated with single task type -- Task_Typ. return Is_Single_Task_Object (Task_Typ) and then Nkind (Decl) = N_Object_Declaration and then Defining_Entity (Decl) = Task_Typ; end Is_Single_Task_Pragma; -- Local variables Conc_Obj : constant Entity_Id := Encapsulating_State (Var_Id); Par : Node_Id; Prag_Nam : Name_Id; Prev : Node_Id; -- Start of processing for Check_Part_Of_Reference begin -- Nothing to do when the variable was recorded, but did not become a -- constituent of a single concurrent type. if No (Conc_Obj) then return; end if; -- Traverse the parent chain looking for a suitable context for the -- reference to the concurrent constituent. Prev := Ref; Par := Parent (Prev); while Present (Par) loop if Nkind (Par) = N_Pragma then Prag_Nam := Pragma_Name (Par); -- A concurrent constituent is allowed to appear in pragmas -- Initial_Condition and Initializes as this is part of the -- elaboration checks for the constituent (SPARK RM 9(3)). if Prag_Nam in Name_Initial_Condition | Name_Initializes then return; -- When the reference appears within pragma Depends or Global, -- check whether the pragma applies to a single task type. Note -- that the pragma may not encapsulated by the type definition, -- but this is still a valid context. elsif Prag_Nam in Name_Depends | Name_Global and then Is_Single_Task_Pragma (Par, Conc_Obj) then return; end if; -- The reference appears somewhere in the definition of a single -- concurrent type (SPARK RM 9(3)). elsif Nkind (Par) in N_Single_Protected_Declaration | N_Single_Task_Declaration and then Defining_Entity (Par) = Conc_Obj then return; -- The reference appears within the declaration or body of a single -- concurrent type (SPARK RM 9(3)). elsif Nkind (Par) in N_Protected_Body | N_Protected_Type_Declaration | N_Task_Body | N_Task_Type_Declaration and then Is_Single_Declaration_Or_Body (Par, Conc_Obj) then return; -- The reference appears within the statement list of the object's -- immediately enclosing package (SPARK RM 9(3)). elsif Nkind (Par) = N_Package_Body and then Nkind (Prev) = N_Handled_Sequence_Of_Statements and then Is_Enclosing_Package_Body (Par, Var_Id) then return; -- The reference has been relocated within an internally generated -- package or subprogram. Assume that the reference is legal as the -- real check was already performed in the original context of the -- reference. elsif Nkind (Par) in N_Package_Body | N_Package_Declaration | N_Subprogram_Body | N_Subprogram_Declaration and then Is_Internal_Declaration_Or_Body (Par) then return; -- The reference has been relocated to an inlined body for GNATprove. -- Assume that the reference is legal as the real check was already -- performed in the original context of the reference. elsif GNATprove_Mode and then Nkind (Par) = N_Subprogram_Body and then Chars (Defining_Entity (Par)) = Name_uParent then return; end if; Prev := Par; Par := Parent (Prev); end loop; -- At this point it is known that the reference does not appear within a -- legal context. Error_Msg_NE ("reference to variable & cannot appear in this context", Ref, Var_Id); Error_Msg_Name_1 := Chars (Var_Id); if Is_Single_Protected_Object (Conc_Obj) then Error_Msg_NE ("\% is constituent of single protected type &", Ref, Conc_Obj); else Error_Msg_NE ("\% is constituent of single task type &", Ref, Conc_Obj); end if; end Check_Part_Of_Reference; ------------------------------------------ -- Check_Potentially_Blocking_Operation -- ------------------------------------------ procedure Check_Potentially_Blocking_Operation (N : Node_Id) is S : Entity_Id; begin -- N is one of the potentially blocking operations listed in 9.5.1(8). -- When pragma Detect_Blocking is active, the run time will raise -- Program_Error. Here we only issue a warning, since we generally -- support the use of potentially blocking operations in the absence -- of the pragma. -- Indirect blocking through a subprogram call cannot be diagnosed -- statically without interprocedural analysis, so we do not attempt -- to do it here. S := Scope (Current_Scope); while Present (S) and then S /= Standard_Standard loop if Is_Protected_Type (S) then Error_Msg_N ("potentially blocking operation in protected operation??", N); return; end if; S := Scope (S); end loop; end Check_Potentially_Blocking_Operation; ------------------------------------ -- Check_Previous_Null_Procedure -- ------------------------------------ procedure Check_Previous_Null_Procedure (Decl : Node_Id; Prev : Entity_Id) is begin if Ekind (Prev) = E_Procedure and then Nkind (Parent (Prev)) = N_Procedure_Specification and then Null_Present (Parent (Prev)) then Error_Msg_Sloc := Sloc (Prev); Error_Msg_N ("declaration cannot complete previous null procedure#", Decl); end if; end Check_Previous_Null_Procedure; --------------------------------- -- Check_Result_And_Post_State -- --------------------------------- procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is procedure Check_Result_And_Post_State_In_Pragma (Prag : Node_Id; Result_Seen : in out Boolean); -- Determine whether pragma Prag mentions attribute 'Result and whether -- the pragma contains an expression that evaluates differently in pre- -- and post-state. Prag is a [refined] postcondition or a contract-cases -- pragma. Result_Seen is set when the pragma mentions attribute 'Result function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean; -- Determine whether subprogram Subp_Id contains at least one IN OUT -- formal parameter. ------------------------------------------- -- Check_Result_And_Post_State_In_Pragma -- ------------------------------------------- procedure Check_Result_And_Post_State_In_Pragma (Prag : Node_Id; Result_Seen : in out Boolean) is procedure Check_Conjunct (Expr : Node_Id); -- Check an individual conjunct in a conjunction of Boolean -- expressions, connected by "and" or "and then" operators. procedure Check_Conjuncts (Expr : Node_Id); -- Apply the post-state check to every conjunct in an expression, in -- case this is a conjunction of Boolean expressions. Otherwise apply -- it to the expression as a whole. procedure Check_Expression (Expr : Node_Id); -- Perform the 'Result and post-state checks on a given expression function Is_Function_Result (N : Node_Id) return Traverse_Result; -- Attempt to find attribute 'Result in a subtree denoted by N function Is_Trivial_Boolean (N : Node_Id) return Boolean; -- Determine whether source node N denotes "True" or "False" function Mentions_Post_State (N : Node_Id) return Boolean; -- Determine whether a subtree denoted by N mentions any construct -- that denotes a post-state. procedure Check_Function_Result is new Traverse_Proc (Is_Function_Result); -------------------- -- Check_Conjunct -- -------------------- procedure Check_Conjunct (Expr : Node_Id) is function Adjust_Message (Msg : String) return String; -- Prepend a prefix to the input message Msg denoting that the -- message applies to a conjunct in the expression, when this -- is the case. function Applied_On_Conjunct return Boolean; -- Returns True if the message applies to a conjunct in the -- expression, instead of the whole expression. function Has_Global_Output (Subp : Entity_Id) return Boolean; -- Returns True if Subp has an output in its Global contract function Has_No_Output (Subp : Entity_Id) return Boolean; -- Returns True if Subp has no declared output: no function -- result, no output parameter, and no output in its Global -- contract. -------------------- -- Adjust_Message -- -------------------- function Adjust_Message (Msg : String) return String is begin if Applied_On_Conjunct then return "conjunct in " & Msg; else return Msg; end if; end Adjust_Message; ------------------------- -- Applied_On_Conjunct -- ------------------------- function Applied_On_Conjunct return Boolean is begin -- Expr is the conjunct of an enclosing "and" expression return Nkind (Parent (Expr)) in N_Subexpr -- or Expr is a conjunct of an enclosing "and then" -- expression in a postcondition aspect that was split into -- multiple pragmas. The first conjunct has the "and then" -- expression as Original_Node, and other conjuncts have -- Split_PCC set to True. or else Nkind (Original_Node (Expr)) = N_And_Then or else Split_PPC (Prag); end Applied_On_Conjunct; ----------------------- -- Has_Global_Output -- ----------------------- function Has_Global_Output (Subp : Entity_Id) return Boolean is Global : constant Node_Id := Get_Pragma (Subp, Pragma_Global); List : Node_Id; Assoc : Node_Id; begin if No (Global) then return False; end if; List := Expression (Get_Argument (Global, Subp)); -- Empty list (no global items) or single global item -- declaration (only input items). if Nkind (List) in N_Null | N_Expanded_Name | N_Identifier | N_Selected_Component then return False; -- Simple global list (only input items) or moded global list -- declaration. elsif Nkind (List) = N_Aggregate then if Present (Expressions (List)) then return False; else Assoc := First (Component_Associations (List)); while Present (Assoc) loop if Chars (First (Choices (Assoc))) /= Name_Input then return True; end if; Next (Assoc); end loop; return False; end if; -- To accommodate partial decoration of disabled SPARK -- features, this routine may be called with illegal input. -- If this is the case, do not raise Program_Error. else return False; end if; end Has_Global_Output; ------------------- -- Has_No_Output -- ------------------- function Has_No_Output (Subp : Entity_Id) return Boolean is Param : Node_Id; begin -- A function has its result as output if Ekind (Subp) = E_Function then return False; end if; -- An OUT or IN OUT parameter is an output Param := First_Formal (Subp); while Present (Param) loop if Ekind (Param) in E_Out_Parameter | E_In_Out_Parameter then return False; end if; Next_Formal (Param); end loop; -- An item of mode Output or In_Out in the Global contract is -- an output. if Has_Global_Output (Subp) then return False; end if; return True; end Has_No_Output; -- Local variables Err_Node : Node_Id; -- Error node when reporting a warning on a (refined) -- postcondition. -- Start of processing for Check_Conjunct begin if Applied_On_Conjunct then Err_Node := Expr; else Err_Node := Prag; end if; -- Do not report missing reference to outcome in postcondition if -- either the postcondition is trivially True or False, or if the -- subprogram is ghost and has no declared output. if not Is_Trivial_Boolean (Expr) and then not Mentions_Post_State (Expr) and then not (Is_Ghost_Entity (Subp_Id) and then Has_No_Output (Subp_Id)) then if Pragma_Name (Prag) = Name_Contract_Cases then Error_Msg_NE (Adjust_Message ("contract case does not check the outcome of calling " & "&?T?"), Expr, Subp_Id); elsif Pragma_Name (Prag) = Name_Refined_Post then Error_Msg_NE (Adjust_Message ("refined postcondition does not check the outcome of " & "calling &?T?"), Err_Node, Subp_Id); else Error_Msg_NE (Adjust_Message ("postcondition does not check the outcome of calling " & "&?T?"), Err_Node, Subp_Id); end if; end if; end Check_Conjunct; --------------------- -- Check_Conjuncts -- --------------------- procedure Check_Conjuncts (Expr : Node_Id) is begin if Nkind (Expr) in N_Op_And | N_And_Then then Check_Conjuncts (Left_Opnd (Expr)); Check_Conjuncts (Right_Opnd (Expr)); else Check_Conjunct (Expr); end if; end Check_Conjuncts; ---------------------- -- Check_Expression -- ---------------------- procedure Check_Expression (Expr : Node_Id) is begin if not Is_Trivial_Boolean (Expr) then Check_Function_Result (Expr); Check_Conjuncts (Expr); end if; end Check_Expression; ------------------------ -- Is_Function_Result -- ------------------------ function Is_Function_Result (N : Node_Id) return Traverse_Result is begin if Is_Attribute_Result (N) then Result_Seen := True; return Abandon; -- Warn on infinite recursion if call is to current function elsif Nkind (N) = N_Function_Call and then Is_Entity_Name (Name (N)) and then Entity (Name (N)) = Subp_Id and then not Is_Potentially_Unevaluated (N) then Error_Msg_NE ("call to & within its postcondition will lead to infinite " & "recursion?", N, Subp_Id); return OK; -- Continue the traversal else return OK; end if; end Is_Function_Result; ------------------------ -- Is_Trivial_Boolean -- ------------------------ function Is_Trivial_Boolean (N : Node_Id) return Boolean is begin return Comes_From_Source (N) and then Is_Entity_Name (N) and then (Entity (N) = Standard_True or else Entity (N) = Standard_False); end Is_Trivial_Boolean; ------------------------- -- Mentions_Post_State -- ------------------------- function Mentions_Post_State (N : Node_Id) return Boolean is Post_State_Seen : Boolean := False; function Is_Post_State (N : Node_Id) return Traverse_Result; -- Attempt to find a construct that denotes a post-state. If this -- is the case, set flag Post_State_Seen. ------------------- -- Is_Post_State -- ------------------- function Is_Post_State (N : Node_Id) return Traverse_Result is Ent : Entity_Id; begin if Nkind (N) in N_Explicit_Dereference | N_Function_Call then Post_State_Seen := True; return Abandon; elsif Nkind (N) in N_Expanded_Name | N_Identifier then Ent := Entity (N); -- Treat an undecorated reference as OK if No (Ent) -- A reference to an assignable entity is considered a -- change in the post-state of a subprogram. or else Ekind (Ent) in E_Generic_In_Out_Parameter | E_In_Out_Parameter | E_Out_Parameter | E_Variable -- The reference may be modified through a dereference or else (Is_Access_Type (Etype (Ent)) and then Nkind (Parent (N)) = N_Selected_Component) then Post_State_Seen := True; return Abandon; end if; elsif Nkind (N) = N_Attribute_Reference then if Attribute_Name (N) = Name_Old then return Skip; elsif Attribute_Name (N) = Name_Result then Post_State_Seen := True; return Abandon; end if; end if; return OK; end Is_Post_State; procedure Find_Post_State is new Traverse_Proc (Is_Post_State); -- Start of processing for Mentions_Post_State begin Find_Post_State (N); return Post_State_Seen; end Mentions_Post_State; -- Local variables Expr : constant Node_Id := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); Nam : constant Name_Id := Pragma_Name (Prag); CCase : Node_Id; -- Start of processing for Check_Result_And_Post_State_In_Pragma begin -- Examine all consequences if Nam = Name_Contract_Cases then CCase := First (Component_Associations (Expr)); while Present (CCase) loop Check_Expression (Expression (CCase)); Next (CCase); end loop; -- Examine the expression of a postcondition else pragma Assert (Nam in Name_Postcondition | Name_Refined_Post); Check_Expression (Expr); end if; end Check_Result_And_Post_State_In_Pragma; -------------------------- -- Has_In_Out_Parameter -- -------------------------- function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is Formal : Entity_Id; begin -- Traverse the formals looking for an IN OUT parameter Formal := First_Formal (Subp_Id); while Present (Formal) loop if Ekind (Formal) = E_In_Out_Parameter then return True; end if; Next_Formal (Formal); end loop; return False; end Has_In_Out_Parameter; -- Local variables Items : constant Node_Id := Contract (Subp_Id); Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); Case_Prag : Node_Id := Empty; Post_Prag : Node_Id := Empty; Prag : Node_Id; Seen_In_Case : Boolean := False; Seen_In_Post : Boolean := False; Spec_Id : Entity_Id; -- Start of processing for Check_Result_And_Post_State begin -- The lack of attribute 'Result or a post-state is classified as a -- suspicious contract. Do not perform the check if the corresponding -- swich is not set. if not Warn_On_Suspicious_Contract then return; -- Nothing to do if there is no contract elsif No (Items) then return; end if; -- Retrieve the entity of the subprogram spec (if any) if Nkind (Subp_Decl) = N_Subprogram_Body and then Present (Corresponding_Spec (Subp_Decl)) then Spec_Id := Corresponding_Spec (Subp_Decl); elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub and then Present (Corresponding_Spec_Of_Stub (Subp_Decl)) then Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); else Spec_Id := Subp_Id; end if; -- Examine all postconditions for attribute 'Result and a post-state Prag := Pre_Post_Conditions (Items); while Present (Prag) loop if Pragma_Name_Unmapped (Prag) in Name_Postcondition | Name_Refined_Post and then not Error_Posted (Prag) then Post_Prag := Prag; Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post); end if; Prag := Next_Pragma (Prag); end loop; -- Examine the contract cases of the subprogram for attribute 'Result -- and a post-state. Prag := Contract_Test_Cases (Items); while Present (Prag) loop if Pragma_Name (Prag) = Name_Contract_Cases and then not Error_Posted (Prag) then Case_Prag := Prag; Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case); end if; Prag := Next_Pragma (Prag); end loop; -- Do not emit any errors if the subprogram is not a function if Ekind (Spec_Id) not in E_Function | E_Generic_Function then null; -- Regardless of whether the function has postconditions or contract -- cases, or whether they mention attribute 'Result, an IN OUT formal -- parameter is always treated as a result. elsif Has_In_Out_Parameter (Spec_Id) then null; -- The function has both a postcondition and contract cases and they do -- not mention attribute 'Result. elsif Present (Case_Prag) and then not Seen_In_Case and then Present (Post_Prag) and then not Seen_In_Post then Error_Msg_N ("neither postcondition nor contract cases mention function " & "result?T?", Post_Prag); -- The function has contract cases only and they do not mention -- attribute 'Result. elsif Present (Case_Prag) and then not Seen_In_Case then Error_Msg_N ("contract cases do not mention result?T?", Case_Prag); -- The function has postconditions only and they do not mention -- attribute 'Result. elsif Present (Post_Prag) and then not Seen_In_Post then Error_Msg_N ("postcondition does not mention function result?T?", Post_Prag); end if; end Check_Result_And_Post_State; ----------------------------- -- Check_State_Refinements -- ----------------------------- procedure Check_State_Refinements (Context : Node_Id; Is_Main_Unit : Boolean := False) is procedure Check_Package (Pack : Node_Id); -- Verify that all abstract states of a [generic] package denoted by its -- declarative node Pack have proper refinement. Recursively verify the -- visible and private declarations of the [generic] package for other -- nested packages. procedure Check_Packages_In (Decls : List_Id); -- Seek out [generic] package declarations within declarative list Decls -- and verify the status of their abstract state refinement. function SPARK_Mode_Is_Off (N : Node_Id) return Boolean; -- Determine whether construct N is subject to pragma SPARK_Mode Off ------------------- -- Check_Package -- ------------------- procedure Check_Package (Pack : Node_Id) is Body_Id : constant Entity_Id := Corresponding_Body (Pack); Spec : constant Node_Id := Specification (Pack); States : constant Elist_Id := Abstract_States (Defining_Entity (Pack)); State_Elmt : Elmt_Id; State_Id : Entity_Id; begin -- Do not verify proper state refinement when the package is subject -- to pragma SPARK_Mode Off because this disables the requirement for -- state refinement. if SPARK_Mode_Is_Off (Pack) then null; -- State refinement can only occur in a completing package body. Do -- not verify proper state refinement when the body is subject to -- pragma SPARK_Mode Off because this disables the requirement for -- state refinement. elsif Present (Body_Id) and then SPARK_Mode_Is_Off (Unit_Declaration_Node (Body_Id)) then null; -- Do not verify proper state refinement when the package is an -- instance as this check was already performed in the generic. elsif Present (Generic_Parent (Spec)) then null; -- Otherwise examine the contents of the package else if Present (States) then State_Elmt := First_Elmt (States); while Present (State_Elmt) loop State_Id := Node (State_Elmt); -- Emit an error when a non-null state lacks any form of -- refinement. if not Is_Null_State (State_Id) and then not Has_Null_Refinement (State_Id) and then not Has_Non_Null_Refinement (State_Id) then Error_Msg_N ("state & requires refinement", State_Id); end if; Next_Elmt (State_Elmt); end loop; end if; Check_Packages_In (Visible_Declarations (Spec)); Check_Packages_In (Private_Declarations (Spec)); end if; end Check_Package; ----------------------- -- Check_Packages_In -- ----------------------- procedure Check_Packages_In (Decls : List_Id) is Decl : Node_Id; begin if Present (Decls) then Decl := First (Decls); while Present (Decl) loop if Nkind (Decl) in N_Generic_Package_Declaration | N_Package_Declaration then Check_Package (Decl); end if; Next (Decl); end loop; end if; end Check_Packages_In; ----------------------- -- SPARK_Mode_Is_Off -- ----------------------- function SPARK_Mode_Is_Off (N : Node_Id) return Boolean is Id : constant Entity_Id := Defining_Entity (N); Prag : constant Node_Id := SPARK_Pragma (Id); begin -- Default the mode to "off" when the context is an instance and all -- SPARK_Mode pragmas found within are to be ignored. if Ignore_SPARK_Mode_Pragmas (Id) then return True; else return Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = Off; end if; end SPARK_Mode_Is_Off; -- Start of processing for Check_State_Refinements begin -- A block may declare a nested package if Nkind (Context) = N_Block_Statement then Check_Packages_In (Declarations (Context)); -- An entry, protected, subprogram, or task body may declare a nested -- package. elsif Nkind (Context) in N_Entry_Body | N_Protected_Body | N_Subprogram_Body | N_Task_Body then -- Do not verify proper state refinement when the body is subject to -- pragma SPARK_Mode Off because this disables the requirement for -- state refinement. if not SPARK_Mode_Is_Off (Context) then Check_Packages_In (Declarations (Context)); end if; -- A package body may declare a nested package elsif Nkind (Context) = N_Package_Body then Check_Package (Unit_Declaration_Node (Corresponding_Spec (Context))); -- Do not verify proper state refinement when the body is subject to -- pragma SPARK_Mode Off because this disables the requirement for -- state refinement. if not SPARK_Mode_Is_Off (Context) then Check_Packages_In (Declarations (Context)); end if; -- A library level [generic] package may declare a nested package elsif Nkind (Context) in N_Generic_Package_Declaration | N_Package_Declaration and then Is_Main_Unit then Check_Package (Context); end if; end Check_State_Refinements; ------------------------------ -- Check_Unprotected_Access -- ------------------------------ procedure Check_Unprotected_Access (Context : Node_Id; Expr : Node_Id) is Cont_Encl_Typ : Entity_Id; Pref_Encl_Typ : Entity_Id; function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; -- Check whether Obj is a private component of a protected object. -- Return the protected type where the component resides, Empty -- otherwise. function Is_Public_Operation return Boolean; -- Verify that the enclosing operation is callable from outside the -- protected object, to minimize false positives. ------------------------------ -- Enclosing_Protected_Type -- ------------------------------ function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is begin if Is_Entity_Name (Obj) then declare Ent : Entity_Id := Entity (Obj); begin -- The object can be a renaming of a private component, use -- the original record component. if Is_Prival (Ent) then Ent := Prival_Link (Ent); end if; if Is_Protected_Type (Scope (Ent)) then return Scope (Ent); end if; end; end if; -- For indexed and selected components, recursively check the prefix if Nkind (Obj) in N_Indexed_Component | N_Selected_Component then return Enclosing_Protected_Type (Prefix (Obj)); -- The object does not denote a protected component else return Empty; end if; end Enclosing_Protected_Type; ------------------------- -- Is_Public_Operation -- ------------------------- function Is_Public_Operation return Boolean is S : Entity_Id; E : Entity_Id; begin S := Current_Scope; while Present (S) and then S /= Pref_Encl_Typ loop if Scope (S) = Pref_Encl_Typ then E := First_Entity (Pref_Encl_Typ); while Present (E) and then E /= First_Private_Entity (Pref_Encl_Typ) loop if E = S then return True; end if; Next_Entity (E); end loop; end if; S := Scope (S); end loop; return False; end Is_Public_Operation; -- Start of processing for Check_Unprotected_Access begin if Nkind (Expr) = N_Attribute_Reference and then Attribute_Name (Expr) = Name_Unchecked_Access then Cont_Encl_Typ := Enclosing_Protected_Type (Context); Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); -- Check whether we are trying to export a protected component to a -- context with an equal or lower access level. if Present (Pref_Encl_Typ) and then No (Cont_Encl_Typ) and then Is_Public_Operation and then Scope_Depth (Pref_Encl_Typ) >= Static_Accessibility_Level (Context, Object_Decl_Level) then Error_Msg_N ("??possible unprotected access to protected data", Expr); end if; end if; end Check_Unprotected_Access; ------------------------------ -- Check_Unused_Body_States -- ------------------------------ procedure Check_Unused_Body_States (Body_Id : Entity_Id) is procedure Process_Refinement_Clause (Clause : Node_Id; States : Elist_Id); -- Inspect all constituents of refinement clause Clause and remove any -- matches from body state list States. procedure Report_Unused_Body_States (States : Elist_Id); -- Emit errors for each abstract state or object found in list States ------------------------------- -- Process_Refinement_Clause -- ------------------------------- procedure Process_Refinement_Clause (Clause : Node_Id; States : Elist_Id) is procedure Process_Constituent (Constit : Node_Id); -- Remove constituent Constit from body state list States ------------------------- -- Process_Constituent -- ------------------------- procedure Process_Constituent (Constit : Node_Id) is Constit_Id : Entity_Id; begin -- Guard against illegal constituents. Only abstract states and -- objects can appear on the right hand side of a refinement. if Is_Entity_Name (Constit) then Constit_Id := Entity_Of (Constit); if Present (Constit_Id) and then Ekind (Constit_Id) in E_Abstract_State | E_Constant | E_Variable then Remove (States, Constit_Id); end if; end if; end Process_Constituent; -- Local variables Constit : Node_Id; -- Start of processing for Process_Refinement_Clause begin if Nkind (Clause) = N_Component_Association then Constit := Expression (Clause); -- Multiple constituents appear as an aggregate if Nkind (Constit) = N_Aggregate then Constit := First (Expressions (Constit)); while Present (Constit) loop Process_Constituent (Constit); Next (Constit); end loop; -- Various forms of a single constituent else Process_Constituent (Constit); end if; end if; end Process_Refinement_Clause; ------------------------------- -- Report_Unused_Body_States -- ------------------------------- procedure Report_Unused_Body_States (States : Elist_Id) is Posted : Boolean := False; State_Elmt : Elmt_Id; State_Id : Entity_Id; begin if Present (States) then State_Elmt := First_Elmt (States); while Present (State_Elmt) loop State_Id := Node (State_Elmt); -- Constants are part of the hidden state of a package, but the -- compiler cannot determine whether they have variable input -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a -- hidden state. Do not emit an error when a constant does not -- participate in a state refinement, even though it acts as a -- hidden state. if Ekind (State_Id) = E_Constant then null; -- Generate an error message of the form: -- body of package ... has unused hidden states -- abstract state ... defined at ... -- variable ... defined at ... else if not Posted then Posted := True; SPARK_Msg_N ("body of package & has unused hidden states", Body_Id); end if; Error_Msg_Sloc := Sloc (State_Id); if Ekind (State_Id) = E_Abstract_State then SPARK_Msg_NE ("\abstract state & defined #", Body_Id, State_Id); else SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id); end if; end if; Next_Elmt (State_Elmt); end loop; end if; end Report_Unused_Body_States; -- Local variables Prag : constant Node_Id := Get_Pragma (Body_Id, Pragma_Refined_State); Spec_Id : constant Entity_Id := Spec_Entity (Body_Id); Clause : Node_Id; States : Elist_Id; -- Start of processing for Check_Unused_Body_States begin -- Inspect the clauses of pragma Refined_State and determine whether all -- visible states declared within the package body participate in the -- refinement. if Present (Prag) then Clause := Expression (Get_Argument (Prag, Spec_Id)); States := Collect_Body_States (Body_Id); -- Multiple non-null state refinements appear as an aggregate if Nkind (Clause) = N_Aggregate then Clause := First (Component_Associations (Clause)); while Present (Clause) loop Process_Refinement_Clause (Clause, States); Next (Clause); end loop; -- Various forms of a single state refinement else Process_Refinement_Clause (Clause, States); end if; -- Ensure that all abstract states and objects declared in the -- package body state space are utilized as constituents. Report_Unused_Body_States (States); end if; end Check_Unused_Body_States; ------------------------------------ -- Check_Volatility_Compatibility -- ------------------------------------ procedure Check_Volatility_Compatibility (Id1, Id2 : Entity_Id; Description_1, Description_2 : String; Srcpos_Bearer : Node_Id) is begin if SPARK_Mode /= On then return; end if; declare AR1 : constant Boolean := Async_Readers_Enabled (Id1); AW1 : constant Boolean := Async_Writers_Enabled (Id1); ER1 : constant Boolean := Effective_Reads_Enabled (Id1); EW1 : constant Boolean := Effective_Writes_Enabled (Id1); AR2 : constant Boolean := Async_Readers_Enabled (Id2); AW2 : constant Boolean := Async_Writers_Enabled (Id2); ER2 : constant Boolean := Effective_Reads_Enabled (Id2); EW2 : constant Boolean := Effective_Writes_Enabled (Id2); AR_Check_Failed : constant Boolean := AR1 and not AR2; AW_Check_Failed : constant Boolean := AW1 and not AW2; ER_Check_Failed : constant Boolean := ER1 and not ER2; EW_Check_Failed : constant Boolean := EW1 and not EW2; package Failure_Description is procedure Note_If_Failure (Failed : Boolean; Aspect_Name : String); -- If Failed is False, do nothing. -- If Failed is True, add Aspect_Name to the failure description. function Failure_Text return String; -- returns accumulated list of failing aspects end Failure_Description; package body Failure_Description is Description_Buffer : Bounded_String; --------------------- -- Note_If_Failure -- --------------------- procedure Note_If_Failure (Failed : Boolean; Aspect_Name : String) is begin if Failed then if Description_Buffer.Length /= 0 then Append (Description_Buffer, ", "); end if; Append (Description_Buffer, Aspect_Name); end if; end Note_If_Failure; ------------------ -- Failure_Text -- ------------------ function Failure_Text return String is begin return +Description_Buffer; end Failure_Text; end Failure_Description; use Failure_Description; begin if AR_Check_Failed or AW_Check_Failed or ER_Check_Failed or EW_Check_Failed then Note_If_Failure (AR_Check_Failed, "Async_Readers"); Note_If_Failure (AW_Check_Failed, "Async_Writers"); Note_If_Failure (ER_Check_Failed, "Effective_Reads"); Note_If_Failure (EW_Check_Failed, "Effective_Writes"); Error_Msg_N (Description_1 & " and " & Description_2 & " are not compatible with respect to volatility due to " & Failure_Text, Srcpos_Bearer); end if; end; end Check_Volatility_Compatibility; ----------------- -- Choice_List -- ----------------- function Choice_List (N : Node_Id) return List_Id is begin if Nkind (N) = N_Iterated_Component_Association then return Discrete_Choices (N); else return Choices (N); end if; end Choice_List; ------------------------- -- Collect_Body_States -- ------------------------- function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean; -- Determine whether object Obj_Id is a suitable visible state of a -- package body. procedure Collect_Visible_States (Pack_Id : Entity_Id; States : in out Elist_Id); -- Gather the entities of all abstract states and objects declared in -- the visible state space of package Pack_Id. ---------------------------- -- Collect_Visible_States -- ---------------------------- procedure Collect_Visible_States (Pack_Id : Entity_Id; States : in out Elist_Id) is Item_Id : Entity_Id; begin -- Traverse the entity chain of the package and inspect all visible -- items. Item_Id := First_Entity (Pack_Id); while Present (Item_Id) and then not In_Private_Part (Item_Id) loop -- Do not consider internally generated items as those cannot be -- named and participate in refinement. if not Comes_From_Source (Item_Id) then null; elsif Ekind (Item_Id) = E_Abstract_State then Append_New_Elmt (Item_Id, States); elsif Ekind (Item_Id) in E_Constant | E_Variable and then Is_Visible_Object (Item_Id) then Append_New_Elmt (Item_Id, States); -- Recursively gather the visible states of a nested package elsif Ekind (Item_Id) = E_Package then Collect_Visible_States (Item_Id, States); end if; Next_Entity (Item_Id); end loop; end Collect_Visible_States; ----------------------- -- Is_Visible_Object -- ----------------------- function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean is begin -- Objects that map generic formals to their actuals are not visible -- from outside the generic instantiation. if Present (Corresponding_Generic_Association (Declaration_Node (Obj_Id))) then return False; -- Constituents of a single protected/task type act as components of -- the type and are not visible from outside the type. elsif Ekind (Obj_Id) = E_Variable and then Present (Encapsulating_State (Obj_Id)) and then Is_Single_Concurrent_Object (Encapsulating_State (Obj_Id)) then return False; else return True; end if; end Is_Visible_Object; -- Local variables Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id); Decl : Node_Id; Item_Id : Entity_Id; States : Elist_Id := No_Elist; -- Start of processing for Collect_Body_States begin -- Inspect the declarations of the body looking for source objects, -- packages and package instantiations. Note that even though this -- processing is very similar to Collect_Visible_States, a package -- body does not have a First/Next_Entity list. Decl := First (Declarations (Body_Decl)); while Present (Decl) loop -- Capture source objects as internally generated temporaries cannot -- be named and participate in refinement. if Nkind (Decl) = N_Object_Declaration then Item_Id := Defining_Entity (Decl); if Comes_From_Source (Item_Id) and then Is_Visible_Object (Item_Id) then Append_New_Elmt (Item_Id, States); end if; -- Capture the visible abstract states and objects of a source -- package [instantiation]. elsif Nkind (Decl) = N_Package_Declaration then Item_Id := Defining_Entity (Decl); if Comes_From_Source (Item_Id) then Collect_Visible_States (Item_Id, States); end if; end if; Next (Decl); end loop; return States; end Collect_Body_States; ------------------------ -- Collect_Interfaces -- ------------------------ procedure Collect_Interfaces (T : Entity_Id; Ifaces_List : out Elist_Id; Exclude_Parents : Boolean := False; Use_Full_View : Boolean := True) is procedure Collect (Typ : Entity_Id); -- Subsidiary subprogram used to traverse the whole list -- of directly and indirectly implemented interfaces ------------- -- Collect -- ------------- procedure Collect (Typ : Entity_Id) is Ancestor : Entity_Id; Full_T : Entity_Id; Id : Node_Id; Iface : Entity_Id; begin Full_T := Typ; -- Handle private types and subtypes if Use_Full_View and then Is_Private_Type (Typ) and then Present (Full_View (Typ)) then Full_T := Full_View (Typ); if Ekind (Full_T) = E_Record_Subtype then Full_T := Etype (Typ); if Present (Full_View (Full_T)) then Full_T := Full_View (Full_T); end if; end if; end if; -- Include the ancestor if we are generating the whole list of -- abstract interfaces. if Etype (Full_T) /= Typ -- Protect the frontend against wrong sources. For example: -- package P is -- type A is tagged null record; -- type B is new A with private; -- type C is new A with private; -- private -- type B is new C with null record; -- type C is new B with null record; -- end P; and then Etype (Full_T) /= T then Ancestor := Etype (Full_T); Collect (Ancestor); if Is_Interface (Ancestor) and then not Exclude_Parents then Append_Unique_Elmt (Ancestor, Ifaces_List); end if; end if; -- Traverse the graph of ancestor interfaces if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then Id := First (Abstract_Interface_List (Full_T)); while Present (Id) loop Iface := Etype (Id); -- Protect against wrong uses. For example: -- type I is interface; -- type O is tagged null record; -- type Wrong is new I and O with null record; -- ERROR if Is_Interface (Iface) then if Exclude_Parents and then Etype (T) /= T and then Interface_Present_In_Ancestor (Etype (T), Iface) then null; else Collect (Iface); Append_Unique_Elmt (Iface, Ifaces_List); end if; end if; Next (Id); end loop; end if; end Collect; -- Start of processing for Collect_Interfaces begin pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); Ifaces_List := New_Elmt_List; Collect (T); end Collect_Interfaces; ---------------------------------- -- Collect_Interface_Components -- ---------------------------------- procedure Collect_Interface_Components (Tagged_Type : Entity_Id; Components_List : out Elist_Id) is procedure Collect (Typ : Entity_Id); -- Subsidiary subprogram used to climb to the parents ------------- -- Collect -- ------------- procedure Collect (Typ : Entity_Id) is Tag_Comp : Entity_Id; Parent_Typ : Entity_Id; begin -- Handle private types if Present (Full_View (Etype (Typ))) then Parent_Typ := Full_View (Etype (Typ)); else Parent_Typ := Etype (Typ); end if; if Parent_Typ /= Typ -- Protect the frontend against wrong sources. For example: -- package P is -- type A is tagged null record; -- type B is new A with private; -- type C is new A with private; -- private -- type B is new C with null record; -- type C is new B with null record; -- end P; and then Parent_Typ /= Tagged_Type then Collect (Parent_Typ); end if; -- Collect the components containing tags of secondary dispatch -- tables. Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); while Present (Tag_Comp) loop pragma Assert (Present (Related_Type (Tag_Comp))); Append_Elmt (Tag_Comp, Components_List); Tag_Comp := Next_Tag_Component (Tag_Comp); end loop; end Collect; -- Start of processing for Collect_Interface_Components begin pragma Assert (Ekind (Tagged_Type) = E_Record_Type and then Is_Tagged_Type (Tagged_Type)); Components_List := New_Elmt_List; Collect (Tagged_Type); end Collect_Interface_Components; ----------------------------- -- Collect_Interfaces_Info -- ----------------------------- procedure Collect_Interfaces_Info (T : Entity_Id; Ifaces_List : out Elist_Id; Components_List : out Elist_Id; Tags_List : out Elist_Id) is Comps_List : Elist_Id; Comp_Elmt : Elmt_Id; Comp_Iface : Entity_Id; Iface_Elmt : Elmt_Id; Iface : Entity_Id; function Search_Tag (Iface : Entity_Id) return Entity_Id; -- Search for the secondary tag associated with the interface type -- Iface that is implemented by T. ---------------- -- Search_Tag -- ---------------- function Search_Tag (Iface : Entity_Id) return Entity_Id is ADT : Elmt_Id; begin if not Is_CPP_Class (T) then ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); else ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); end if; while Present (ADT) and then Is_Tag (Node (ADT)) and then Related_Type (Node (ADT)) /= Iface loop -- Skip secondary dispatch table referencing thunks to user -- defined primitives covered by this interface. pragma Assert (Has_Suffix (Node (ADT), 'P')); Next_Elmt (ADT); -- Skip secondary dispatch tables of Ada types if not Is_CPP_Class (T) then -- Skip secondary dispatch table referencing thunks to -- predefined primitives. pragma Assert (Has_Suffix (Node (ADT), 'Y')); Next_Elmt (ADT); -- Skip secondary dispatch table referencing user-defined -- primitives covered by this interface. pragma Assert (Has_Suffix (Node (ADT), 'D')); Next_Elmt (ADT); -- Skip secondary dispatch table referencing predefined -- primitives. pragma Assert (Has_Suffix (Node (ADT), 'Z')); Next_Elmt (ADT); end if; end loop; pragma Assert (Is_Tag (Node (ADT))); return Node (ADT); end Search_Tag; -- Start of processing for Collect_Interfaces_Info begin Collect_Interfaces (T, Ifaces_List); Collect_Interface_Components (T, Comps_List); -- Search for the record component and tag associated with each -- interface type of T. Components_List := New_Elmt_List; Tags_List := New_Elmt_List; Iface_Elmt := First_Elmt (Ifaces_List); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); -- Associate the primary tag component and the primary dispatch table -- with all the interfaces that are parents of T if Is_Ancestor (Iface, T, Use_Full_View => True) then Append_Elmt (First_Tag_Component (T), Components_List); Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); -- Otherwise search for the tag component and secondary dispatch -- table of Iface else Comp_Elmt := First_Elmt (Comps_List); while Present (Comp_Elmt) loop Comp_Iface := Related_Type (Node (Comp_Elmt)); if Comp_Iface = Iface or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True) then Append_Elmt (Node (Comp_Elmt), Components_List); Append_Elmt (Search_Tag (Comp_Iface), Tags_List); exit; end if; Next_Elmt (Comp_Elmt); end loop; pragma Assert (Present (Comp_Elmt)); end if; Next_Elmt (Iface_Elmt); end loop; end Collect_Interfaces_Info; --------------------- -- Collect_Parents -- --------------------- procedure Collect_Parents (T : Entity_Id; List : out Elist_Id; Use_Full_View : Boolean := True) is Current_Typ : Entity_Id := T; Parent_Typ : Entity_Id; begin List := New_Elmt_List; -- No action if the if the type has no parents if T = Etype (T) then return; end if; loop Parent_Typ := Etype (Current_Typ); if Is_Private_Type (Parent_Typ) and then Present (Full_View (Parent_Typ)) and then Use_Full_View then Parent_Typ := Full_View (Base_Type (Parent_Typ)); end if; Append_Elmt (Parent_Typ, List); exit when Parent_Typ = Current_Typ; Current_Typ := Parent_Typ; end loop; end Collect_Parents; ---------------------------------- -- Collect_Primitive_Operations -- ---------------------------------- function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is B_Type : constant Entity_Id := Base_Type (T); function Match (E : Entity_Id) return Boolean; -- True if E's base type is B_Type, or E is of an anonymous access type -- and the base type of its designated type is B_Type. ----------- -- Match -- ----------- function Match (E : Entity_Id) return Boolean is Etyp : Entity_Id := Etype (E); begin if Ekind (Etyp) = E_Anonymous_Access_Type then Etyp := Designated_Type (Etyp); end if; -- In Ada 2012 a primitive operation may have a formal of an -- incomplete view of the parent type. return Base_Type (Etyp) = B_Type or else (Ada_Version >= Ada_2012 and then Ekind (Etyp) = E_Incomplete_Type and then Full_View (Etyp) = B_Type); end Match; -- Local variables B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); B_Scope : Entity_Id := Scope (B_Type); Op_List : Elist_Id; Eq_Prims_List : Elist_Id := No_Elist; Formal : Entity_Id; Is_Prim : Boolean; Is_Type_In_Pkg : Boolean; Formal_Derived : Boolean := False; Id : Entity_Id; -- Start of processing for Collect_Primitive_Operations begin -- For tagged types, the primitive operations are collected as they -- are declared, and held in an explicit list which is simply returned. if Is_Tagged_Type (B_Type) then return Primitive_Operations (B_Type); -- An untagged generic type that is a derived type inherits the -- primitive operations of its parent type. Other formal types only -- have predefined operators, which are not explicitly represented. elsif Is_Generic_Type (B_Type) then if Nkind (B_Decl) = N_Formal_Type_Declaration and then Nkind (Formal_Type_Definition (B_Decl)) = N_Formal_Derived_Type_Definition then Formal_Derived := True; else return New_Elmt_List; end if; end if; Op_List := New_Elmt_List; if B_Scope = Standard_Standard then if B_Type = Standard_String then Append_Elmt (Standard_Op_Concat, Op_List); elsif B_Type = Standard_Wide_String then Append_Elmt (Standard_Op_Concatw, Op_List); else null; end if; -- Locate the primitive subprograms of the type else -- The primitive operations appear after the base type, except if the -- derivation happens within the private part of B_Scope and the type -- is a private type, in which case both the type and some primitive -- operations may appear before the base type, and the list of -- candidates starts after the type. if In_Open_Scopes (B_Scope) and then Scope (T) = B_Scope and then In_Private_Part (B_Scope) then Id := Next_Entity (T); -- In Ada 2012, If the type has an incomplete partial view, there may -- be primitive operations declared before the full view, so we need -- to start scanning from the incomplete view, which is earlier on -- the entity chain. elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration and then Present (Incomplete_View (Parent (B_Type))) then Id := Defining_Entity (Incomplete_View (Parent (B_Type))); -- If T is a derived from a type with an incomplete view declared -- elsewhere, that incomplete view is irrelevant, we want the -- operations in the scope of T. if Scope (Id) /= Scope (B_Type) then Id := Next_Entity (B_Type); end if; else Id := Next_Entity (B_Type); end if; -- Set flag if this is a type in a package spec Is_Type_In_Pkg := Is_Package_Or_Generic_Package (B_Scope) and then Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= N_Package_Body; while Present (Id) loop -- Test whether the result type or any of the parameter types of -- each subprogram following the type match that type when the -- type is declared in a package spec, is a derived type, or the -- subprogram is marked as primitive. (The Is_Primitive test is -- needed to find primitives of nonderived types in declarative -- parts that happen to override the predefined "=" operator.) -- Note that generic formal subprograms are not considered to be -- primitive operations and thus are never inherited. if Is_Overloadable (Id) and then (Is_Type_In_Pkg or else Is_Derived_Type (B_Type) or else Is_Primitive (Id)) and then Nkind (Parent (Parent (Id))) not in N_Formal_Subprogram_Declaration then Is_Prim := False; if Match (Id) then Is_Prim := True; else Formal := First_Formal (Id); while Present (Formal) loop if Match (Formal) then Is_Prim := True; exit; end if; Next_Formal (Formal); end loop; end if; -- For a formal derived type, the only primitives are the ones -- inherited from the parent type. Operations appearing in the -- package declaration are not primitive for it. if Is_Prim and then (not Formal_Derived or else Present (Alias (Id))) then -- In the special case of an equality operator aliased to -- an overriding dispatching equality belonging to the same -- type, we don't include it in the list of primitives. -- This avoids inheriting multiple equality operators when -- deriving from untagged private types whose full type is -- tagged, which can otherwise cause ambiguities. Note that -- this should only happen for this kind of untagged parent -- type, since normally dispatching operations are inherited -- using the type's Primitive_Operations list. if Chars (Id) = Name_Op_Eq and then Is_Dispatching_Operation (Id) and then Present (Alias (Id)) and then Present (Overridden_Operation (Alias (Id))) and then Base_Type (Etype (First_Entity (Id))) = Base_Type (Etype (First_Entity (Alias (Id)))) then null; -- Include the subprogram in the list of primitives else Append_Elmt (Id, Op_List); -- Save collected equality primitives for later filtering -- (if we are processing a private type for which we can -- collect several candidates). if Inherits_From_Tagged_Full_View (T) and then Chars (Id) = Name_Op_Eq and then Etype (First_Formal (Id)) = Etype (Next_Formal (First_Formal (Id))) then if No (Eq_Prims_List) then Eq_Prims_List := New_Elmt_List; end if; Append_Elmt (Id, Eq_Prims_List); end if; end if; end if; end if; Next_Entity (Id); -- For a type declared in System, some of its operations may -- appear in the target-specific extension to System. if No (Id) and then B_Scope = RTU_Entity (System) and then Present_System_Aux then B_Scope := System_Aux_Id; Id := First_Entity (System_Aux_Id); end if; end loop; -- Filter collected equality primitives if Inherits_From_Tagged_Full_View (T) and then Present (Eq_Prims_List) then declare First : constant Elmt_Id := First_Elmt (Eq_Prims_List); Second : Elmt_Id; begin pragma Assert (No (Next_Elmt (First)) or else No (Next_Elmt (Next_Elmt (First)))); -- No action needed if we have collected a single equality -- primitive if Present (Next_Elmt (First)) then Second := Next_Elmt (First); if Is_Dispatching_Operation (Ultimate_Alias (Node (First))) then Remove (Op_List, Node (First)); elsif Is_Dispatching_Operation (Ultimate_Alias (Node (Second))) then Remove (Op_List, Node (Second)); else pragma Assert (False); raise Program_Error; end if; end if; end; end if; end if; return Op_List; end Collect_Primitive_Operations; ----------------------------------- -- Compile_Time_Constraint_Error -- ----------------------------------- function Compile_Time_Constraint_Error (N : Node_Id; Msg : String; Ent : Entity_Id := Empty; Loc : Source_Ptr := No_Location; Warn : Boolean := False; Extra_Msg : String := "") return Node_Id is Msgc : String (1 .. Msg'Length + 3); -- Copy of message, with room for possible ?? or << and ! at end Msgl : Natural; Wmsg : Boolean; Eloc : Source_Ptr; -- Start of processing for Compile_Time_Constraint_Error begin -- If this is a warning, convert it into an error if we are in code -- subject to SPARK_Mode being set On, unless Warn is True to force a -- warning. The rationale is that a compile-time constraint error should -- lead to an error instead of a warning when SPARK_Mode is On, but in -- a few cases we prefer to issue a warning and generate both a suitable -- run-time error in GNAT and a suitable check message in GNATprove. -- Those cases are those that likely correspond to deactivated SPARK -- code, so that this kind of code can be compiled and analyzed instead -- of being rejected. Error_Msg_Warn := Warn or SPARK_Mode /= On; -- A static constraint error in an instance body is not a fatal error. -- we choose to inhibit the message altogether, because there is no -- obvious node (for now) on which to post it. On the other hand the -- offending node must be replaced with a constraint_error in any case. -- No messages are generated if we already posted an error on this node if not Error_Posted (N) then if Loc /= No_Location then Eloc := Loc; else Eloc := Sloc (N); end if; -- Copy message to Msgc, converting any ? in the message into < -- instead, so that we have an error in GNATprove mode. Msgl := Msg'Length; for J in 1 .. Msgl loop if Msg (J) = '?' and then (J = 1 or else Msg (J - 1) /= ''') then Msgc (J) := '<'; else Msgc (J) := Msg (J); end if; end loop; -- Message is a warning, even in Ada 95 case if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then Wmsg := True; -- In Ada 83, all messages are warnings. In the private part and the -- body of an instance, constraint_checks are only warnings. We also -- make this a warning if the Warn parameter is set. elsif Warn or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) or else In_Instance_Not_Visible then Msgl := Msgl + 1; Msgc (Msgl) := '<'; Msgl := Msgl + 1; Msgc (Msgl) := '<'; Wmsg := True; -- Otherwise we have a real error message (Ada 95 static case) and we -- make this an unconditional message. Note that in the warning case -- we do not make the message unconditional, it seems reasonable to -- delete messages like this (about exceptions that will be raised) -- in dead code. else Wmsg := False; Msgl := Msgl + 1; Msgc (Msgl) := '!'; end if; -- One more test, skip the warning if the related expression is -- statically unevaluated, since we don't want to warn about what -- will happen when something is evaluated if it never will be -- evaluated. -- Suppress error reporting when checking that the expression of a -- static expression function is a potentially static expression, -- because we don't want additional errors being reported during the -- preanalysis of the expression (see Analyze_Expression_Function). if not Is_Statically_Unevaluated (N) and then not Checking_Potentially_Static_Expression then if Present (Ent) then Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); else Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); end if; -- Emit any extra message as a continuation if Extra_Msg /= "" then Error_Msg_N ('\' & Extra_Msg, N); end if; if Wmsg then -- Check whether the context is an Init_Proc if Inside_Init_Proc then declare Conc_Typ : constant Entity_Id := Corresponding_Concurrent_Type (Entity (Parameter_Type (First (Parameter_Specifications (Parent (Current_Scope)))))); begin -- Don't complain if the corresponding concurrent type -- doesn't come from source (i.e. a single task/protected -- object). if Present (Conc_Typ) and then not Comes_From_Source (Conc_Typ) then Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc); else if GNATprove_Mode then Error_Msg_NEL ("\& would have been raised for objects of this " & "type", N, Standard_Constraint_Error, Eloc); else Error_Msg_NEL ("\& will be raised for objects of this type??", N, Standard_Constraint_Error, Eloc); end if; end if; end; else Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc); end if; else Error_Msg ("\static expression fails Constraint_Check", Eloc); Set_Error_Posted (N); end if; end if; end if; return N; end Compile_Time_Constraint_Error; ----------------------- -- Conditional_Delay -- ----------------------- procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is begin if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then Set_Has_Delayed_Freeze (New_Ent); end if; end Conditional_Delay; ------------------------- -- Copy_Component_List -- ------------------------- function Copy_Component_List (R_Typ : Entity_Id; Loc : Source_Ptr) return List_Id is Comp : Node_Id; Comps : constant List_Id := New_List; begin Comp := First_Component (Underlying_Type (R_Typ)); while Present (Comp) loop if Comes_From_Source (Comp) then declare Comp_Decl : constant Node_Id := Declaration_Node (Comp); begin Append_To (Comps, Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Chars (Comp)), Component_Definition => New_Copy_Tree (Component_Definition (Comp_Decl), New_Sloc => Loc))); end; end if; Next_Component (Comp); end loop; return Comps; end Copy_Component_List; ------------------------- -- Copy_Parameter_List -- ------------------------- function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Subp_Id); Plist : List_Id; Formal : Entity_Id; begin if No (First_Formal (Subp_Id)) then return No_List; else Plist := New_List; Formal := First_Formal (Subp_Id); while Present (Formal) loop Append_To (Plist, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), In_Present => In_Present (Parent (Formal)), Out_Present => Out_Present (Parent (Formal)), Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc), Expression => New_Copy_Tree (Expression (Parent (Formal))))); Next_Formal (Formal); end loop; end if; return Plist; end Copy_Parameter_List; ---------------------------- -- Copy_SPARK_Mode_Aspect -- ---------------------------- procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is pragma Assert (not Has_Aspects (To)); Asp : Node_Id; begin if Has_Aspects (From) then Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode); if Present (Asp) then Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp))); Set_Has_Aspects (To, True); end if; end if; end Copy_SPARK_Mode_Aspect; -------------------------- -- Copy_Subprogram_Spec -- -------------------------- function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is Def_Id : Node_Id; Formal_Spec : Node_Id; Result : Node_Id; begin -- The structure of the original tree must be replicated without any -- alterations. Use New_Copy_Tree for this purpose. Result := New_Copy_Tree (Spec); -- However, the spec of a null procedure carries the corresponding null -- statement of the body (created by the parser), and this cannot be -- shared with the new subprogram spec. if Nkind (Result) = N_Procedure_Specification then Set_Null_Statement (Result, Empty); end if; -- Create a new entity for the defining unit name Def_Id := Defining_Unit_Name (Result); Set_Defining_Unit_Name (Result, Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); -- Create new entities for the formal parameters if Present (Parameter_Specifications (Result)) then Formal_Spec := First (Parameter_Specifications (Result)); while Present (Formal_Spec) loop Def_Id := Defining_Identifier (Formal_Spec); Set_Defining_Identifier (Formal_Spec, Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); Next (Formal_Spec); end loop; end if; return Result; end Copy_Subprogram_Spec; -------------------------------- -- Corresponding_Generic_Type -- -------------------------------- function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is Inst : Entity_Id; Gen : Entity_Id; Typ : Entity_Id; begin if not Is_Generic_Actual_Type (T) then return Any_Type; -- If the actual is the actual of an enclosing instance, resolution -- was correct in the generic. elsif Nkind (Parent (T)) = N_Subtype_Declaration and then Is_Entity_Name (Subtype_Indication (Parent (T))) and then Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T)))) then return Any_Type; else Inst := Scope (T); if Is_Wrapper_Package (Inst) then Inst := Related_Instance (Inst); end if; Gen := Generic_Parent (Specification (Unit_Declaration_Node (Inst))); -- Generic actual has the same name as the corresponding formal Typ := First_Entity (Gen); while Present (Typ) loop if Chars (Typ) = Chars (T) then return Typ; end if; Next_Entity (Typ); end loop; return Any_Type; end if; end Corresponding_Generic_Type; -------------------- -- Current_Entity -- -------------------- -- The currently visible definition for a given identifier is the -- one most chained at the start of the visibility chain, i.e. the -- one that is referenced by the Node_Id value of the name of the -- given identifier. function Current_Entity (N : Node_Id) return Entity_Id is begin return Get_Name_Entity_Id (Chars (N)); end Current_Entity; ----------------------------- -- Current_Entity_In_Scope -- ----------------------------- function Current_Entity_In_Scope (N : Name_Id) return Entity_Id is E : Entity_Id; CS : constant Entity_Id := Current_Scope; Transient_Case : constant Boolean := Scope_Is_Transient; begin E := Get_Name_Entity_Id (N); while Present (E) and then Scope (E) /= CS and then (not Transient_Case or else Scope (E) /= Scope (CS)) loop E := Homonym (E); end loop; return E; end Current_Entity_In_Scope; ----------------------------- -- Current_Entity_In_Scope -- ----------------------------- function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is begin return Current_Entity_In_Scope (Chars (N)); end Current_Entity_In_Scope; ------------------- -- Current_Scope -- ------------------- function Current_Scope return Entity_Id is begin if Scope_Stack.Last = -1 then return Standard_Standard; else declare C : constant Entity_Id := Scope_Stack.Table (Scope_Stack.Last).Entity; begin if Present (C) then return C; else return Standard_Standard; end if; end; end if; end Current_Scope; ---------------------------- -- Current_Scope_No_Loops -- ---------------------------- function Current_Scope_No_Loops return Entity_Id is S : Entity_Id; begin -- Examine the scope stack starting from the current scope and skip any -- internally generated loops. S := Current_Scope; while Present (S) and then S /= Standard_Standard loop if Ekind (S) = E_Loop and then not Comes_From_Source (S) then S := Scope (S); else exit; end if; end loop; return S; end Current_Scope_No_Loops; ------------------------ -- Current_Subprogram -- ------------------------ function Current_Subprogram return Entity_Id is Scop : constant Entity_Id := Current_Scope; begin if Is_Subprogram_Or_Generic_Subprogram (Scop) then return Scop; else return Enclosing_Subprogram (Scop); end if; end Current_Subprogram; ------------------------------- -- Deepest_Type_Access_Level -- ------------------------------- function Deepest_Type_Access_Level (Typ : Entity_Id) 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 -- 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); end if; end Deepest_Type_Access_Level; --------------------- -- Defining_Entity -- --------------------- function Defining_Entity (N : Node_Id; Empty_On_Errors : Boolean := False) return Entity_Id is begin case Nkind (N) is when N_Abstract_Subprogram_Declaration | N_Expression_Function | N_Formal_Subprogram_Declaration | N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration | N_Package_Declaration | N_Subprogram_Body | N_Subprogram_Body_Stub | N_Subprogram_Declaration | N_Subprogram_Renaming_Declaration => return Defining_Entity (Specification (N)); when N_Component_Declaration | N_Defining_Program_Unit_Name | N_Discriminant_Specification | N_Entry_Body | N_Entry_Declaration | N_Entry_Index_Specification | N_Exception_Declaration | N_Exception_Renaming_Declaration | N_Formal_Object_Declaration | N_Formal_Package_Declaration | N_Formal_Type_Declaration | N_Full_Type_Declaration | N_Implicit_Label_Declaration | N_Incomplete_Type_Declaration | N_Iterator_Specification | N_Loop_Parameter_Specification | N_Number_Declaration | N_Object_Declaration | N_Object_Renaming_Declaration | N_Package_Body_Stub | N_Parameter_Specification | N_Private_Extension_Declaration | N_Private_Type_Declaration | N_Protected_Body | N_Protected_Body_Stub | N_Protected_Type_Declaration | N_Single_Protected_Declaration | N_Single_Task_Declaration | N_Subtype_Declaration | N_Task_Body | N_Task_Body_Stub | N_Task_Type_Declaration => return Defining_Identifier (N); when N_Compilation_Unit => return Defining_Entity (Unit (N)); when N_Subunit => return Defining_Entity (Proper_Body (N)); when N_Function_Instantiation | N_Function_Specification | N_Generic_Function_Renaming_Declaration | N_Generic_Package_Renaming_Declaration | N_Generic_Procedure_Renaming_Declaration | N_Package_Body | N_Package_Instantiation | N_Package_Renaming_Declaration | N_Package_Specification | N_Procedure_Instantiation | N_Procedure_Specification => declare Nam : constant Node_Id := Defining_Unit_Name (N); Err : Entity_Id := Empty; begin if Nkind (Nam) in N_Entity then return Nam; -- For Error, make up a name and attach to declaration so we -- can continue semantic analysis. elsif Nam = Error then Err := Make_Temporary (Sloc (N), 'T'); Set_Defining_Unit_Name (N, Err); return Err; -- If not an entity, get defining identifier else return Defining_Identifier (Nam); end if; end; when N_Block_Statement | N_Loop_Statement => return Entity (Identifier (N)); when others => if Empty_On_Errors then return Empty; end if; raise Program_Error; end case; end Defining_Entity; -------------------------- -- Denotes_Discriminant -- -------------------------- function Denotes_Discriminant (N : Node_Id; Check_Concurrent : Boolean := False) return Boolean is E : Entity_Id; begin if not Is_Entity_Name (N) or else No (Entity (N)) then return False; else E := Entity (N); end if; -- If we are checking for a protected type, the discriminant may have -- been rewritten as the corresponding discriminal of the original type -- or of the corresponding concurrent record, depending on whether we -- are in the spec or body of the protected type. return Ekind (E) = E_Discriminant or else (Check_Concurrent and then Ekind (E) = E_In_Parameter and then Present (Discriminal_Link (E)) and then (Is_Concurrent_Type (Scope (Discriminal_Link (E))) or else Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); end Denotes_Discriminant; ------------------------- -- Denotes_Same_Object -- ------------------------- function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is function Is_Renaming (N : Node_Id) return Boolean; -- Return true if N names a renaming entity function Is_Valid_Renaming (N : Node_Id) return Boolean; -- For renamings, return False if the prefix of any dereference within -- the renamed object_name is a variable, or any expression within the -- renamed object_name contains references to variables or calls on -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) ----------------- -- Is_Renaming -- ----------------- function Is_Renaming (N : Node_Id) return Boolean is begin if not Is_Entity_Name (N) then return False; end if; case Ekind (Entity (N)) is when E_Variable | E_Constant => return Present (Renamed_Object (Entity (N))); when E_Exception | E_Function | E_Generic_Function | E_Generic_Package | E_Generic_Procedure | E_Operator | E_Package | E_Procedure => return Present (Renamed_Entity (Entity (N))); when others => return False; end case; end Is_Renaming; ----------------------- -- Is_Valid_Renaming -- ----------------------- function Is_Valid_Renaming (N : Node_Id) return Boolean is function Check_Renaming (N : Node_Id) return Boolean; -- Recursive function used to traverse all the prefixes of N -------------------- -- Check_Renaming -- -------------------- function Check_Renaming (N : Node_Id) return Boolean is begin if Is_Renaming (N) and then not Check_Renaming (Renamed_Entity (Entity (N))) then return False; end if; if Nkind (N) = N_Indexed_Component then declare Indx : Node_Id; begin Indx := First (Expressions (N)); while Present (Indx) loop if not Is_OK_Static_Expression (Indx) then return False; end if; Next_Index (Indx); end loop; end; end if; if Has_Prefix (N) then declare P : constant Node_Id := Prefix (N); begin if Nkind (N) = N_Explicit_Dereference and then Is_Variable (P) then return False; elsif Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Function then return False; elsif Nkind (P) = N_Function_Call then return False; end if; -- Recursion to continue traversing the prefix of the -- renaming expression return Check_Renaming (P); end; end if; return True; end Check_Renaming; -- Start of processing for Is_Valid_Renaming begin return Check_Renaming (N); end Is_Valid_Renaming; -- Local variables Obj1 : Node_Id := A1; Obj2 : Node_Id := A2; -- Start of processing for Denotes_Same_Object begin -- Both names statically denote the same stand-alone object or parameter -- (RM 6.4.1(6.5/3)) if Is_Entity_Name (Obj1) and then Is_Entity_Name (Obj2) and then Entity (Obj1) = Entity (Obj2) then return True; end if; -- For renamings, the prefix of any dereference within the renamed -- object_name is not a variable, and any expression within the -- renamed object_name contains no references to variables nor -- calls on nonstatic functions (RM 6.4.1(6.10/3)). if Is_Renaming (Obj1) then if Is_Valid_Renaming (Obj1) then Obj1 := Renamed_Entity (Entity (Obj1)); else return False; end if; end if; if Is_Renaming (Obj2) then if Is_Valid_Renaming (Obj2) then Obj2 := Renamed_Entity (Entity (Obj2)); else return False; end if; end if; -- No match if not same node kind (such cases are handled by -- Denotes_Same_Prefix) if Nkind (Obj1) /= Nkind (Obj2) then return False; -- After handling valid renamings, one of the two names statically -- denoted a renaming declaration whose renamed object_name is known -- to denote the same object as the other (RM 6.4.1(6.10/3)) elsif Is_Entity_Name (Obj1) then if Is_Entity_Name (Obj2) then return Entity (Obj1) = Entity (Obj2); else return False; end if; -- Both names are selected_components, their prefixes are known to -- denote the same object, and their selector_names denote the same -- component (RM 6.4.1(6.6/3)). elsif Nkind (Obj1) = N_Selected_Component then return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) and then Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); -- Both names are dereferences and the dereferenced names are known to -- denote the same object (RM 6.4.1(6.7/3)) elsif Nkind (Obj1) = N_Explicit_Dereference then return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); -- Both names are indexed_components, their prefixes are known to denote -- the same object, and each of the pairs of corresponding index values -- are either both static expressions with the same static value or both -- names that are known to denote the same object (RM 6.4.1(6.8/3)) elsif Nkind (Obj1) = N_Indexed_Component then if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then return False; else declare Indx1 : Node_Id; Indx2 : Node_Id; begin Indx1 := First (Expressions (Obj1)); Indx2 := First (Expressions (Obj2)); while Present (Indx1) loop -- Indexes must denote the same static value or same object if Is_OK_Static_Expression (Indx1) then if not Is_OK_Static_Expression (Indx2) then return False; elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then return False; end if; elsif not Denotes_Same_Object (Indx1, Indx2) then return False; end if; Next (Indx1); Next (Indx2); end loop; return True; end; end if; -- Both names are slices, their prefixes are known to denote the same -- object, and the two slices have statically matching index constraints -- (RM 6.4.1(6.9/3)) elsif Nkind (Obj1) = N_Slice and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then declare Lo1, Lo2, Hi1, Hi2 : Node_Id; begin Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); -- Check whether bounds are statically identical. There is no -- attempt to detect partial overlap of slices. return Denotes_Same_Object (Lo1, Lo2) and then Denotes_Same_Object (Hi1, Hi2); end; -- In the recursion, literals appear as indexes elsif Nkind (Obj1) = N_Integer_Literal and then Nkind (Obj2) = N_Integer_Literal then return Intval (Obj1) = Intval (Obj2); else return False; end if; end Denotes_Same_Object; ------------------------- -- Denotes_Same_Prefix -- ------------------------- function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is begin if Is_Entity_Name (A1) then if Nkind (A2) in N_Selected_Component | N_Indexed_Component and then not Is_Access_Type (Etype (A1)) then return Denotes_Same_Object (A1, Prefix (A2)) or else Denotes_Same_Prefix (A1, Prefix (A2)); else return False; end if; elsif Is_Entity_Name (A2) then return Denotes_Same_Prefix (A1 => A2, A2 => A1); elsif Nkind (A1) in N_Selected_Component | N_Indexed_Component | N_Slice and then Nkind (A2) in N_Selected_Component | N_Indexed_Component | N_Slice then declare Root1, Root2 : Node_Id; Depth1, Depth2 : Nat := 0; begin Root1 := Prefix (A1); while not Is_Entity_Name (Root1) loop if Nkind (Root1) not in N_Selected_Component | N_Indexed_Component then return False; else Root1 := Prefix (Root1); end if; Depth1 := Depth1 + 1; end loop; Root2 := Prefix (A2); while not Is_Entity_Name (Root2) loop if Nkind (Root2) not in N_Selected_Component | N_Indexed_Component then return False; else Root2 := Prefix (Root2); end if; Depth2 := Depth2 + 1; end loop; -- If both have the same depth and they do not denote the same -- object, they are disjoint and no warning is needed. if Depth1 = Depth2 then return False; elsif Depth1 > Depth2 then Root1 := Prefix (A1); for J in 1 .. Depth1 - Depth2 - 1 loop Root1 := Prefix (Root1); end loop; return Denotes_Same_Object (Root1, A2); else Root2 := Prefix (A2); for J in 1 .. Depth2 - Depth1 - 1 loop Root2 := Prefix (Root2); end loop; return Denotes_Same_Object (A1, Root2); end if; end; else return False; end if; end Denotes_Same_Prefix; ---------------------- -- Denotes_Variable -- ---------------------- function Denotes_Variable (N : Node_Id) return Boolean is begin return Is_Variable (N) and then Paren_Count (N) = 0; end Denotes_Variable; ----------------------------- -- Depends_On_Discriminant -- ----------------------------- function Depends_On_Discriminant (N : Node_Id) return Boolean is L : Node_Id; H : Node_Id; begin Get_Index_Bounds (N, L, H); return Denotes_Discriminant (L) or else Denotes_Discriminant (H); end Depends_On_Discriminant; ------------------------------------- -- Derivation_Too_Early_To_Inherit -- ------------------------------------- function Derivation_Too_Early_To_Inherit (Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean is Btyp : constant Entity_Id := Implementation_Base_Type (Typ); Parent_Type : Entity_Id; begin if Is_Derived_Type (Btyp) then Parent_Type := Implementation_Base_Type (Etype (Btyp)); pragma Assert (Parent_Type /= Btyp); if Has_Stream_Attribute_Definition (Parent_Type, Streaming_Op) and then In_Same_Extended_Unit (Btyp, Parent_Type) and then Instantiation (Get_Source_File_Index (Sloc (Btyp))) = Instantiation (Get_Source_File_Index (Sloc (Parent_Type))) then declare -- ??? Avoid code duplication here with -- Sem_Cat.Has_Stream_Attribute_Definition by introducing a -- new function to be called from both places? Rep_Item : Node_Id := First_Rep_Item (Parent_Type); Real_Rep : Node_Id; Found : Boolean := False; begin while Present (Rep_Item) loop Real_Rep := Rep_Item; if Nkind (Rep_Item) = N_Aspect_Specification then Real_Rep := Aspect_Rep_Item (Rep_Item); end if; if Nkind (Real_Rep) = N_Attribute_Definition_Clause then case Chars (Real_Rep) is when Name_Read => Found := Streaming_Op = TSS_Stream_Read; when Name_Write => Found := Streaming_Op = TSS_Stream_Write; when Name_Input => Found := Streaming_Op = TSS_Stream_Input; when Name_Output => Found := Streaming_Op = TSS_Stream_Output; when others => null; end case; end if; if Found then return Earlier_In_Extended_Unit (Btyp, Real_Rep); end if; Next_Rep_Item (Rep_Item); end loop; end; end if; end if; return False; end Derivation_Too_Early_To_Inherit; ------------------------- -- Designate_Same_Unit -- ------------------------- function Designate_Same_Unit (Name1 : Node_Id; Name2 : Node_Id) return Boolean is K1 : constant Node_Kind := Nkind (Name1); K2 : constant Node_Kind := Nkind (Name2); function Prefix_Node (N : Node_Id) return Node_Id; -- Returns the parent unit name node of a defining program unit name -- or the prefix if N is a selected component or an expanded name. function Select_Node (N : Node_Id) return Node_Id; -- Returns the defining identifier node of a defining program unit -- name or the selector node if N is a selected component or an -- expanded name. ----------------- -- Prefix_Node -- ----------------- function Prefix_Node (N : Node_Id) return Node_Id is begin if Nkind (N) = N_Defining_Program_Unit_Name then return Name (N); else return Prefix (N); end if; end Prefix_Node; ----------------- -- Select_Node -- ----------------- function Select_Node (N : Node_Id) return Node_Id is begin if Nkind (N) = N_Defining_Program_Unit_Name then return Defining_Identifier (N); else return Selector_Name (N); end if; end Select_Node; -- Start of processing for Designate_Same_Unit begin if K1 in N_Identifier | N_Defining_Identifier and then K2 in N_Identifier | N_Defining_Identifier then return Chars (Name1) = Chars (Name2); elsif K1 in N_Expanded_Name | N_Selected_Component | N_Defining_Program_Unit_Name and then K2 in N_Expanded_Name | N_Selected_Component | N_Defining_Program_Unit_Name then return (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) and then Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); else return False; end if; end Designate_Same_Unit; --------------------------------------------- -- Diagnose_Iterated_Component_Association -- --------------------------------------------- procedure Diagnose_Iterated_Component_Association (N : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); Aggr : Node_Id; begin -- Determine whether the iterated component association appears within -- an aggregate. If this is the case, raise Program_Error because the -- iterated component association cannot be left in the tree as is and -- must always be processed by the related aggregate. Aggr := N; while Present (Aggr) loop if Nkind (Aggr) = N_Aggregate then raise Program_Error; -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Aggr) then exit; end if; Aggr := Parent (Aggr); end loop; -- At this point it is known that the iterated component association is -- not within an aggregate. This is really a quantified expression with -- a missing "all" or "some" quantifier. Error_Msg_N ("missing quantifier", Def_Id); -- Rewrite the iterated component association as True to prevent any -- cascaded errors. Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N))); Analyze (N); end Diagnose_Iterated_Component_Association; ------------------------ -- Discriminated_Size -- ------------------------ function Discriminated_Size (Comp : Entity_Id) return Boolean is function Non_Static_Bound (Bound : Node_Id) return Boolean; -- Check whether the bound of an index is non-static and does denote -- a discriminant, in which case any object of the type (protected or -- otherwise) will have a non-static size. ---------------------- -- Non_Static_Bound -- ---------------------- function Non_Static_Bound (Bound : Node_Id) return Boolean is begin if Is_OK_Static_Expression (Bound) then return False; -- If the bound is given by a discriminant it is non-static -- (A static constraint replaces the reference with the value). -- In an protected object the discriminant has been replaced by -- the corresponding discriminal within the protected operation. elsif Is_Entity_Name (Bound) and then (Ekind (Entity (Bound)) = E_Discriminant or else Present (Discriminal_Link (Entity (Bound)))) then return False; else return True; end if; end Non_Static_Bound; -- Local variables Typ : constant Entity_Id := Etype (Comp); Index : Node_Id; -- Start of processing for Discriminated_Size begin if not Is_Array_Type (Typ) then return False; end if; if Ekind (Typ) = E_Array_Subtype then Index := First_Index (Typ); while Present (Index) loop if Non_Static_Bound (Low_Bound (Index)) or else Non_Static_Bound (High_Bound (Index)) then return False; end if; Next_Index (Index); end loop; return True; end if; 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 -- ----------------------------- function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is begin return Has_Enabled_Property (Id, Name_Effective_Reads); end Effective_Reads_Enabled; ------------------------------ -- Effective_Writes_Enabled -- ------------------------------ function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is begin return Has_Enabled_Property (Id, Name_Effective_Writes); end Effective_Writes_Enabled; ------------------------------ -- Enclosing_Comp_Unit_Node -- ------------------------------ function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is Current_Node : Node_Id; begin Current_Node := N; while Present (Current_Node) and then Nkind (Current_Node) /= N_Compilation_Unit loop Current_Node := Parent (Current_Node); end loop; if Nkind (Current_Node) /= N_Compilation_Unit then return Empty; else return Current_Node; end if; end Enclosing_Comp_Unit_Node; -------------------------- -- Enclosing_CPP_Parent -- -------------------------- function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is Parent_Typ : Entity_Id := Typ; begin while not Is_CPP_Class (Parent_Typ) and then Etype (Parent_Typ) /= Parent_Typ loop Parent_Typ := Etype (Parent_Typ); if Is_Private_Type (Parent_Typ) then Parent_Typ := Full_View (Base_Type (Parent_Typ)); end if; end loop; pragma Assert (Is_CPP_Class (Parent_Typ)); return Parent_Typ; end Enclosing_CPP_Parent; --------------------------- -- Enclosing_Declaration -- --------------------------- function Enclosing_Declaration (N : Node_Id) return Node_Id is Decl : Node_Id := N; begin while Present (Decl) and then not (Nkind (Decl) in N_Declaration or else Nkind (Decl) in N_Later_Decl_Item or else Nkind (Decl) = N_Number_Declaration) loop Decl := Parent (Decl); end loop; return Decl; end Enclosing_Declaration; ---------------------------- -- Enclosing_Generic_Body -- ---------------------------- function Enclosing_Generic_Body (N : Node_Id) return Node_Id is Par : Node_Id; Spec_Id : Entity_Id; begin Par := Parent (N); while Present (Par) loop if Nkind (Par) in N_Package_Body | N_Subprogram_Body then Spec_Id := Corresponding_Spec (Par); if Present (Spec_Id) and then Nkind (Unit_Declaration_Node (Spec_Id)) in N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration then return Par; end if; end if; Par := Parent (Par); end loop; return Empty; end Enclosing_Generic_Body; ---------------------------- -- Enclosing_Generic_Unit -- ---------------------------- function Enclosing_Generic_Unit (N : Node_Id) return Node_Id is Par : Node_Id; Spec_Decl : Node_Id; Spec_Id : Entity_Id; begin Par := Parent (N); while Present (Par) loop if Nkind (Par) in N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration then return Par; elsif Nkind (Par) in N_Package_Body | N_Subprogram_Body then Spec_Id := Corresponding_Spec (Par); if Present (Spec_Id) then Spec_Decl := Unit_Declaration_Node (Spec_Id); if Nkind (Spec_Decl) in N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration then return Spec_Decl; end if; end if; end if; Par := Parent (Par); end loop; return Empty; end Enclosing_Generic_Unit; ------------------------------- -- Enclosing_Lib_Unit_Entity -- ------------------------------- function Enclosing_Lib_Unit_Entity (E : Entity_Id := Current_Scope) return Entity_Id is Unit_Entity : Entity_Id; begin -- Look for enclosing library unit entity by following scope links. -- Equivalent to, but faster than indexing through the scope stack. Unit_Entity := E; while (Present (Scope (Unit_Entity)) and then Scope (Unit_Entity) /= Standard_Standard) and not Is_Child_Unit (Unit_Entity) loop Unit_Entity := Scope (Unit_Entity); end loop; return Unit_Entity; end Enclosing_Lib_Unit_Entity; ----------------------------- -- Enclosing_Lib_Unit_Node -- ----------------------------- function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is Encl_Unit : Node_Id; begin Encl_Unit := Enclosing_Comp_Unit_Node (N); while Present (Encl_Unit) and then Nkind (Unit (Encl_Unit)) = N_Subunit loop Encl_Unit := Library_Unit (Encl_Unit); end loop; pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit); return Encl_Unit; end Enclosing_Lib_Unit_Node; ----------------------- -- Enclosing_Package -- ----------------------- function Enclosing_Package (E : Entity_Id) return Entity_Id is Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); begin if Dynamic_Scope = Standard_Standard then return Standard_Standard; elsif Dynamic_Scope = Empty then return Empty; elsif Ekind (Dynamic_Scope) in E_Generic_Package | E_Package | E_Package_Body then return Dynamic_Scope; else return Enclosing_Package (Dynamic_Scope); end if; end Enclosing_Package; ------------------------------------- -- Enclosing_Package_Or_Subprogram -- ------------------------------------- function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is S : Entity_Id; begin S := Scope (E); while Present (S) loop if Is_Package_Or_Generic_Package (S) or else Is_Subprogram_Or_Generic_Subprogram (S) then return S; else S := Scope (S); end if; end loop; return Empty; end Enclosing_Package_Or_Subprogram; -------------------------- -- Enclosing_Subprogram -- -------------------------- function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is Dyn_Scop : constant Entity_Id := Enclosing_Dynamic_Scope (E); begin if Dyn_Scop = Standard_Standard then return Empty; elsif Dyn_Scop = Empty then return Empty; elsif Ekind (Dyn_Scop) = E_Subprogram_Body then return Corresponding_Spec (Parent (Parent (Dyn_Scop))); elsif Ekind (Dyn_Scop) in E_Block | E_Loop | E_Return_Statement then return Enclosing_Subprogram (Dyn_Scop); elsif Ekind (Dyn_Scop) in E_Entry | E_Entry_Family then -- For a task entry or entry family, return the enclosing subprogram -- of the task itself. if Ekind (Scope (Dyn_Scop)) = E_Task_Type then return Enclosing_Subprogram (Dyn_Scop); -- A protected entry or entry family is rewritten as a protected -- procedure which is the desired enclosing subprogram. This is -- relevant when unnesting a procedure local to an entry body. else return Protected_Body_Subprogram (Dyn_Scop); end if; elsif Ekind (Dyn_Scop) = E_Task_Type then return Get_Task_Body_Procedure (Dyn_Scop); -- The scope may appear as a private type or as a private extension -- whose completion is a task or protected type. elsif Ekind (Dyn_Scop) in E_Limited_Private_Type | E_Record_Type_With_Private and then Present (Full_View (Dyn_Scop)) and then Ekind (Full_View (Dyn_Scop)) in E_Task_Type | E_Protected_Type then return Get_Task_Body_Procedure (Full_View (Dyn_Scop)); -- No body is generated if the protected operation is eliminated elsif not Is_Eliminated (Dyn_Scop) and then Present (Protected_Body_Subprogram (Dyn_Scop)) then return Protected_Body_Subprogram (Dyn_Scop); else return Dyn_Scop; end if; end Enclosing_Subprogram; -------------------------- -- End_Keyword_Location -- -------------------------- function End_Keyword_Location (N : Node_Id) return Source_Ptr is function End_Label_Loc (Nod : Node_Id) return Source_Ptr; -- Return the source location of Nod's end label according to the -- following precedence rules: -- -- 1) If the end label exists, return its location -- 2) If Nod exists, return its location -- 3) Return the location of N ------------------- -- End_Label_Loc -- ------------------- function End_Label_Loc (Nod : Node_Id) return Source_Ptr is Label : Node_Id; begin if Present (Nod) then Label := End_Label (Nod); if Present (Label) then return Sloc (Label); else return Sloc (Nod); end if; else return Sloc (N); end if; end End_Label_Loc; -- Local variables Owner : Node_Id; -- Start of processing for End_Keyword_Location begin if Nkind (N) in N_Block_Statement | N_Entry_Body | N_Package_Body | N_Subprogram_Body | N_Task_Body then Owner := Handled_Statement_Sequence (N); elsif Nkind (N) = N_Package_Declaration then Owner := Specification (N); elsif Nkind (N) = N_Protected_Body then Owner := N; elsif Nkind (N) in N_Protected_Type_Declaration | N_Single_Protected_Declaration then Owner := Protected_Definition (N); elsif Nkind (N) in N_Single_Task_Declaration | N_Task_Type_Declaration then Owner := Task_Definition (N); -- This routine should not be called with other contexts else pragma Assert (False); null; end if; return End_Label_Loc (Owner); end End_Keyword_Location; ------------------------ -- Ensure_Freeze_Node -- ------------------------ procedure Ensure_Freeze_Node (E : Entity_Id) is FN : Node_Id; begin if No (Freeze_Node (E)) then FN := Make_Freeze_Entity (Sloc (E)); Set_Has_Delayed_Freeze (E); Set_Freeze_Node (E, FN); Set_Access_Types_To_Process (FN, No_Elist); Set_TSS_Elist (FN, No_Elist); Set_Entity (FN, E); end if; end Ensure_Freeze_Node; ---------------- -- Enter_Name -- ---------------- procedure Enter_Name (Def_Id : Entity_Id) is C : constant Entity_Id := Current_Entity (Def_Id); E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); S : constant Entity_Id := Current_Scope; begin Generate_Definition (Def_Id); -- Add new name to current scope declarations. Check for duplicate -- declaration, which may or may not be a genuine error. if Present (E) then -- Case of previous entity entered because of a missing declaration -- or else a bad subtype indication. Best is to use the new entity, -- and make the previous one invisible. if Etype (E) = Any_Type then Set_Is_Immediately_Visible (E, False); -- Case of renaming declaration constructed for package instances. -- if there is an explicit declaration with the same identifier, -- the renaming is not immediately visible any longer, but remains -- visible through selected component notation. elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration and then not Comes_From_Source (E) then Set_Is_Immediately_Visible (E, False); -- The new entity may be the package renaming, which has the same -- same name as a generic formal which has been seen already. elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration and then not Comes_From_Source (Def_Id) then Set_Is_Immediately_Visible (E, False); -- For a fat pointer corresponding to a remote access to subprogram, -- we use the same identifier as the RAS type, so that the proper -- name appears in the stub. This type is only retrieved through -- the RAS type and never by visibility, and is not added to the -- visibility list (see below). elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration and then Ekind (Def_Id) = E_Record_Type and then Present (Corresponding_Remote_Type (Def_Id)) then null; -- Case of an implicit operation or derived literal. The new entity -- hides the implicit one, which is removed from all visibility, -- i.e. the entity list of its scope, and homonym chain of its name. elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) or else Is_Internal (E) then declare Decl : constant Node_Id := Parent (E); Prev : Entity_Id; Prev_Vis : Entity_Id; begin -- If E is an implicit declaration, it cannot be the first -- entity in the scope. Prev := First_Entity (Current_Scope); while Present (Prev) and then Next_Entity (Prev) /= E loop Next_Entity (Prev); end loop; if No (Prev) then -- If E is not on the entity chain of the current scope, -- it is an implicit declaration in the generic formal -- part of a generic subprogram. When analyzing the body, -- the generic formals are visible but not on the entity -- chain of the subprogram. The new entity will become -- the visible one in the body. pragma Assert (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); null; else Link_Entities (Prev, Next_Entity (E)); if No (Next_Entity (Prev)) then Set_Last_Entity (Current_Scope, Prev); end if; if E = Current_Entity (E) then Prev_Vis := Empty; else Prev_Vis := Current_Entity (E); while Homonym (Prev_Vis) /= E loop Prev_Vis := Homonym (Prev_Vis); end loop; end if; if Present (Prev_Vis) then -- Skip E in the visibility chain Set_Homonym (Prev_Vis, Homonym (E)); else Set_Name_Entity_Id (Chars (E), Homonym (E)); end if; end if; end; -- This section of code could use a comment ??? elsif Present (Etype (E)) and then Is_Concurrent_Type (Etype (E)) and then E = Def_Id then return; -- If the homograph is a protected component renaming, it should not -- be hiding the current entity. Such renamings are treated as weak -- declarations. elsif Is_Prival (E) then Set_Is_Immediately_Visible (E, False); -- In this case the current entity is a protected component renaming. -- Perform minimal decoration by setting the scope and return since -- the prival should not be hiding other visible entities. elsif Is_Prival (Def_Id) then Set_Scope (Def_Id, Current_Scope); return; -- Analogous to privals, the discriminal generated for an entry index -- parameter acts as a weak declaration. Perform minimal decoration -- to avoid bogus errors. elsif Is_Discriminal (Def_Id) and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter then Set_Scope (Def_Id, Current_Scope); return; -- In the body or private part of an instance, a type extension may -- introduce a component with the same name as that of an actual. The -- legality rule is not enforced, but the semantics of the full type -- with two components of same name are not clear at this point??? elsif In_Instance_Not_Visible then null; -- When compiling a package body, some child units may have become -- visible. They cannot conflict with local entities that hide them. elsif Is_Child_Unit (E) and then In_Open_Scopes (Scope (E)) and then not Is_Immediately_Visible (E) then null; -- Conversely, with front-end inlining we may compile the parent body -- first, and a child unit subsequently. The context is now the -- parent spec, and body entities are not visible. elsif Is_Child_Unit (Def_Id) and then Is_Package_Body_Entity (E) and then not In_Package_Body (Current_Scope) then null; -- Case of genuine duplicate declaration else Error_Msg_Sloc := Sloc (E); -- If the previous declaration is an incomplete type declaration -- this may be an attempt to complete it with a private type. The -- following avoids confusing cascaded errors. if Nkind (Parent (E)) = N_Incomplete_Type_Declaration and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration then Error_Msg_N ("incomplete type cannot be completed with a private " & "declaration", Parent (Def_Id)); Set_Is_Immediately_Visible (E, False); Set_Full_View (E, Def_Id); -- An inherited component of a record conflicts with a new -- discriminant. The discriminant is inserted first in the scope, -- but the error should be posted on it, not on the component. elsif Ekind (E) = E_Discriminant and then Present (Scope (Def_Id)) and then Scope (Def_Id) /= Current_Scope then Error_Msg_Sloc := Sloc (Def_Id); Error_Msg_N ("& conflicts with declaration#", E); return; -- If the name of the unit appears in its own context clause, a -- dummy package with the name has already been created, and the -- error emitted. Try to continue quietly. elsif Error_Posted (E) and then Sloc (E) = No_Location and then Nkind (Parent (E)) = N_Package_Specification and then Current_Scope = Standard_Standard then Set_Scope (Def_Id, Current_Scope); return; else Error_Msg_N ("& conflicts with declaration#", Def_Id); -- Avoid cascaded messages with duplicate components in -- derived types. if Ekind (E) in E_Component | E_Discriminant then return; end if; end if; if Nkind (Parent (Parent (Def_Id))) = N_Generic_Subprogram_Declaration and then Def_Id = Defining_Entity (Specification (Parent (Parent (Def_Id)))) then Error_Msg_N ("\generic units cannot be overloaded", Def_Id); end if; -- If entity is in standard, then we are in trouble, because it -- means that we have a library package with a duplicated name. -- That's hard to recover from, so abort. if S = Standard_Standard then raise Unrecoverable_Error; -- Otherwise we continue with the declaration. Having two -- identical declarations should not cause us too much trouble. else null; end if; end if; end if; -- If we fall through, declaration is OK, at least OK enough to continue -- If Def_Id is a discriminant or a record component we are in the midst -- of inheriting components in a derived record definition. Preserve -- their Ekind and Etype. if Ekind (Def_Id) in E_Discriminant | E_Component then null; -- If a type is already set, leave it alone (happens when a type -- declaration is reanalyzed following a call to the optimizer). elsif Present (Etype (Def_Id)) then null; -- Otherwise, the kind E_Void insures that premature uses of the entity -- will be detected. Any_Type insures that no cascaded errors will occur else Set_Ekind (Def_Id, E_Void); Set_Etype (Def_Id, Any_Type); end if; -- All entities except Itypes are immediately visible if not Is_Itype (Def_Id) then Set_Is_Immediately_Visible (Def_Id); Set_Current_Entity (Def_Id); end if; Set_Homonym (Def_Id, C); Append_Entity (Def_Id, S); Set_Public_Status (Def_Id); -- Warn if new entity hides an old one if Warn_On_Hiding and then Present (C) -- Don't warn for record components since they always have a well -- defined scope which does not confuse other uses. Note that in -- some cases, Ekind has not been set yet. and then Ekind (C) /= E_Component and then Ekind (C) /= E_Discriminant and then Nkind (Parent (C)) /= N_Component_Declaration and then Ekind (Def_Id) /= E_Component and then Ekind (Def_Id) /= E_Discriminant and then Nkind (Parent (Def_Id)) /= N_Component_Declaration -- Don't warn for one character variables. It is too common to use -- such variables as locals and will just cause too many false hits. and then Length_Of_Name (Chars (C)) /= 1 -- Don't warn for non-source entities and then Comes_From_Source (C) and then Comes_From_Source (Def_Id) -- Don't warn unless entity in question is in extended main source and then In_Extended_Main_Source_Unit (Def_Id) -- Finally, the hidden entity must be either immediately visible or -- use visible (i.e. from a used package). and then (Is_Immediately_Visible (C) or else Is_Potentially_Use_Visible (C)) then Error_Msg_Sloc := Sloc (C); Error_Msg_N ("declaration hides &#?h?", Def_Id); end if; end Enter_Name; --------------- -- Entity_Of -- --------------- function Entity_Of (N : Node_Id) return Entity_Id is Id : Entity_Id; Ren : Node_Id; begin -- Assume that the arbitrary node does not have an entity Id := Empty; if Is_Entity_Name (N) then Id := Entity (N); -- Follow a possible chain of renamings to reach the earliest renamed -- source object. while Present (Id) and then Is_Object (Id) and then Present (Renamed_Object (Id)) loop Ren := Renamed_Object (Id); -- The reference renames an abstract state or a whole object -- Obj : ...; -- Ren : ... renames Obj; if Is_Entity_Name (Ren) then -- Do not follow a renaming that goes through a generic formal, -- because these entities are hidden and must not be referenced -- from outside the generic. if Is_Hidden (Entity (Ren)) then exit; else Id := Entity (Ren); end if; -- The reference renames a function result. Check the original -- node in case expansion relocates the function call. -- Ren : ... renames Func_Call; elsif Nkind (Original_Node (Ren)) = N_Function_Call then exit; -- Otherwise the reference renames something which does not yield -- an abstract state or a whole object. Treat the reference as not -- having a proper entity for SPARK legality purposes. else Id := Empty; exit; end if; end loop; end if; return Id; end Entity_Of; -------------------------- -- Examine_Array_Bounds -- -------------------------- procedure Examine_Array_Bounds (Typ : Entity_Id; All_Static : out Boolean; Has_Empty : out Boolean) is function Is_OK_Static_Bound (Bound : Node_Id) return Boolean; -- Determine whether bound Bound is a suitable static bound ------------------------ -- Is_OK_Static_Bound -- ------------------------ function Is_OK_Static_Bound (Bound : Node_Id) return Boolean is begin return not Error_Posted (Bound) and then Is_OK_Static_Expression (Bound); end Is_OK_Static_Bound; -- Local variables Hi_Bound : Node_Id; Index : Node_Id; Lo_Bound : Node_Id; -- Start of processing for Examine_Array_Bounds begin -- An unconstrained array type does not have static bounds, and it is -- not known whether they are empty or not. if not Is_Constrained (Typ) then All_Static := False; Has_Empty := False; -- A string literal has static bounds, and is not empty as long as it -- contains at least one character. elsif Ekind (Typ) = E_String_Literal_Subtype then All_Static := True; Has_Empty := String_Literal_Length (Typ) > 0; end if; -- Assume that all bounds are static and not empty All_Static := True; Has_Empty := False; -- Examine each index Index := First_Index (Typ); while Present (Index) loop if Is_Discrete_Type (Etype (Index)) then Get_Index_Bounds (Index, Lo_Bound, Hi_Bound); if Is_OK_Static_Bound (Lo_Bound) and then Is_OK_Static_Bound (Hi_Bound) then -- The static bounds produce an empty range if Is_Null_Range (Lo_Bound, Hi_Bound) then Has_Empty := True; end if; -- Otherwise at least one of the bounds is not static else All_Static := False; end if; -- Otherwise the index is non-discrete, therefore not static else All_Static := False; end if; Next_Index (Index); end loop; end Examine_Array_Bounds; ------------------- -- Exceptions_OK -- ------------------- function Exceptions_OK return Boolean is begin return not (Restriction_Active (No_Exception_Handlers) or else Restriction_Active (No_Exception_Propagation) or else Restriction_Active (No_Exceptions)); end Exceptions_OK; -------------------------- -- Explain_Limited_Type -- -------------------------- procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is C : Entity_Id; begin -- For array, component type must be limited if Is_Array_Type (T) then Error_Msg_Node_2 := T; Error_Msg_NE ("\component type& of type& is limited", N, Component_Type (T)); Explain_Limited_Type (Component_Type (T), N); elsif Is_Record_Type (T) then -- No need for extra messages if explicit limited record if Is_Limited_Record (Base_Type (T)) then return; end if; -- Otherwise find a limited component. Check only components that -- come from source, or inherited components that appear in the -- source of the ancestor. C := First_Component (T); while Present (C) loop if Is_Limited_Type (Etype (C)) and then (Comes_From_Source (C) or else (Present (Original_Record_Component (C)) and then Comes_From_Source (Original_Record_Component (C)))) then Error_Msg_Node_2 := T; Error_Msg_NE ("\component& of type& has limited type", N, C); Explain_Limited_Type (Etype (C), N); return; end if; Next_Component (C); end loop; -- The type may be declared explicitly limited, even if no component -- of it is limited, in which case we fall out of the loop. return; end if; end Explain_Limited_Type; --------------------------------------- -- Expression_Of_Expression_Function -- --------------------------------------- function Expression_Of_Expression_Function (Subp : Entity_Id) return Node_Id is Expr_Func : Node_Id; begin pragma Assert (Is_Expression_Function_Or_Completion (Subp)); if Nkind (Original_Node (Subprogram_Spec (Subp))) = N_Expression_Function then Expr_Func := Original_Node (Subprogram_Spec (Subp)); elsif Nkind (Original_Node (Subprogram_Body (Subp))) = N_Expression_Function then Expr_Func := Original_Node (Subprogram_Body (Subp)); else pragma Assert (False); null; end if; return Original_Node (Expression (Expr_Func)); end Expression_Of_Expression_Function; ------------------------------- -- Extensions_Visible_Status -- ------------------------------- function Extensions_Visible_Status (Id : Entity_Id) return Extensions_Visible_Mode is Arg : Node_Id; Decl : Node_Id; Expr : Node_Id; Prag : Node_Id; Subp : Entity_Id; begin -- When a formal parameter is subject to Extensions_Visible, the pragma -- is stored in the contract of related subprogram. if Is_Formal (Id) then Subp := Scope (Id); elsif Is_Subprogram_Or_Generic_Subprogram (Id) then Subp := Id; -- No other construct carries this pragma else return Extensions_Visible_None; end if; Prag := Get_Pragma (Subp, Pragma_Extensions_Visible); -- In certain cases analysis may request the Extensions_Visible status -- of an expression function before the pragma has been analyzed yet. -- Inspect the declarative items after the expression function looking -- for the pragma (if any). if No (Prag) and then Is_Expression_Function (Subp) then Decl := Next (Unit_Declaration_Node (Subp)); while Present (Decl) loop if Nkind (Decl) = N_Pragma and then Pragma_Name (Decl) = Name_Extensions_Visible then Prag := Decl; exit; -- A source construct ends the region where Extensions_Visible may -- appear, stop the traversal. An expanded expression function is -- no longer a source construct, but it must still be recognized. elsif Comes_From_Source (Decl) or else (Nkind (Decl) in N_Subprogram_Body | N_Subprogram_Declaration and then Is_Expression_Function (Defining_Entity (Decl))) then exit; end if; Next (Decl); end loop; end if; -- Extract the value from the Boolean expression (if any) if Present (Prag) then Arg := First (Pragma_Argument_Associations (Prag)); if Present (Arg) then Expr := Get_Pragma_Arg (Arg); -- When the associated subprogram is an expression function, the -- argument of the pragma may not have been analyzed. if not Analyzed (Expr) then Preanalyze_And_Resolve (Expr, Standard_Boolean); end if; -- Guard against cascading errors when the argument of pragma -- Extensions_Visible is not a valid static Boolean expression. if Error_Posted (Expr) then return Extensions_Visible_None; elsif Is_True (Expr_Value (Expr)) then return Extensions_Visible_True; else return Extensions_Visible_False; end if; -- Otherwise the aspect or pragma defaults to True else return Extensions_Visible_True; end if; -- Otherwise aspect or pragma Extensions_Visible is not inherited or -- directly specified. In SPARK code, its value defaults to "False". elsif SPARK_Mode = On then return Extensions_Visible_False; -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to -- "True". else return Extensions_Visible_True; end if; end Extensions_Visible_Status; ----------------- -- Find_Actual -- ----------------- procedure Find_Actual (N : Node_Id; Formal : out Entity_Id; Call : out Node_Id) is Context : constant Node_Id := Parent (N); Actual : Node_Id; Call_Nam : Node_Id; begin if Nkind (Context) in N_Indexed_Component | N_Selected_Component and then N = Prefix (Context) then Find_Actual (Context, Formal, Call); return; elsif Nkind (Context) = N_Parameter_Association and then N = Explicit_Actual_Parameter (Context) then Call := Parent (Context); elsif Nkind (Context) in N_Entry_Call_Statement | N_Function_Call | N_Procedure_Call_Statement then Call := Context; else Formal := Empty; Call := Empty; return; end if; -- If we have a call to a subprogram look for the parameter. Note that -- we exclude overloaded calls, since we don't know enough to be sure -- of giving the right answer in this case. if Nkind (Call) in N_Entry_Call_Statement | N_Function_Call | N_Procedure_Call_Statement then Call_Nam := Name (Call); -- A call to a protected or task entry appears as a selected -- component rather than an expanded name. if Nkind (Call_Nam) = N_Selected_Component then Call_Nam := Selector_Name (Call_Nam); end if; if Is_Entity_Name (Call_Nam) and then Present (Entity (Call_Nam)) and then Is_Overloadable (Entity (Call_Nam)) and then not Is_Overloaded (Call_Nam) then -- If node is name in call it is not an actual if N = Call_Nam then Formal := Empty; Call := Empty; return; end if; -- Fall here if we are definitely a parameter Actual := First_Actual (Call); Formal := First_Formal (Entity (Call_Nam)); while Present (Formal) and then Present (Actual) loop if Actual = N then return; -- An actual that is the prefix in a prefixed call may have -- been rewritten in the call, after the deferred reference -- was collected. Check if sloc and kinds and names match. elsif Sloc (Actual) = Sloc (N) and then Nkind (Actual) = N_Identifier and then Nkind (Actual) = Nkind (N) and then Chars (Actual) = Chars (N) then return; else Next_Actual (Actual); Next_Formal (Formal); end if; end loop; end if; end if; -- Fall through here if we did not find matching actual Formal := Empty; Call := Empty; end Find_Actual; --------------------------- -- Find_Body_Discriminal -- --------------------------- function Find_Body_Discriminal (Spec_Discriminant : Entity_Id) return Entity_Id is Tsk : Entity_Id; Disc : Entity_Id; begin -- If expansion is suppressed, then the scope can be the concurrent type -- itself rather than a corresponding concurrent record type. if Is_Concurrent_Type (Scope (Spec_Discriminant)) then Tsk := Scope (Spec_Discriminant); else pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); end if; -- Find discriminant of original concurrent type, and use its current -- discriminal, which is the renaming within the task/protected body. Disc := First_Discriminant (Tsk); while Present (Disc) loop if Chars (Disc) = Chars (Spec_Discriminant) then return Discriminal (Disc); end if; Next_Discriminant (Disc); end loop; -- That loop should always succeed in finding a matching entry and -- returning. Fatal error if not. raise Program_Error; end Find_Body_Discriminal; ------------------------------------- -- Find_Corresponding_Discriminant -- ------------------------------------- function Find_Corresponding_Discriminant (Id : Node_Id; Typ : Entity_Id) return Entity_Id is Par_Disc : Entity_Id; Old_Disc : Entity_Id; New_Disc : Entity_Id; begin Par_Disc := Original_Record_Component (Original_Discriminant (Id)); -- The original type may currently be private, and the discriminant -- only appear on its full view. if Is_Private_Type (Scope (Par_Disc)) and then not Has_Discriminants (Scope (Par_Disc)) and then Present (Full_View (Scope (Par_Disc))) then Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); else Old_Disc := First_Discriminant (Scope (Par_Disc)); end if; if Is_Class_Wide_Type (Typ) then New_Disc := First_Discriminant (Root_Type (Typ)); else New_Disc := First_Discriminant (Typ); end if; while Present (Old_Disc) and then Present (New_Disc) loop if Old_Disc = Par_Disc then return New_Disc; end if; Next_Discriminant (Old_Disc); Next_Discriminant (New_Disc); end loop; -- Should always find it raise Program_Error; end Find_Corresponding_Discriminant; ------------------- -- Find_DIC_Type -- ------------------- function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is Curr_Typ : Entity_Id; -- The current type being examined in the parent hierarchy traversal DIC_Typ : Entity_Id; -- The type which carries the DIC pragma. This variable denotes the -- partial view when private types are involved. Par_Typ : Entity_Id; -- The parent type of the current type. This variable denotes the full -- view when private types are involved. begin -- The input type defines its own DIC pragma, therefore it is the owner if Has_Own_DIC (Typ) then DIC_Typ := Typ; -- Otherwise the DIC pragma is inherited from a parent type else pragma Assert (Has_Inherited_DIC (Typ)); -- Climb the parent chain Curr_Typ := Typ; loop -- Inspect the parent type. Do not consider subtypes as they -- inherit the DIC attributes from their base types. DIC_Typ := Base_Type (Etype (Curr_Typ)); -- Look at the full view of a private type because the type may -- have a hidden parent introduced in the full view. Par_Typ := DIC_Typ; if Is_Private_Type (Par_Typ) and then Present (Full_View (Par_Typ)) then Par_Typ := Full_View (Par_Typ); end if; -- Stop the climb once the nearest parent type which defines a DIC -- pragma of its own is encountered or when the root of the parent -- chain is reached. exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ; Curr_Typ := Par_Typ; end loop; end if; return DIC_Typ; end Find_DIC_Type; ---------------------------------- -- Find_Enclosing_Iterator_Loop -- ---------------------------------- function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is Constr : Node_Id; S : Entity_Id; begin -- Traverse the scope chain looking for an iterator loop. Such loops are -- usually transformed into blocks, hence the use of Original_Node. S := Id; while Present (S) and then S /= Standard_Standard loop if Ekind (S) = E_Loop and then Nkind (Parent (S)) = N_Implicit_Label_Declaration then Constr := Original_Node (Label_Construct (Parent (S))); if Nkind (Constr) = N_Loop_Statement and then Present (Iteration_Scheme (Constr)) and then Nkind (Iterator_Specification (Iteration_Scheme (Constr))) = N_Iterator_Specification then return S; end if; end if; S := Scope (S); end loop; return Empty; end Find_Enclosing_Iterator_Loop; -------------------------- -- Find_Enclosing_Scope -- -------------------------- function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is Par : Node_Id; begin -- Examine the parent chain looking for a construct which defines a -- scope. Par := Parent (N); while Present (Par) loop case Nkind (Par) is -- The construct denotes a declaration, the proper scope is its -- entity. when N_Entry_Declaration | N_Expression_Function | N_Full_Type_Declaration | N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration | N_Package_Declaration | N_Private_Extension_Declaration | N_Protected_Type_Declaration | N_Single_Protected_Declaration | N_Single_Task_Declaration | N_Subprogram_Declaration | N_Task_Type_Declaration => return Defining_Entity (Par); -- The construct denotes a body, the proper scope is the entity of -- the corresponding spec or that of the body if the body does not -- complete a previous declaration. when N_Entry_Body | N_Package_Body | N_Protected_Body | N_Subprogram_Body | N_Task_Body => return Unique_Defining_Entity (Par); -- Special cases -- Blocks carry either a source or an internally-generated scope, -- unless the block is a byproduct of exception handling. when N_Block_Statement => if not Exception_Junk (Par) then return Entity (Identifier (Par)); end if; -- Loops carry an internally-generated scope when N_Loop_Statement => return Entity (Identifier (Par)); -- Extended return statements carry an internally-generated scope when N_Extended_Return_Statement => return Return_Statement_Entity (Par); -- A traversal from a subunit continues via the corresponding stub when N_Subunit => Par := Corresponding_Stub (Par); when others => null; end case; Par := Parent (Par); end loop; return Standard_Standard; end Find_Enclosing_Scope; ------------------------------------ -- Find_Loop_In_Conditional_Block -- ------------------------------------ function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is Stmt : Node_Id; begin Stmt := N; if Nkind (Stmt) = N_If_Statement then Stmt := First (Then_Statements (Stmt)); end if; pragma Assert (Nkind (Stmt) = N_Block_Statement); -- Inspect the statements of the conditional block. In general the loop -- should be the first statement in the statement sequence of the block, -- but the finalization machinery may have introduced extra object -- declarations. Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); while Present (Stmt) loop if Nkind (Stmt) = N_Loop_Statement then return Stmt; end if; Next (Stmt); end loop; -- The expansion of attribute 'Loop_Entry produced a malformed block raise Program_Error; end Find_Loop_In_Conditional_Block; -------------------------- -- Find_Overlaid_Entity -- -------------------------- procedure Find_Overlaid_Entity (N : Node_Id; Ent : out Entity_Id; Off : out Boolean) is Expr : Node_Id; begin -- We are looking for one of the two following forms: -- for X'Address use Y'Address -- or -- Const : constant Address := expr; -- ... -- for X'Address use Const; -- In the second case, the expr is either Y'Address, or recursively a -- constant that eventually references Y'Address. Ent := Empty; Off := False; if Nkind (N) = N_Attribute_Definition_Clause and then Chars (N) = Name_Address then Expr := Expression (N); -- This loop checks the form of the expression for Y'Address, -- using recursion to deal with intermediate constants. loop -- Check for Y'Address if Nkind (Expr) = N_Attribute_Reference and then Attribute_Name (Expr) = Name_Address then Expr := Prefix (Expr); exit; -- Check for Const where Const is a constant entity elsif Is_Entity_Name (Expr) and then Ekind (Entity (Expr)) = E_Constant then Expr := Constant_Value (Entity (Expr)); -- Anything else does not need checking else return; end if; end loop; -- This loop checks the form of the prefix for an entity, using -- recursion to deal with intermediate components. loop -- Check for Y where Y is an entity if Is_Entity_Name (Expr) then Ent := Entity (Expr); return; -- Check for components elsif Nkind (Expr) in N_Selected_Component | N_Indexed_Component then Expr := Prefix (Expr); Off := True; -- Anything else does not need checking else return; end if; end loop; end if; end Find_Overlaid_Entity; ------------------------- -- Find_Parameter_Type -- ------------------------- function Find_Parameter_Type (Param : Node_Id) return Entity_Id is begin if Nkind (Param) /= N_Parameter_Specification then return Empty; -- For an access parameter, obtain the type from the formal entity -- itself, because access to subprogram nodes do not carry a type. -- Shouldn't we always use the formal entity ??? elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then return Etype (Defining_Identifier (Param)); else return Etype (Parameter_Type (Param)); end if; end Find_Parameter_Type; ----------------------------------- -- Find_Placement_In_State_Space -- ----------------------------------- procedure Find_Placement_In_State_Space (Item_Id : Entity_Id; Placement : out State_Space_Kind; Pack_Id : out Entity_Id) is Context : Entity_Id; begin -- Assume that the item does not appear in the state space of a package Placement := Not_In_Package; Pack_Id := Empty; -- Climb the scope stack and examine the enclosing context Context := Scope (Item_Id); while Present (Context) and then Context /= Standard_Standard loop if Is_Package_Or_Generic_Package (Context) then Pack_Id := Context; -- A package body is a cut off point for the traversal as the item -- cannot be visible to the outside from this point on. Note that -- this test must be done first as a body is also classified as a -- private part. if In_Package_Body (Context) then Placement := Body_State_Space; return; -- The private part of a package is a cut off point for the -- traversal as the item cannot be visible to the outside from -- this point on. elsif In_Private_Part (Context) then Placement := Private_State_Space; return; -- When the item appears in the visible state space of a package, -- continue to climb the scope stack as this may not be the final -- state space. else Placement := Visible_State_Space; -- The visible state space of a child unit acts as the proper -- placement of an item. if Is_Child_Unit (Context) then return; end if; end if; -- The item or its enclosing package appear in a construct that has -- no state space. else Placement := Not_In_Package; return; end if; Context := Scope (Context); end loop; end Find_Placement_In_State_Space; ----------------------- -- Find_Primitive_Eq -- ----------------------- function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id is function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id; -- Search for the equality primitive; return Empty if the primitive is -- not found. ------------------ -- Find_Eq_Prim -- ------------------ function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is Prim : Entity_Id; Prim_Elmt : Elmt_Id; begin Prim_Elmt := First_Elmt (Prims_List); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); -- Locate primitive equality with the right signature if Chars (Prim) = Name_Op_Eq and then Etype (First_Formal (Prim)) = Etype (Next_Formal (First_Formal (Prim))) and then Base_Type (Etype (Prim)) = Standard_Boolean then return Prim; end if; Next_Elmt (Prim_Elmt); end loop; return Empty; end Find_Eq_Prim; -- Local Variables Eq_Prim : Entity_Id; Full_Type : Entity_Id; -- Start of processing for Find_Primitive_Eq begin if Is_Private_Type (Typ) then Full_Type := Underlying_Type (Typ); else Full_Type := Typ; end if; if No (Full_Type) then return Empty; end if; Full_Type := Base_Type (Full_Type); -- When the base type itself is private, use the full view if Is_Private_Type (Full_Type) then Full_Type := Underlying_Type (Full_Type); end if; if Is_Class_Wide_Type (Full_Type) then Full_Type := Root_Type (Full_Type); end if; if not Is_Tagged_Type (Full_Type) then Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); -- If this is an untagged private type completed with a derivation of -- an untagged private type whose full view is a tagged type, we use -- the primitive operations of the private parent type (since it does -- not have a full view, and also because its equality primitive may -- have been overridden in its untagged full view). If no equality was -- defined for it then take its dispatching equality primitive. elsif Inherits_From_Tagged_Full_View (Typ) then Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ)); if No (Eq_Prim) then Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); end if; else Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type)); end if; return Eq_Prim; end Find_Primitive_Eq; ------------------------ -- Find_Specific_Type -- ------------------------ function Find_Specific_Type (CW : Entity_Id) return Entity_Id is Typ : Entity_Id := Root_Type (CW); begin if Ekind (Typ) = E_Incomplete_Type then if From_Limited_With (Typ) then Typ := Non_Limited_View (Typ); else Typ := Full_View (Typ); end if; end if; if Is_Private_Type (Typ) and then not Is_Tagged_Type (Typ) and then Present (Full_View (Typ)) then return Full_View (Typ); else return Typ; end if; end Find_Specific_Type; ----------------------------- -- Find_Static_Alternative -- ----------------------------- function Find_Static_Alternative (N : Node_Id) return Node_Id is Expr : constant Node_Id := Expression (N); Val : constant Uint := Expr_Value (Expr); Alt : Node_Id; Choice : Node_Id; begin Alt := First (Alternatives (N)); Search : loop if Nkind (Alt) /= N_Pragma then Choice := First (Discrete_Choices (Alt)); while Present (Choice) loop -- Others choice, always matches if Nkind (Choice) = N_Others_Choice then exit Search; -- Range, check if value is in the range elsif Nkind (Choice) = N_Range then exit Search when Val >= Expr_Value (Low_Bound (Choice)) and then Val <= Expr_Value (High_Bound (Choice)); -- Choice is a subtype name. Note that we know it must -- be a static subtype, since otherwise it would have -- been diagnosed as illegal. elsif Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)) then exit Search when Is_In_Range (Expr, Etype (Choice), Assume_Valid => False); -- Choice is a subtype indication elsif Nkind (Choice) = N_Subtype_Indication then declare C : constant Node_Id := Constraint (Choice); R : constant Node_Id := Range_Expression (C); begin exit Search when Val >= Expr_Value (Low_Bound (R)) and then Val <= Expr_Value (High_Bound (R)); end; -- Choice is a simple expression else exit Search when Val = Expr_Value (Choice); end if; Next (Choice); end loop; end if; Next (Alt); pragma Assert (Present (Alt)); end loop Search; -- The above loop *must* terminate by finding a match, since we know the -- case statement is valid, and the value of the expression is known at -- compile time. When we fall out of the loop, Alt points to the -- alternative that we know will be selected at run time. return Alt; end Find_Static_Alternative; ------------------ -- First_Actual -- ------------------ function First_Actual (Node : Node_Id) return Node_Id is N : Node_Id; begin if No (Parameter_Associations (Node)) then return Empty; end if; N := First (Parameter_Associations (Node)); if Nkind (N) = N_Parameter_Association then return First_Named_Actual (Node); else return N; end if; end First_Actual; ------------------ -- First_Global -- ------------------ function First_Global (Subp : Entity_Id; Global_Mode : Name_Id; Refined : Boolean := False) return Node_Id is function First_From_Global_List (List : Node_Id; Global_Mode : Name_Id := Name_Input) return Entity_Id; -- Get the first item with suitable mode from List ---------------------------- -- First_From_Global_List -- ---------------------------- function First_From_Global_List (List : Node_Id; Global_Mode : Name_Id := Name_Input) return Entity_Id is Assoc : Node_Id; begin -- Empty list (no global items) if Nkind (List) = N_Null then return Empty; -- Single global item declaration (only input items) elsif Nkind (List) in N_Expanded_Name | N_Identifier then if Global_Mode = Name_Input then return List; else return Empty; end if; -- Simple global list (only input items) or moded global list -- declaration. elsif Nkind (List) = N_Aggregate then if Present (Expressions (List)) then if Global_Mode = Name_Input then return First (Expressions (List)); else return Empty; end if; else Assoc := First (Component_Associations (List)); while Present (Assoc) loop -- When we find the desired mode in an association, call -- recursively First_From_Global_List as if the mode was -- Name_Input, in order to reuse the existing machinery -- for the other cases. if Chars (First (Choices (Assoc))) = Global_Mode then return First_From_Global_List (Expression (Assoc)); end if; Next (Assoc); end loop; return Empty; end if; -- To accommodate partial decoration of disabled SPARK features, -- this routine may be called with illegal input. If this is the -- case, do not raise Program_Error. else return Empty; end if; end First_From_Global_List; -- Local variables Global : Node_Id := Empty; Body_Id : Entity_Id; -- Start of processing for First_Global begin pragma Assert (Global_Mode in Name_In_Out | Name_Input | Name_Output | Name_Proof_In); -- Retrieve the suitable pragma Global or Refined_Global. In the second -- case, it can only be located on the body entity. if Refined then if Is_Subprogram_Or_Generic_Subprogram (Subp) then Body_Id := Subprogram_Body_Entity (Subp); elsif Is_Entry (Subp) or else Is_Task_Type (Subp) then Body_Id := Corresponding_Body (Parent (Subp)); -- ??? It should be possible to retrieve the Refined_Global on the -- task body associated to the task object. This is not yet possible. elsif Is_Single_Task_Object (Subp) then Body_Id := Empty; else Body_Id := Empty; end if; if Present (Body_Id) then Global := Get_Pragma (Body_Id, Pragma_Refined_Global); end if; else Global := Get_Pragma (Subp, Pragma_Global); end if; -- No corresponding global if pragma is not present if No (Global) then return Empty; -- Otherwise retrieve the corresponding list of items depending on the -- Global_Mode. else return First_From_Global_List (Expression (Get_Argument (Global, Subp)), Global_Mode); end if; end First_Global; ------------- -- Fix_Msg -- ------------- function Fix_Msg (Id : Entity_Id; Msg : String) return String is Is_Task : constant Boolean := Ekind (Id) in E_Task_Body | E_Task_Type or else Is_Single_Task_Object (Id); Msg_Last : constant Natural := Msg'Last; Msg_Index : Natural; Res : String (Msg'Range) := (others => ' '); Res_Index : Natural; begin -- Copy all characters from the input message Msg to result Res with -- suitable replacements. Msg_Index := Msg'First; Res_Index := Res'First; while Msg_Index <= Msg_Last loop -- Replace "subprogram" with a different word if Msg_Index <= Msg_Last - 10 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram" then if Is_Entry (Id) then Res (Res_Index .. Res_Index + 4) := "entry"; Res_Index := Res_Index + 5; elsif Is_Task then Res (Res_Index .. Res_Index + 8) := "task type"; Res_Index := Res_Index + 9; else Res (Res_Index .. Res_Index + 9) := "subprogram"; Res_Index := Res_Index + 10; end if; Msg_Index := Msg_Index + 10; -- Replace "protected" with a different word elsif Msg_Index <= Msg_Last - 9 and then Msg (Msg_Index .. Msg_Index + 8) = "protected" and then Is_Task then Res (Res_Index .. Res_Index + 3) := "task"; Res_Index := Res_Index + 4; Msg_Index := Msg_Index + 9; -- Otherwise copy the character else Res (Res_Index) := Msg (Msg_Index); Msg_Index := Msg_Index + 1; Res_Index := Res_Index + 1; end if; end loop; return Res (Res'First .. Res_Index - 1); end Fix_Msg; ------------------------- -- From_Nested_Package -- ------------------------- function From_Nested_Package (T : Entity_Id) return Boolean is Pack : constant Entity_Id := Scope (T); begin return Ekind (Pack) = E_Package and then not Is_Frozen (Pack) and then not Scope_Within_Or_Same (Current_Scope, Pack) and then In_Open_Scopes (Scope (Pack)); end From_Nested_Package; ----------------------- -- Gather_Components -- ----------------------- procedure Gather_Components (Typ : Entity_Id; Comp_List : Node_Id; Governed_By : List_Id; Into : Elist_Id; Report_Errors : out Boolean) is Assoc : Node_Id; Variant : Node_Id; Discrete_Choice : Node_Id; Comp_Item : Node_Id; Discrim : Entity_Id; Discrim_Name : Node_Id; type Discriminant_Value_Status is (Static_Expr, Static_Subtype, Bad); subtype Good_Discrim_Value_Status is Discriminant_Value_Status range Static_Expr .. Static_Subtype; -- range excludes Bad Discrim_Value : Node_Id; Discrim_Value_Subtype : Node_Id; Discrim_Value_Status : Discriminant_Value_Status := Bad; begin Report_Errors := False; if No (Comp_List) or else Null_Present (Comp_List) then return; elsif Present (Component_Items (Comp_List)) then Comp_Item := First (Component_Items (Comp_List)); else Comp_Item := Empty; end if; while Present (Comp_Item) loop -- Skip the tag of a tagged record, the interface tags, as well -- as all items that are not user components (anonymous types, -- rep clauses, Parent field, controller field). if Nkind (Comp_Item) = N_Component_Declaration then declare Comp : constant Entity_Id := Defining_Identifier (Comp_Item); begin if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then Append_Elmt (Comp, Into); end if; end; end if; Next (Comp_Item); end loop; if No (Variant_Part (Comp_List)) then return; else Discrim_Name := Name (Variant_Part (Comp_List)); Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); end if; -- Look for the discriminant that governs this variant part. -- The discriminant *must* be in the Governed_By List Assoc := First (Governed_By); Find_Constraint : loop Discrim := First (Choices (Assoc)); exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) or else (Present (Corresponding_Discriminant (Entity (Discrim))) and then Chars (Corresponding_Discriminant (Entity (Discrim))) = Chars (Discrim_Name)) or else Chars (Original_Record_Component (Entity (Discrim))) = Chars (Discrim_Name); if No (Next (Assoc)) then if not Is_Constrained (Typ) and then Is_Derived_Type (Typ) then -- If the type is a tagged type with inherited discriminants, -- use the stored constraint on the parent in order to find -- the values of discriminants that are otherwise hidden by an -- explicit constraint. Renamed discriminants are handled in -- the code above. -- If several parent discriminants are renamed by a single -- discriminant of the derived type, the call to obtain the -- Corresponding_Discriminant field only retrieves the last -- of them. We recover the constraint on the others from the -- Stored_Constraint as well. -- An inherited discriminant may have been constrained in a -- later ancestor (not the immediate parent) so we must examine -- the stored constraint of all of them to locate the inherited -- value. declare C : Elmt_Id; D : Entity_Id; T : Entity_Id := Typ; begin while Is_Derived_Type (T) loop if Present (Stored_Constraint (T)) then D := First_Discriminant (Etype (T)); C := First_Elmt (Stored_Constraint (T)); while Present (D) and then Present (C) loop if Chars (Discrim_Name) = Chars (D) then if Is_Entity_Name (Node (C)) and then Entity (Node (C)) = Entity (Discrim) then -- D is renamed by Discrim, whose value is -- given in Assoc. null; else Assoc := Make_Component_Association (Sloc (Typ), New_List (New_Occurrence_Of (D, Sloc (Typ))), Duplicate_Subexpr_No_Checks (Node (C))); end if; exit Find_Constraint; end if; Next_Discriminant (D); Next_Elmt (C); end loop; end if; -- Discriminant may be inherited from ancestor T := Etype (T); end loop; end; end if; end if; if No (Next (Assoc)) then Error_Msg_NE (" missing value for discriminant&", First (Governed_By), Discrim_Name); Report_Errors := True; return; end if; Next (Assoc); end loop Find_Constraint; Discrim_Value := Expression (Assoc); if Is_OK_Static_Expression (Discrim_Value) then Discrim_Value_Status := Static_Expr; else if Ada_Version >= Ada_2020 then if Original_Node (Discrim_Value) /= Discrim_Value and then Nkind (Discrim_Value) = N_Type_Conversion and then Etype (Original_Node (Discrim_Value)) = Etype (Expression (Discrim_Value)) then Discrim_Value_Subtype := Etype (Original_Node (Discrim_Value)); -- An unhelpful (for this code) type conversion may be -- introduced in some cases; deal with it. else Discrim_Value_Subtype := Etype (Discrim_Value); end if; if Is_OK_Static_Subtype (Discrim_Value_Subtype) and then not Is_Null_Range (Type_Low_Bound (Discrim_Value_Subtype), Type_High_Bound (Discrim_Value_Subtype)) then -- Is_Null_Range test doesn't account for predicates, as in -- subtype Null_By_Predicate is Natural -- with Static_Predicate => Null_By_Predicate < 0; -- so test for that null case separately. if (not Has_Static_Predicate (Discrim_Value_Subtype)) or else Present (First (Static_Discrete_Predicate (Discrim_Value_Subtype))) then Discrim_Value_Status := Static_Subtype; end if; end if; end if; if Discrim_Value_Status = Bad then -- If the variant part is governed by a discriminant of the type -- this is an error. If the variant part and the discriminant are -- inherited from an ancestor this is legal (AI05-220) unless the -- components are being gathered for an aggregate, in which case -- the caller must check Report_Errors. -- -- In Ada 2020 the above rules are relaxed. A nonstatic governing -- discriminant is OK as long as it has a static subtype and -- every value of that subtype (and there must be at least one) -- selects the same variant. if Scope (Original_Record_Component ((Entity (First (Choices (Assoc)))))) = Typ then if Ada_Version >= Ada_2020 then Error_Msg_FE ("value for discriminant & must be static or " & "discriminant's nominal subtype must be static " & "and non-null!", Discrim_Value, Discrim); else Error_Msg_FE ("value for discriminant & must be static!", Discrim_Value, Discrim); end if; Why_Not_Static (Discrim_Value); end if; Report_Errors := True; return; end if; end if; Search_For_Discriminant_Value : declare Low : Node_Id; High : Node_Id; UI_High : Uint; UI_Low : Uint; UI_Discrim_Value : Uint; begin case Good_Discrim_Value_Status'(Discrim_Value_Status) is when Static_Expr => UI_Discrim_Value := Expr_Value (Discrim_Value); when Static_Subtype => -- Arbitrarily pick one value of the subtype and look -- for the variant associated with that value; we will -- check later that the same variant is associated with -- all of the other values of the subtype. if Has_Static_Predicate (Discrim_Value_Subtype) then declare Range_Or_Expr : constant Node_Id := First (Static_Discrete_Predicate (Discrim_Value_Subtype)); begin if Nkind (Range_Or_Expr) = N_Range then UI_Discrim_Value := Expr_Value (Low_Bound (Range_Or_Expr)); else UI_Discrim_Value := Expr_Value (Range_Or_Expr); end if; end; else UI_Discrim_Value := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype)); end if; end case; Find_Discrete_Value : while Present (Variant) loop -- If a choice is a subtype with a static predicate, it must -- be rewritten as an explicit list of non-predicated choices. Expand_Static_Predicates_In_Choices (Variant); Discrete_Choice := First (Discrete_Choices (Variant)); while Present (Discrete_Choice) loop exit Find_Discrete_Value when Nkind (Discrete_Choice) = N_Others_Choice; Get_Index_Bounds (Discrete_Choice, Low, High); UI_Low := Expr_Value (Low); UI_High := Expr_Value (High); exit Find_Discrete_Value when UI_Low <= UI_Discrim_Value and then UI_High >= UI_Discrim_Value; Next (Discrete_Choice); end loop; Next_Non_Pragma (Variant); end loop Find_Discrete_Value; end Search_For_Discriminant_Value; -- The case statement must include a variant that corresponds to the -- value of the discriminant, unless the discriminant type has a -- static predicate. In that case the absence of an others_choice that -- would cover this value becomes a run-time error (3.8.1 (21.1/2)). if No (Variant) and then not Has_Static_Predicate (Etype (Discrim_Name)) then Error_Msg_NE ("value of discriminant & is out of range", Discrim_Value, Discrim); Report_Errors := True; return; end if; -- If we have found the corresponding choice, recursively add its -- components to the Into list. The nested components are part of -- the same record type. if Present (Variant) then if Discrim_Value_Status = Static_Subtype then declare Discrim_Value_Subtype_Intervals : constant Interval_Lists.Discrete_Interval_List := Interval_Lists.Type_Intervals (Discrim_Value_Subtype); Variant_Intervals : constant Interval_Lists.Discrete_Interval_List := Interval_Lists.Choice_List_Intervals (Discrete_Choices => Discrete_Choices (Variant)); begin if not Interval_Lists.Is_Subset (Subset => Discrim_Value_Subtype_Intervals, Of_Set => Variant_Intervals) then Error_Msg_NE ("no single variant is associated with all values of " & "the subtype of discriminant value &", Discrim_Value, Discrim); Report_Errors := True; return; end if; end; end if; Gather_Components (Typ, Component_List (Variant), Governed_By, Into, Report_Errors); 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 -- ------------------------ function Get_Actual_Subtype (N : Node_Id) return Entity_Id is Typ : constant Entity_Id := Etype (N); Utyp : Entity_Id := Underlying_Type (Typ); Decl : Node_Id; Atyp : Entity_Id; begin if No (Utyp) then Utyp := Typ; end if; -- If what we have is an identifier that references a subprogram -- formal, or a variable or constant object, then we get the actual -- subtype from the referenced entity if one has been built. if Nkind (N) = N_Identifier and then (Is_Formal (Entity (N)) or else Ekind (Entity (N)) = E_Constant or else Ekind (Entity (N)) = E_Variable) and then Present (Actual_Subtype (Entity (N))) then return Actual_Subtype (Entity (N)); -- Actual subtype of unchecked union is always itself. We never need -- the "real" actual subtype. If we did, we couldn't get it anyway -- because the discriminant is not available. The restrictions on -- Unchecked_Union are designed to make sure that this is OK. elsif Is_Unchecked_Union (Base_Type (Utyp)) then return Typ; -- Here for the unconstrained case, we must find actual subtype -- No actual subtype is available, so we must build it on the fly. -- Checking the type, not the underlying type, for constrainedness -- seems to be necessary. Maybe all the tests should be on the type??? elsif (not Is_Constrained (Typ)) and then (Is_Array_Type (Utyp) or else (Is_Record_Type (Utyp) and then Has_Discriminants (Utyp))) and then not Has_Unknown_Discriminants (Utyp) and then not (Ekind (Utyp) = E_String_Literal_Subtype) then -- Nothing to do if in spec expression (why not???) if In_Spec_Expression then return Typ; elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then -- If the type has no discriminants, there is no subtype to -- build, even if the underlying type is discriminated. return Typ; -- Else build the actual subtype else Decl := Build_Actual_Subtype (Typ, N); -- The call may yield a declaration, or just return the entity if Decl = Typ then return Typ; end if; Atyp := Defining_Identifier (Decl); -- If Build_Actual_Subtype generated a new declaration then use it if Atyp /= Typ then -- The actual subtype is an Itype, so analyze the declaration, -- but do not attach it to the tree, to get the type defined. Set_Parent (Decl, N); Set_Is_Itype (Atyp); Analyze (Decl, Suppress => All_Checks); Set_Associated_Node_For_Itype (Atyp, N); Set_Has_Delayed_Freeze (Atyp, False); -- We need to freeze the actual subtype immediately. This is -- needed, because otherwise this Itype will not get frozen -- at all, and it is always safe to freeze on creation because -- any associated types must be frozen at this point. Freeze_Itype (Atyp, N); return Atyp; -- Otherwise we did not build a declaration, so return original else return Typ; end if; end if; -- For all remaining cases, the actual subtype is the same as -- the nominal type. else return Typ; end if; end Get_Actual_Subtype; ------------------------------------- -- Get_Actual_Subtype_If_Available -- ------------------------------------- function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is Typ : constant Entity_Id := Etype (N); begin -- If what we have is an identifier that references a subprogram -- formal, or a variable or constant object, then we get the actual -- subtype from the referenced entity if one has been built. if Nkind (N) = N_Identifier and then (Is_Formal (Entity (N)) or else Ekind (Entity (N)) = E_Constant or else Ekind (Entity (N)) = E_Variable) and then Present (Actual_Subtype (Entity (N))) then return Actual_Subtype (Entity (N)); -- Otherwise the Etype of N is returned unchanged else return Typ; end if; end Get_Actual_Subtype_If_Available; ------------------------ -- Get_Body_From_Stub -- ------------------------ function Get_Body_From_Stub (N : Node_Id) return Node_Id is begin return Proper_Body (Unit (Library_Unit (N))); end Get_Body_From_Stub; --------------------- -- Get_Cursor_Type -- --------------------- function Get_Cursor_Type (Aspect : Node_Id; Typ : Entity_Id) return Entity_Id is Assoc : Node_Id; Func : Entity_Id; First_Op : Entity_Id; Cursor : Entity_Id; begin -- If error already detected, return if Error_Posted (Aspect) then return Any_Type; end if; -- The cursor type for an Iterable aspect is the return type of a -- non-overloaded First primitive operation. Locate association for -- First. Assoc := First (Component_Associations (Expression (Aspect))); First_Op := Any_Id; while Present (Assoc) loop if Chars (First (Choices (Assoc))) = Name_First then First_Op := Expression (Assoc); exit; end if; Next (Assoc); end loop; if First_Op = Any_Id then Error_Msg_N ("aspect Iterable must specify First operation", Aspect); return Any_Type; elsif not Analyzed (First_Op) then Analyze (First_Op); end if; Cursor := Any_Type; -- Locate function with desired name and profile in scope of type -- In the rare case where the type is an integer type, a base type -- is created for it, check that the base type of the first formal -- of First matches the base type of the domain. Func := First_Entity (Scope (Typ)); while Present (Func) loop if Chars (Func) = Chars (First_Op) and then Ekind (Func) = E_Function and then Present (First_Formal (Func)) and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ) and then No (Next_Formal (First_Formal (Func))) then if Cursor /= Any_Type then Error_Msg_N ("Operation First for iterable type must be unique", Aspect); return Any_Type; else Cursor := Etype (Func); end if; end if; Next_Entity (Func); end loop; -- If not found, no way to resolve remaining primitives if Cursor = Any_Type then Error_Msg_N ("primitive operation for Iterable type must appear in the same " & "list of declarations as the type", Aspect); end if; return Cursor; end Get_Cursor_Type; function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is begin return Etype (Get_Iterable_Type_Primitive (Typ, Name_First)); end Get_Cursor_Type; ------------------------------- -- Get_Default_External_Name -- ------------------------------- function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is begin Get_Decoded_Name_String (Chars (E)); if Opt.External_Name_Imp_Casing = Uppercase then Set_Casing (All_Upper_Case); else Set_Casing (All_Lower_Case); end if; return Make_String_Literal (Sloc (E), Strval => String_From_Name_Buffer); end Get_Default_External_Name; -------------------------- -- Get_Enclosing_Object -- -------------------------- function Get_Enclosing_Object (N : Node_Id) return Entity_Id is begin if Is_Entity_Name (N) then return Entity (N); else case Nkind (N) is when N_Indexed_Component | N_Selected_Component | N_Slice => -- If not generating code, a dereference may be left implicit. -- In thoses cases, return Empty. if Is_Access_Type (Etype (Prefix (N))) then return Empty; else return Get_Enclosing_Object (Prefix (N)); end if; when N_Type_Conversion => return Get_Enclosing_Object (Expression (N)); when others => return Empty; end case; end if; end Get_Enclosing_Object; --------------------------- -- Get_Enum_Lit_From_Pos -- --------------------------- function Get_Enum_Lit_From_Pos (T : Entity_Id; Pos : Uint; Loc : Source_Ptr) return Node_Id is Btyp : Entity_Id := Base_Type (T); Lit : Node_Id; LLoc : Source_Ptr; begin -- In the case where the literal is of type Character, Wide_Character -- or Wide_Wide_Character or of a type derived from them, there needs -- to be some special handling since there is no explicit chain of -- literals to search. Instead, an N_Character_Literal node is created -- with the appropriate Char_Code and Chars fields. if Is_Standard_Character_Type (T) then Set_Character_Literal_Name (UI_To_CC (Pos)); return Make_Character_Literal (Loc, Chars => Name_Find, Char_Literal_Value => Pos); -- For all other cases, we have a complete table of literals, and -- we simply iterate through the chain of literal until the one -- with the desired position value is found. else if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then Btyp := Full_View (Btyp); end if; Lit := First_Literal (Btyp); -- Position in the enumeration type starts at 0 if UI_To_Int (Pos) < 0 then raise Constraint_Error; end if; for J in 1 .. UI_To_Int (Pos) loop Next_Literal (Lit); -- If Lit is Empty, Pos is not in range, so raise Constraint_Error -- inside the loop to avoid calling Next_Literal on Empty. if No (Lit) then raise Constraint_Error; end if; end loop; -- Create a new node from Lit, with source location provided by Loc -- if not equal to No_Location, or by copying the source location of -- Lit otherwise. LLoc := Loc; if LLoc = No_Location then LLoc := Sloc (Lit); end if; return New_Occurrence_Of (Lit, LLoc); end if; end Get_Enum_Lit_From_Pos; ---------------------- -- Get_Fullest_View -- ---------------------- function Get_Fullest_View (E : Entity_Id; Include_PAT : Boolean := True) return Entity_Id is begin -- Strictly speaking, the recursion below isn't necessary, but -- it's both simplest and safest. case Ekind (E) is when Incomplete_Kind => if From_Limited_With (E) then return Get_Fullest_View (Non_Limited_View (E), Include_PAT); elsif Present (Full_View (E)) then return Get_Fullest_View (Full_View (E), Include_PAT); elsif Ekind (E) = E_Incomplete_Subtype then return Get_Fullest_View (Etype (E)); end if; when Private_Kind => if Present (Underlying_Full_View (E)) then return Get_Fullest_View (Underlying_Full_View (E), Include_PAT); elsif Present (Full_View (E)) then return Get_Fullest_View (Full_View (E), Include_PAT); elsif Etype (E) /= E then return Get_Fullest_View (Etype (E), Include_PAT); end if; when Array_Kind => if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then return Get_Fullest_View (Packed_Array_Impl_Type (E)); end if; when E_Record_Subtype => if Present (Cloned_Subtype (E)) then return Get_Fullest_View (Cloned_Subtype (E), Include_PAT); end if; when E_Class_Wide_Type => return Get_Fullest_View (Root_Type (E), Include_PAT); when E_Class_Wide_Subtype => if Present (Equivalent_Type (E)) then return Get_Fullest_View (Equivalent_Type (E), Include_PAT); elsif Present (Cloned_Subtype (E)) then return Get_Fullest_View (Cloned_Subtype (E), Include_PAT); end if; when E_Protected_Type | E_Protected_Subtype | E_Task_Type | E_Task_Subtype => if Present (Corresponding_Record_Type (E)) then return Get_Fullest_View (Corresponding_Record_Type (E), Include_PAT); end if; when E_Access_Protected_Subprogram_Type | E_Anonymous_Access_Protected_Subprogram_Type => if Present (Equivalent_Type (E)) then return Get_Fullest_View (Equivalent_Type (E), Include_PAT); end if; when E_Access_Subtype => return Get_Fullest_View (Base_Type (E), Include_PAT); when others => null; end case; return E; end Get_Fullest_View; ------------------------ -- Get_Generic_Entity -- ------------------------ function Get_Generic_Entity (N : Node_Id) return Entity_Id is Ent : constant Entity_Id := Entity (Name (N)); begin if Present (Renamed_Object (Ent)) then return Renamed_Object (Ent); else return Ent; end if; end Get_Generic_Entity; ------------------------------------- -- Get_Incomplete_View_Of_Ancestor -- ------------------------------------- function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); Par_Scope : Entity_Id; Par_Type : Entity_Id; begin -- The incomplete view of an ancestor is only relevant for private -- derived types in child units. if not Is_Derived_Type (E) or else not Is_Child_Unit (Cur_Unit) then return Empty; else Par_Scope := Scope (Cur_Unit); if No (Par_Scope) then return Empty; end if; Par_Type := Etype (Base_Type (E)); -- Traverse list of ancestor types until we find one declared in -- a parent or grandparent unit (two levels seem sufficient). while Present (Par_Type) loop if Scope (Par_Type) = Par_Scope or else Scope (Par_Type) = Scope (Par_Scope) then return Par_Type; elsif not Is_Derived_Type (Par_Type) then return Empty; else Par_Type := Etype (Base_Type (Par_Type)); end if; end loop; -- If none found, there is no relevant ancestor type. return Empty; end if; end Get_Incomplete_View_Of_Ancestor; ---------------------- -- Get_Index_Bounds -- ---------------------- procedure Get_Index_Bounds (N : Node_Id; L : out Node_Id; H : out Node_Id; Use_Full_View : Boolean := False) is function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id; -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and -- Typ qualifies, the scalar range is obtained from the full view of the -- type. -------------------------- -- Scalar_Range_Of_Type -- -------------------------- function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is T : Entity_Id := Typ; begin if Use_Full_View and then Present (Full_View (T)) then T := Full_View (T); end if; return Scalar_Range (T); end Scalar_Range_Of_Type; -- Local variables Kind : constant Node_Kind := Nkind (N); Rng : Node_Id; -- Start of processing for Get_Index_Bounds begin if Kind = N_Range then L := Low_Bound (N); H := High_Bound (N); elsif Kind = N_Subtype_Indication then Rng := Range_Expression (Constraint (N)); if Rng = Error then L := Error; H := Error; return; else L := Low_Bound (Range_Expression (Constraint (N))); H := High_Bound (Range_Expression (Constraint (N))); end if; elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then Rng := Scalar_Range_Of_Type (Entity (N)); if Error_Posted (Rng) then L := Error; H := Error; elsif Nkind (Rng) = N_Subtype_Indication then Get_Index_Bounds (Rng, L, H); else L := Low_Bound (Rng); H := High_Bound (Rng); end if; else -- N is an expression, indicating a range with one value L := N; H := N; end if; end Get_Index_Bounds; ----------------------------- -- Get_Interfacing_Aspects -- ----------------------------- procedure Get_Interfacing_Aspects (Iface_Asp : Node_Id; Conv_Asp : out Node_Id; EN_Asp : out Node_Id; Expo_Asp : out Node_Id; Imp_Asp : out Node_Id; LN_Asp : out Node_Id; Do_Checks : Boolean := False) is procedure Save_Or_Duplication_Error (Asp : Node_Id; To : in out Node_Id); -- Save the value of aspect Asp in node To. If To already has a value, -- then this is considered a duplicate use of aspect. Emit an error if -- flag Do_Checks is set. ------------------------------- -- Save_Or_Duplication_Error -- ------------------------------- procedure Save_Or_Duplication_Error (Asp : Node_Id; To : in out Node_Id) is begin -- Detect an extra aspect and issue an error if Present (To) then if Do_Checks then Error_Msg_Name_1 := Chars (Identifier (Asp)); Error_Msg_Sloc := Sloc (To); Error_Msg_N ("aspect % previously given #", Asp); end if; -- Otherwise capture the aspect else To := Asp; end if; end Save_Or_Duplication_Error; -- Local variables Asp : Node_Id; Asp_Id : Aspect_Id; -- The following variables capture each individual aspect Conv : Node_Id := Empty; EN : Node_Id := Empty; Expo : Node_Id := Empty; Imp : Node_Id := Empty; LN : Node_Id := Empty; -- Start of processing for Get_Interfacing_Aspects begin -- The input interfacing aspect should reside in an aspect specification -- list. pragma Assert (Is_List_Member (Iface_Asp)); -- Examine the aspect specifications of the related entity. Find and -- capture all interfacing aspects. Detect duplicates and emit errors -- if applicable. Asp := First (List_Containing (Iface_Asp)); while Present (Asp) loop Asp_Id := Get_Aspect_Id (Asp); if Asp_Id = Aspect_Convention then Save_Or_Duplication_Error (Asp, Conv); elsif Asp_Id = Aspect_External_Name then Save_Or_Duplication_Error (Asp, EN); elsif Asp_Id = Aspect_Export then Save_Or_Duplication_Error (Asp, Expo); elsif Asp_Id = Aspect_Import then Save_Or_Duplication_Error (Asp, Imp); elsif Asp_Id = Aspect_Link_Name then Save_Or_Duplication_Error (Asp, LN); end if; Next (Asp); end loop; Conv_Asp := Conv; EN_Asp := EN; Expo_Asp := Expo; Imp_Asp := Imp; LN_Asp := LN; end Get_Interfacing_Aspects; --------------------------------- -- Get_Iterable_Type_Primitive -- --------------------------------- function Get_Iterable_Type_Primitive (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is pragma Assert (Is_Type (Typ) and then Nam in Name_Element | Name_First | Name_Has_Element | Name_Last | Name_Next | Name_Previous); Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); Assoc : Node_Id; begin if No (Funcs) then return Empty; else Assoc := First (Component_Associations (Funcs)); while Present (Assoc) loop if Chars (First (Choices (Assoc))) = Nam then return Entity (Expression (Assoc)); end if; Next (Assoc); end loop; return Empty; end if; end Get_Iterable_Type_Primitive; ---------------------------------- -- Get_Library_Unit_Name_String -- ---------------------------------- procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); begin Get_Unit_Name_String (Unit_Name_Id); -- Remove seven last character (" (spec)" or " (body)") Name_Len := Name_Len - 7; pragma Assert (Name_Buffer (Name_Len + 1) = ' '); end Get_Library_Unit_Name_String; -------------------------- -- Get_Max_Queue_Length -- -------------------------- function Get_Max_Queue_Length (Id : Entity_Id) return Uint is pragma Assert (Is_Entry (Id)); Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length); Max : Uint; begin -- A value of 0 or -1 represents no maximum specified, and entries and -- entry families with no Max_Queue_Length aspect or pragma default to -- it. if not Present (Prag) then return Uint_0; end if; Max := Expr_Value (Expression (First (Pragma_Argument_Associations (Prag)))); -- Since -1 and 0 are equivalent, return 0 for instances of -1 for -- uniformity. if Max = -1 then return Uint_0; end if; return Max; end Get_Max_Queue_Length; ------------------------ -- Get_Name_Entity_Id -- ------------------------ function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is begin return Entity_Id (Get_Name_Table_Int (Id)); end Get_Name_Entity_Id; ------------------------------ -- Get_Name_From_CTC_Pragma -- ------------------------------ function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is Arg : constant Node_Id := Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); begin return Strval (Expr_Value_S (Arg)); end Get_Name_From_CTC_Pragma; ----------------------- -- Get_Parent_Entity -- ----------------------- function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is begin if Nkind (Unit) = N_Package_Body and then Nkind (Original_Node (Unit)) = N_Package_Instantiation then return Defining_Entity (Specification (Instance_Spec (Original_Node (Unit)))); elsif Nkind (Unit) = N_Package_Instantiation then return Defining_Entity (Specification (Instance_Spec (Unit))); else return Defining_Entity (Unit); end if; end Get_Parent_Entity; ------------------- -- Get_Pragma_Id -- ------------------- function Get_Pragma_Id (N : Node_Id) return Pragma_Id is begin return Get_Pragma_Id (Pragma_Name_Unmapped (N)); end Get_Pragma_Id; ------------------------ -- Get_Qualified_Name -- ------------------------ function Get_Qualified_Name (Id : Entity_Id; Suffix : Entity_Id := Empty) return Name_Id is Suffix_Nam : Name_Id := No_Name; begin if Present (Suffix) then Suffix_Nam := Chars (Suffix); end if; return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id)); end Get_Qualified_Name; function Get_Qualified_Name (Nam : Name_Id; Suffix : Name_Id := No_Name; Scop : Entity_Id := Current_Scope) return Name_Id is procedure Add_Scope (S : Entity_Id); -- Add the fully qualified form of scope S to the name buffer. The -- format is: -- s-1__s__ --------------- -- Add_Scope -- --------------- procedure Add_Scope (S : Entity_Id) is begin if S = Empty then null; elsif S = Standard_Standard then null; else Add_Scope (Scope (S)); Get_Name_String_And_Append (Chars (S)); Add_Str_To_Name_Buffer ("__"); end if; end Add_Scope; -- Start of processing for Get_Qualified_Name begin Name_Len := 0; Add_Scope (Scop); -- Append the base name after all scopes have been chained Get_Name_String_And_Append (Nam); -- Append the suffix (if present) if Suffix /= No_Name then Add_Str_To_Name_Buffer ("__"); Get_Name_String_And_Append (Suffix); end if; return Name_Find; end Get_Qualified_Name; ----------------------- -- Get_Reason_String -- ----------------------- procedure Get_Reason_String (N : Node_Id) is begin if Nkind (N) = N_String_Literal then Store_String_Chars (Strval (N)); elsif Nkind (N) = N_Op_Concat then Get_Reason_String (Left_Opnd (N)); Get_Reason_String (Right_Opnd (N)); -- If not of required form, error else Error_Msg_N ("Reason for pragma Warnings has wrong form", N); Error_Msg_N ("\must be string literal or concatenation of string literals", N); return; end if; end Get_Reason_String; -------------------------------- -- Get_Reference_Discriminant -- -------------------------------- function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is D : Entity_Id; begin D := First_Discriminant (Typ); while Present (D) loop if Has_Implicit_Dereference (D) then return D; end if; Next_Discriminant (D); end loop; return Empty; end Get_Reference_Discriminant; --------------------------- -- Get_Referenced_Object -- --------------------------- function Get_Referenced_Object (N : Node_Id) return Node_Id is R : Node_Id; begin R := N; while Is_Entity_Name (R) and then Is_Object (Entity (R)) and then Present (Renamed_Object (Entity (R))) loop R := Renamed_Object (Entity (R)); end loop; return R; end Get_Referenced_Object; ------------------------ -- Get_Renamed_Entity -- ------------------------ function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is R : Entity_Id; begin R := E; while Present (Renamed_Entity (R)) loop R := Renamed_Entity (R); end loop; return R; end Get_Renamed_Entity; ----------------------- -- Get_Return_Object -- ----------------------- function Get_Return_Object (N : Node_Id) return Entity_Id is Decl : Node_Id; begin Decl := First (Return_Object_Declarations (N)); while Present (Decl) loop exit when Nkind (Decl) = N_Object_Declaration and then Is_Return_Object (Defining_Identifier (Decl)); Next (Decl); end loop; pragma Assert (Present (Decl)); return Defining_Identifier (Decl); end Get_Return_Object; --------------------------- -- Get_Subprogram_Entity -- --------------------------- function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is Subp : Node_Id; Subp_Id : Entity_Id; begin if Nkind (Nod) = N_Accept_Statement then Subp := Entry_Direct_Name (Nod); elsif Nkind (Nod) = N_Slice then Subp := Prefix (Nod); else Subp := Name (Nod); end if; -- Strip the subprogram call loop if Nkind (Subp) in N_Explicit_Dereference | N_Indexed_Component | N_Selected_Component then Subp := Prefix (Subp); elsif Nkind (Subp) in N_Type_Conversion | N_Unchecked_Type_Conversion then Subp := Expression (Subp); else exit; end if; end loop; -- Extract the entity of the subprogram call if Is_Entity_Name (Subp) then Subp_Id := Entity (Subp); if Ekind (Subp_Id) = E_Access_Subprogram_Type then Subp_Id := Directly_Designated_Type (Subp_Id); end if; if Is_Subprogram (Subp_Id) then return Subp_Id; else return Empty; end if; -- The search did not find a construct that denotes a subprogram else return Empty; end if; end Get_Subprogram_Entity; ----------------------------- -- Get_Task_Body_Procedure -- ----------------------------- function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is begin -- Note: A task type may be the completion of a private type with -- discriminants. When performing elaboration checks on a task -- declaration, the current view of the type may be the private one, -- and the procedure that holds the body of the task is held in its -- underlying type. -- This is an odd function, why not have Task_Body_Procedure do -- the following digging??? return Task_Body_Procedure (Underlying_Type (Root_Type (E))); end Get_Task_Body_Procedure; ------------------------- -- Get_User_Defined_Eq -- ------------------------- function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is Prim : Elmt_Id; Op : Entity_Id; begin Prim := First_Elmt (Collect_Primitive_Operations (E)); while Present (Prim) loop Op := Node (Prim); if Chars (Op) = Name_Op_Eq and then Etype (Op) = Standard_Boolean and then Etype (First_Formal (Op)) = E and then Etype (Next_Formal (First_Formal (Op))) = E then return Op; end if; Next_Elmt (Prim); end loop; return Empty; end Get_User_Defined_Eq; --------------- -- Get_Views -- --------------- procedure Get_Views (Typ : Entity_Id; Priv_Typ : out Entity_Id; Full_Typ : out Entity_Id; UFull_Typ : out Entity_Id; CRec_Typ : out Entity_Id) is IP_View : Entity_Id; begin -- Assume that none of the views can be recovered Priv_Typ := Empty; Full_Typ := Empty; UFull_Typ := Empty; CRec_Typ := Empty; -- The input type is the corresponding record type of a protected or a -- task type. if Ekind (Typ) = E_Record_Type and then Is_Concurrent_Record_Type (Typ) then CRec_Typ := Typ; Full_Typ := Corresponding_Concurrent_Type (CRec_Typ); Priv_Typ := Incomplete_Or_Partial_View (Full_Typ); -- Otherwise the input type denotes an arbitrary type else IP_View := Incomplete_Or_Partial_View (Typ); -- The input type denotes the full view of a private type if Present (IP_View) then Priv_Typ := IP_View; Full_Typ := Typ; -- The input type is a private type elsif Is_Private_Type (Typ) then Priv_Typ := Typ; Full_Typ := Full_View (Priv_Typ); -- Otherwise the input type does not have any views else Full_Typ := Typ; end if; if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then UFull_Typ := Underlying_Full_View (Full_Typ); if Present (UFull_Typ) and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type then CRec_Typ := Corresponding_Record_Type (UFull_Typ); end if; else if Present (Full_Typ) and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type then CRec_Typ := Corresponding_Record_Type (Full_Typ); end if; end if; 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 format 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 -- ------------------------------ function Has_Compatible_Alignment (Obj : Entity_Id; Expr : Node_Id; Layout_Done : Boolean) return Alignment_Result is function Has_Compatible_Alignment_Internal (Obj : Entity_Id; Expr : Node_Id; Layout_Done : Boolean; Default : Alignment_Result) return Alignment_Result; -- This is the internal recursive function that actually does the work. -- There is one additional parameter, which says what the result should -- be if no alignment information is found, and there is no definite -- indication of compatible alignments. At the outer level, this is set -- to Unknown, but for internal recursive calls in the case where types -- are known to be correct, it is set to Known_Compatible. --------------------------------------- -- Has_Compatible_Alignment_Internal -- --------------------------------------- function Has_Compatible_Alignment_Internal (Obj : Entity_Id; Expr : Node_Id; Layout_Done : Boolean; Default : Alignment_Result) return Alignment_Result is Result : Alignment_Result := Known_Compatible; -- Holds the current status of the result. Note that once a value of -- Known_Incompatible is set, it is sticky and does not get changed -- to Unknown (the value in Result only gets worse as we go along, -- never better). Offs : Uint := No_Uint; -- Set to a factor of the offset from the base object when Expr is a -- selected or indexed component, based on Component_Bit_Offset and -- Component_Size respectively. A negative value is used to represent -- a value which is not known at compile time. procedure Check_Prefix; -- Checks the prefix recursively in the case where the expression -- is an indexed or selected component. procedure Set_Result (R : Alignment_Result); -- If R represents a worse outcome (unknown instead of known -- compatible, or known incompatible), then set Result to R. ------------------ -- Check_Prefix -- ------------------ procedure Check_Prefix is begin -- The subtlety here is that in doing a recursive call to check -- the prefix, we have to decide what to do in the case where we -- don't find any specific indication of an alignment problem. -- At the outer level, we normally set Unknown as the result in -- this case, since we can only set Known_Compatible if we really -- know that the alignment value is OK, but for the recursive -- call, in the case where the types match, and we have not -- specified a peculiar alignment for the object, we are only -- concerned about suspicious rep clauses, the default case does -- not affect us, since the compiler will, in the absence of such -- rep clauses, ensure that the alignment is correct. if Default = Known_Compatible or else (Etype (Obj) = Etype (Expr) and then (Unknown_Alignment (Obj) or else Alignment (Obj) = Alignment (Etype (Obj)))) then Set_Result (Has_Compatible_Alignment_Internal (Obj, Prefix (Expr), Layout_Done, Known_Compatible)); -- In all other cases, we need a full check on the prefix else Set_Result (Has_Compatible_Alignment_Internal (Obj, Prefix (Expr), Layout_Done, Unknown)); end if; end Check_Prefix; ---------------- -- Set_Result -- ---------------- procedure Set_Result (R : Alignment_Result) is begin if R > Result then Result := R; end if; end Set_Result; -- Start of processing for Has_Compatible_Alignment_Internal begin -- If Expr is a selected component, we must make sure there is no -- potentially troublesome component clause and that the record is -- not packed if the layout is not done. if Nkind (Expr) = N_Selected_Component then -- Packing generates unknown alignment if layout is not done if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then Set_Result (Unknown); end if; -- Check prefix and component offset Check_Prefix; Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); -- If Expr is an indexed component, we must make sure there is no -- potentially troublesome Component_Size clause and that the array -- is not bit-packed if the layout is not done. elsif Nkind (Expr) = N_Indexed_Component then declare Typ : constant Entity_Id := Etype (Prefix (Expr)); begin -- Packing generates unknown alignment if layout is not done if Is_Bit_Packed_Array (Typ) and then not Layout_Done then Set_Result (Unknown); end if; -- Check prefix and component offset (or at least size) Check_Prefix; Offs := Indexed_Component_Bit_Offset (Expr); if Offs = No_Uint then Offs := Component_Size (Typ); end if; end; end if; -- If we have a null offset, the result is entirely determined by -- the base object and has already been computed recursively. if Offs = Uint_0 then null; -- Case where we know the alignment of the object elsif Known_Alignment (Obj) then declare ObjA : constant Uint := Alignment (Obj); ExpA : Uint := No_Uint; SizA : Uint := No_Uint; begin -- If alignment of Obj is 1, then we are always OK if ObjA = 1 then Set_Result (Known_Compatible); -- Alignment of Obj is greater than 1, so we need to check else -- If we have an offset, see if it is compatible if Offs /= No_Uint and Offs > Uint_0 then if Offs mod (System_Storage_Unit * ObjA) /= 0 then Set_Result (Known_Incompatible); end if; -- See if Expr is an object with known alignment elsif Is_Entity_Name (Expr) and then Known_Alignment (Entity (Expr)) then ExpA := Alignment (Entity (Expr)); -- Otherwise, we can use the alignment of the type of -- Expr given that we already checked for -- discombobulating rep clauses for the cases of indexed -- and selected components above. elsif Known_Alignment (Etype (Expr)) then ExpA := Alignment (Etype (Expr)); -- Otherwise the alignment is unknown else Set_Result (Default); end if; -- If we got an alignment, see if it is acceptable if ExpA /= No_Uint and then ExpA < ObjA then Set_Result (Known_Incompatible); end if; -- If Expr is not a piece of a larger object, see if size -- is given. If so, check that it is not too small for the -- required alignment. if Offs /= No_Uint then null; -- See if Expr is an object with known size elsif Is_Entity_Name (Expr) and then Known_Static_Esize (Entity (Expr)) then SizA := Esize (Entity (Expr)); -- Otherwise, we check the object size of the Expr type elsif Known_Static_Esize (Etype (Expr)) then SizA := Esize (Etype (Expr)); end if; -- If we got a size, see if it is a multiple of the Obj -- alignment, if not, then the alignment cannot be -- acceptable, since the size is always a multiple of the -- alignment. if SizA /= No_Uint then if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then Set_Result (Known_Incompatible); end if; end if; end if; end; -- If we do not know required alignment, any non-zero offset is a -- potential problem (but certainly may be OK, so result is unknown). elsif Offs /= No_Uint then Set_Result (Unknown); -- If we can't find the result by direct comparison of alignment -- values, then there is still one case that we can determine known -- result, and that is when we can determine that the types are the -- same, and no alignments are specified. Then we known that the -- alignments are compatible, even if we don't know the alignment -- value in the front end. elsif Etype (Obj) = Etype (Expr) then -- Types are the same, but we have to check for possible size -- and alignments on the Expr object that may make the alignment -- different, even though the types are the same. if Is_Entity_Name (Expr) then -- First check alignment of the Expr object. Any alignment less -- than Maximum_Alignment is worrisome since this is the case -- where we do not know the alignment of Obj. if Known_Alignment (Entity (Expr)) and then UI_To_Int (Alignment (Entity (Expr))) < Ttypes.Maximum_Alignment then Set_Result (Unknown); -- Now check size of Expr object. Any size that is not an -- even multiple of Maximum_Alignment is also worrisome -- since it may cause the alignment of the object to be less -- than the alignment of the type. elsif Known_Static_Esize (Entity (Expr)) and then (UI_To_Int (Esize (Entity (Expr))) mod (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) /= 0 then Set_Result (Unknown); -- Otherwise same type is decisive else Set_Result (Known_Compatible); end if; end if; -- Another case to deal with is when there is an explicit size or -- alignment clause when the types are not the same. If so, then the -- result is Unknown. We don't need to do this test if the Default is -- Unknown, since that result will be set in any case. elsif Default /= Unknown and then (Has_Size_Clause (Etype (Expr)) or else Has_Alignment_Clause (Etype (Expr))) then Set_Result (Unknown); -- If no indication found, set default else Set_Result (Default); end if; -- Return worst result found return Result; end Has_Compatible_Alignment_Internal; -- Start of processing for Has_Compatible_Alignment begin -- If Obj has no specified alignment, then set alignment from the type -- alignment. Perhaps we should always do this, but for sure we should -- do it when there is an address clause since we can do more if the -- alignment is known. if Unknown_Alignment (Obj) then Set_Alignment (Obj, Alignment (Etype (Obj))); end if; -- Now do the internal call that does all the work return Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown); end Has_Compatible_Alignment; ---------------------- -- Has_Declarations -- ---------------------- function Has_Declarations (N : Node_Id) return Boolean is begin return Nkind (N) in N_Accept_Statement | N_Block_Statement | N_Compilation_Unit_Aux | N_Entry_Body | N_Package_Body | N_Protected_Body | N_Subprogram_Body | N_Task_Body | N_Package_Specification; end Has_Declarations; --------------------------------- -- Has_Defaulted_Discriminants -- --------------------------------- function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is begin return Has_Discriminants (Typ) and then Present (First_Discriminant (Typ)) and then Present (Discriminant_Default_Value (First_Discriminant (Typ))); end Has_Defaulted_Discriminants; ------------------- -- Has_Denormals -- ------------------- function Has_Denormals (E : Entity_Id) return Boolean is begin return Is_Floating_Point_Type (E) and then Denorm_On_Target; end Has_Denormals; ------------------------------------------- -- Has_Discriminant_Dependent_Constraint -- ------------------------------------------- function Has_Discriminant_Dependent_Constraint (Comp : Entity_Id) return Boolean is Comp_Decl : constant Node_Id := Parent (Comp); Subt_Indic : Node_Id; Constr : Node_Id; Assn : Node_Id; begin -- Discriminants can't depend on discriminants if Ekind (Comp) = E_Discriminant then return False; else Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl)); if Nkind (Subt_Indic) = N_Subtype_Indication then Constr := Constraint (Subt_Indic); if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then Assn := First (Constraints (Constr)); while Present (Assn) loop case Nkind (Assn) is when N_Identifier | N_Range | N_Subtype_Indication => if Depends_On_Discriminant (Assn) then return True; end if; when N_Discriminant_Association => if Depends_On_Discriminant (Expression (Assn)) then return True; end if; when others => null; end case; Next (Assn); end loop; end if; end if; end if; return False; end Has_Discriminant_Dependent_Constraint; -------------------------------------- -- Has_Effectively_Volatile_Profile -- -------------------------------------- function Has_Effectively_Volatile_Profile (Subp_Id : Entity_Id) return Boolean is Formal : Entity_Id; begin -- Inspect the formal parameters looking for an effectively volatile -- type for reading. Formal := First_Formal (Subp_Id); while Present (Formal) loop if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then return True; end if; Next_Formal (Formal); end loop; -- Inspect the return type of functions if Ekind (Subp_Id) in E_Function | E_Generic_Function and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id)) then return True; end if; return False; end Has_Effectively_Volatile_Profile; -------------------------- -- Has_Enabled_Property -- -------------------------- function Has_Enabled_Property (Item_Id : Entity_Id; Property : Name_Id) return Boolean is function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean; -- Determine whether a protected type or variable denoted by Item_Id -- has the property enabled. function State_Has_Enabled_Property return Boolean; -- Determine whether a state denoted by Item_Id has the property enabled function Type_Or_Variable_Has_Enabled_Property (Item_Id : Entity_Id) return Boolean; -- Determine whether type or variable denoted by Item_Id has the -- property enabled. ----------------------------------------------------- -- Protected_Type_Or_Variable_Has_Enabled_Property -- ----------------------------------------------------- function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean is begin -- Protected entities always have the properties Async_Readers and -- Async_Writers (SPARK RM 7.1.2(16)). if Property = Name_Async_Readers or else Property = Name_Async_Writers then return True; -- Protected objects that have Part_Of components also inherit their -- properties Effective_Reads and Effective_Writes -- (SPARK RM 7.1.2(16)). elsif Is_Single_Protected_Object (Item_Id) then declare Constit_Elmt : Elmt_Id; Constit_Id : Entity_Id; Constits : constant Elist_Id := Part_Of_Constituents (Item_Id); begin if Present (Constits) then Constit_Elmt := First_Elmt (Constits); while Present (Constit_Elmt) loop Constit_Id := Node (Constit_Elmt); if Has_Enabled_Property (Constit_Id, Property) then return True; end if; Next_Elmt (Constit_Elmt); end loop; end if; end; end if; return False; end Protected_Type_Or_Variable_Has_Enabled_Property; -------------------------------- -- State_Has_Enabled_Property -- -------------------------------- function State_Has_Enabled_Property return Boolean is Decl : constant Node_Id := Parent (Item_Id); procedure Find_Simple_Properties (Has_External : out Boolean; Has_Synchronous : out Boolean); -- Extract the simple properties associated with declaration Decl function Is_Enabled_External_Property return Boolean; -- Determine whether property Property appears within the external -- property list of declaration Decl, and return its status. ---------------------------- -- Find_Simple_Properties -- ---------------------------- procedure Find_Simple_Properties (Has_External : out Boolean; Has_Synchronous : out Boolean) is Opt : Node_Id; begin -- Assume that none of the properties are available Has_External := False; Has_Synchronous := False; Opt := First (Expressions (Decl)); while Present (Opt) loop if Nkind (Opt) = N_Identifier then if Chars (Opt) = Name_External then Has_External := True; elsif Chars (Opt) = Name_Synchronous then Has_Synchronous := True; end if; end if; Next (Opt); end loop; end Find_Simple_Properties; ---------------------------------- -- Is_Enabled_External_Property -- ---------------------------------- function Is_Enabled_External_Property return Boolean is Opt : Node_Id; Opt_Nam : Node_Id; Prop : Node_Id; Prop_Nam : Node_Id; Props : Node_Id; begin Opt := First (Component_Associations (Decl)); while Present (Opt) loop Opt_Nam := First (Choices (Opt)); if Nkind (Opt_Nam) = N_Identifier and then Chars (Opt_Nam) = Name_External then Props := Expression (Opt); -- Multiple properties appear as an aggregate if Nkind (Props) = N_Aggregate then -- Simple property form Prop := First (Expressions (Props)); while Present (Prop) loop if Chars (Prop) = Property then return True; end if; Next (Prop); end loop; -- Property with expression form Prop := First (Component_Associations (Props)); while Present (Prop) loop Prop_Nam := First (Choices (Prop)); -- The property can be represented in two ways: -- others => -- => if Nkind (Prop_Nam) = N_Others_Choice or else (Nkind (Prop_Nam) = N_Identifier and then Chars (Prop_Nam) = Property) then return Is_True (Expr_Value (Expression (Prop))); end if; Next (Prop); end loop; -- Single property else return Chars (Props) = Property; end if; end if; Next (Opt); end loop; return False; end Is_Enabled_External_Property; -- Local variables Has_External : Boolean; Has_Synchronous : Boolean; -- Start of processing for State_Has_Enabled_Property begin -- The declaration of an external abstract state appears as an -- extension aggregate. If this is not the case, properties can -- never be set. if Nkind (Decl) /= N_Extension_Aggregate then return False; end if; Find_Simple_Properties (Has_External, Has_Synchronous); -- Simple option External enables all properties (SPARK RM 7.1.2(2)) if Has_External then return True; -- Option External may enable or disable specific properties elsif Is_Enabled_External_Property then return True; -- Simple option Synchronous -- -- enables disables -- Async_Readers Effective_Reads -- Async_Writers Effective_Writes -- -- Note that both forms of External have higher precedence than -- Synchronous (SPARK RM 7.1.4(9)). elsif Has_Synchronous then return Property in Name_Async_Readers | Name_Async_Writers; end if; return False; end State_Has_Enabled_Property; ------------------------------------------- -- Type_Or_Variable_Has_Enabled_Property -- ------------------------------------------- function Type_Or_Variable_Has_Enabled_Property (Item_Id : Entity_Id) return Boolean is function Is_Enabled (Prag : Node_Id) return Boolean; -- Determine whether property pragma Prag (if present) denotes an -- enabled property. ---------------- -- Is_Enabled -- ---------------- function Is_Enabled (Prag : Node_Id) return Boolean is Arg1 : Node_Id; begin if Present (Prag) then Arg1 := First (Pragma_Argument_Associations (Prag)); -- The pragma has an optional Boolean expression, the related -- property is enabled only when the expression evaluates to -- True. if Present (Arg1) then return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); -- Otherwise the lack of expression enables the property by -- default. else return True; end if; -- The property was never set in the first place else return False; end if; end Is_Enabled; -- Local variables AR : constant Node_Id := Get_Pragma (Item_Id, Pragma_Async_Readers); AW : constant Node_Id := Get_Pragma (Item_Id, Pragma_Async_Writers); ER : constant Node_Id := Get_Pragma (Item_Id, Pragma_Effective_Reads); EW : constant Node_Id := Get_Pragma (Item_Id, Pragma_Effective_Writes); Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean := Is_Derived_Type (Item_Id) and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id))); -- Start of processing for Type_Or_Variable_Has_Enabled_Property begin -- A non-effectively volatile object can never possess external -- properties. if not Is_Effectively_Volatile (Item_Id) then return False; -- External properties related to variables come in two flavors - -- explicit and implicit. The explicit case is characterized by the -- presence of a property pragma with an optional Boolean flag. The -- property is enabled when the flag evaluates to True or the flag is -- missing altogether. elsif Property = Name_Async_Readers and then Present (AR) then return Is_Enabled (AR); elsif Property = Name_Async_Writers and then Present (AW) then return Is_Enabled (AW); elsif Property = Name_Effective_Reads and then Present (ER) then return Is_Enabled (ER); elsif Property = Name_Effective_Writes and then Present (EW) then return Is_Enabled (EW); -- If other properties are set explicitly, then this one is set -- implicitly to False, except in the case of a derived type -- whose parent type is volatile (in that case, we will inherit -- from the parent type, below). elsif (Present (AR) or else Present (AW) or else Present (ER) or else Present (EW)) and then not Is_Derived_Type_With_Volatile_Parent_Type then return False; -- For a private type, may need to look at the full view elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id)) then return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id)); -- For a derived type whose parent type is volatile, the -- property may be inherited (but ignore a non-volatile parent). elsif Is_Derived_Type_With_Volatile_Parent_Type then return Type_Or_Variable_Has_Enabled_Property (First_Subtype (Etype (Base_Type (Item_Id)))); -- If not specified explicitly for an object and the type -- is effectively volatile, then take result from the type. elsif not Is_Type (Item_Id) and then Is_Effectively_Volatile (Etype (Item_Id)) then return Has_Enabled_Property (Etype (Item_Id), Property); -- The implicit case lacks all property pragmas elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then if Is_Protected_Type (Etype (Item_Id)) then return Protected_Type_Or_Variable_Has_Enabled_Property; else return True; end if; else return False; end if; end Type_Or_Variable_Has_Enabled_Property; -- Start of processing for Has_Enabled_Property begin -- Abstract states and variables have a flexible scheme of specifying -- external properties. if Ekind (Item_Id) = E_Abstract_State then return State_Has_Enabled_Property; elsif Ekind (Item_Id) in E_Variable | E_Constant then return Type_Or_Variable_Has_Enabled_Property (Item_Id); -- Other objects can only inherit properties through their type. We -- cannot call directly Type_Or_Variable_Has_Enabled_Property on -- these as they don't have contracts attached, which is expected by -- this function. elsif Is_Object (Item_Id) then return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id)); elsif Is_Type (Item_Id) then return Type_Or_Variable_Has_Enabled_Property (Item_Id => First_Subtype (Item_Id)); -- Otherwise a property is enabled when the related item is effectively -- volatile. else return Is_Effectively_Volatile (Item_Id); end if; end Has_Enabled_Property; ------------------------------------- -- Has_Full_Default_Initialization -- ------------------------------------- function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is Comp : Entity_Id; begin -- A type subject to pragma Default_Initial_Condition may be fully -- default initialized depending on inheritance and the argument of -- the pragma. Since any type may act as the full view of a private -- type, this check must be performed prior to the specialized tests -- below. if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then return True; end if; -- A scalar type is fully default initialized if it is subject to aspect -- Default_Value. if Is_Scalar_Type (Typ) then return Has_Default_Aspect (Typ); -- An access type is fully default initialized by default elsif Is_Access_Type (Typ) then return True; -- An array type is fully default initialized if its element type is -- scalar and the array type carries aspect Default_Component_Value or -- the element type is fully default initialized. elsif Is_Array_Type (Typ) then return Has_Default_Aspect (Typ) or else Has_Full_Default_Initialization (Component_Type (Typ)); -- A protected type, record type, or type extension is fully default -- initialized if all its components either carry an initialization -- expression or have a type that is fully default initialized. The -- parent type of a type extension must be fully default initialized. elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then -- Inspect all entities defined in the scope of the type, looking for -- uninitialized components. Comp := First_Component (Typ); while Present (Comp) loop if Comes_From_Source (Comp) and then No (Expression (Parent (Comp))) and then not Has_Full_Default_Initialization (Etype (Comp)) then return False; end if; Next_Component (Comp); end loop; -- Ensure that the parent type of a type extension is fully default -- initialized. if Etype (Typ) /= Typ and then not Has_Full_Default_Initialization (Etype (Typ)) then return False; end if; -- If we get here, then all components and parent portion are fully -- default initialized. return True; -- A task type is fully default initialized by default elsif Is_Task_Type (Typ) then return True; -- Otherwise the type is not fully default initialized else return False; end if; end Has_Full_Default_Initialization; ----------------------------------------------- -- Has_Fully_Default_Initializing_DIC_Pragma -- ----------------------------------------------- function Has_Fully_Default_Initializing_DIC_Pragma (Typ : Entity_Id) return Boolean is Args : List_Id; Prag : Node_Id; begin -- A type that inherits pragma Default_Initial_Condition from a parent -- type is automatically fully default initialized. if Has_Inherited_DIC (Typ) then return True; -- Otherwise the type is fully default initialized only when the pragma -- appears without an argument, or the argument is non-null. elsif Has_Own_DIC (Typ) then Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition); pragma Assert (Present (Prag)); Args := Pragma_Argument_Associations (Prag); -- The pragma appears without an argument in which case it defaults -- to True. if No (Args) then return True; -- The pragma appears with a non-null expression elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then return True; end if; end if; return False; end Has_Fully_Default_Initializing_DIC_Pragma; -------------------- -- Has_Infinities -- -------------------- function Has_Infinities (E : Entity_Id) return Boolean is begin return Is_Floating_Point_Type (E) and then Nkind (Scalar_Range (E)) = N_Range and then Includes_Infinities (Scalar_Range (E)); end Has_Infinities; -------------------- -- Has_Interfaces -- -------------------- function Has_Interfaces (T : Entity_Id; Use_Full_View : Boolean := True) return Boolean is Typ : Entity_Id := Base_Type (T); begin -- Handle concurrent types if Is_Concurrent_Type (Typ) then Typ := Corresponding_Record_Type (Typ); end if; if not Present (Typ) or else not Is_Record_Type (Typ) or else not Is_Tagged_Type (Typ) then return False; end if; -- Handle private types if Use_Full_View and then Present (Full_View (Typ)) then Typ := Full_View (Typ); end if; -- Handle concurrent record types if Is_Concurrent_Record_Type (Typ) and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) then return True; end if; loop if Is_Interface (Typ) or else (Is_Record_Type (Typ) and then Present (Interfaces (Typ)) and then not Is_Empty_Elmt_List (Interfaces (Typ))) then return True; end if; exit when Etype (Typ) = Typ -- Handle private types or else (Present (Full_View (Etype (Typ))) and then Full_View (Etype (Typ)) = Typ) -- Protect frontend against wrong sources with cyclic derivations or else Etype (Typ) = T; -- Climb to the ancestor type handling private types if Present (Full_View (Etype (Typ))) then Typ := Full_View (Etype (Typ)); else Typ := Etype (Typ); end if; end loop; return False; end Has_Interfaces; -------------------------- -- Has_Max_Queue_Length -- -------------------------- function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is begin return Ekind (Id) = E_Entry and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length)); end Has_Max_Queue_Length; --------------------------------- -- Has_No_Obvious_Side_Effects -- --------------------------------- function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is begin -- For now handle literals, constants, and non-volatile variables and -- expressions combining these with operators or short circuit forms. if Nkind (N) in N_Numeric_Or_String_Literal then return True; elsif Nkind (N) = N_Character_Literal then return True; elsif Nkind (N) in N_Unary_Op then return Has_No_Obvious_Side_Effects (Right_Opnd (N)); elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then return Has_No_Obvious_Side_Effects (Left_Opnd (N)) and then Has_No_Obvious_Side_Effects (Right_Opnd (N)); elsif Nkind (N) = N_Expression_With_Actions and then Is_Empty_List (Actions (N)) then return Has_No_Obvious_Side_Effects (Expression (N)); elsif Nkind (N) in N_Has_Entity then return Present (Entity (N)) and then Ekind (Entity (N)) in E_Variable | E_Constant | E_Enumeration_Literal | E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter and then not Is_Volatile (Entity (N)); else return False; end if; end Has_No_Obvious_Side_Effects; ----------------------------- -- Has_Non_Null_Refinement -- ----------------------------- function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is Constits : Elist_Id; begin pragma Assert (Ekind (Id) = E_Abstract_State); Constits := Refinement_Constituents (Id); -- For a refinement to be non-null, the first constituent must be -- anything other than null. return Present (Constits) and then Nkind (Node (First_Elmt (Constits))) /= N_Null; end Has_Non_Null_Refinement; ----------------------------- -- Has_Non_Null_Statements -- ----------------------------- function Has_Non_Null_Statements (L : List_Id) return Boolean is Node : Node_Id; begin if Is_Non_Empty_List (L) then Node := First (L); loop if Nkind (Node) not in N_Null_Statement | N_Call_Marker then return True; end if; Next (Node); exit when Node = Empty; end loop; end if; return False; end Has_Non_Null_Statements; ---------------------------------- -- Is_Access_Subprogram_Wrapper -- ---------------------------------- function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is Formal : constant Entity_Id := Last_Formal (E); begin return Present (Formal) and then Ekind (Etype (Formal)) in Access_Subprogram_Kind and then Access_Subprogram_Wrapper (Directly_Designated_Type (Etype (Formal))) = E; end Is_Access_Subprogram_Wrapper; --------------------------- -- Is_Explicitly_Aliased -- --------------------------- function Is_Explicitly_Aliased (N : Node_Id) return Boolean is begin return Is_Formal (N) and then Present (Parent (N)) and then Nkind (Parent (N)) = N_Parameter_Specification and then Aliased_Present (Parent (N)); end Is_Explicitly_Aliased; ---------------------------- -- Is_Container_Aggregate -- ---------------------------- function Is_Container_Aggregate (Exp : Node_Id) return Boolean is function Is_Record_Aggregate return Boolean is (False); -- ??? Unimplemented. Given an aggregate whose type is a -- record type with specified Aggregate aspect, how do we -- determine whether it is a record aggregate or a container -- aggregate? If the code where the aggregate occurs can see only -- a partial view of the aggregate's type then the aggregate -- cannot be a record type; an aggregate of a private type has to -- be a container aggregate. begin return Nkind (Exp) = N_Aggregate and then Present (Find_Aspect (Etype (Exp), Aspect_Aggregate)) and then not Is_Record_Aggregate; end Is_Container_Aggregate; --------------------------------- -- Side_Effect_Free_Statements -- --------------------------------- function Side_Effect_Free_Statements (L : List_Id) return Boolean is Node : Node_Id; begin if Is_Non_Empty_List (L) then Node := First (L); loop case Nkind (Node) is when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error => null; when N_Object_Declaration => if Present (Expression (Node)) and then not Side_Effect_Free (Expression (Node)) then return False; end if; when others => return False; end case; Next (Node); exit when Node = Empty; end loop; end if; return True; end Side_Effect_Free_Statements; --------------------------- -- Side_Effect_Free_Loop -- --------------------------- function Side_Effect_Free_Loop (N : Node_Id) return Boolean is Scheme : Node_Id; Spec : Node_Id; Subt : Node_Id; begin -- If this is not a loop (e.g. because the loop has been rewritten), -- then return false. if Nkind (N) /= N_Loop_Statement then return False; end if; -- First check the statements if Side_Effect_Free_Statements (Statements (N)) then -- Then check the loop condition/indexes if Present (Iteration_Scheme (N)) then Scheme := Iteration_Scheme (N); if Present (Condition (Scheme)) or else Present (Iterator_Specification (Scheme)) then return False; elsif Present (Loop_Parameter_Specification (Scheme)) then Spec := Loop_Parameter_Specification (Scheme); Subt := Discrete_Subtype_Definition (Spec); if Present (Subt) then if Nkind (Subt) = N_Range then return Side_Effect_Free (Low_Bound (Subt)) and then Side_Effect_Free (High_Bound (Subt)); else -- subtype indication return True; end if; end if; end if; end if; end if; return False; end Side_Effect_Free_Loop; ---------------------------------- -- Has_Non_Trivial_Precondition -- ---------------------------------- function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre); begin return Present (Pre) and then Class_Present (Pre) and then not Is_Entity_Name (Expression (Pre)); end Has_Non_Trivial_Precondition; ------------------- -- Has_Null_Body -- ------------------- function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is Body_Id : Entity_Id; Decl : Node_Id; Spec : Node_Id; Stmt1 : Node_Id; Stmt2 : Node_Id; begin Spec := Parent (Proc_Id); Decl := Parent (Spec); -- Retrieve the entity of the procedure body (e.g. invariant proc). if Nkind (Spec) = N_Procedure_Specification and then Nkind (Decl) = N_Subprogram_Declaration then Body_Id := Corresponding_Body (Decl); -- The body acts as a spec else Body_Id := Proc_Id; end if; -- The body will be generated later if No (Body_Id) then return False; end if; Spec := Parent (Body_Id); Decl := Parent (Spec); pragma Assert (Nkind (Spec) = N_Procedure_Specification and then Nkind (Decl) = N_Subprogram_Body); Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); -- Look for a null statement followed by an optional return -- statement. if Nkind (Stmt1) = N_Null_Statement then Stmt2 := Next (Stmt1); if Present (Stmt2) then return Nkind (Stmt2) = N_Simple_Return_Statement; else return True; end if; end if; return False; end Has_Null_Body; ------------------------ -- Has_Null_Exclusion -- ------------------------ function Has_Null_Exclusion (N : Node_Id) return Boolean is begin case Nkind (N) is when N_Access_Definition | N_Access_Function_Definition | N_Access_Procedure_Definition | N_Access_To_Object_Definition | N_Allocator | N_Derived_Type_Definition | N_Function_Specification | N_Subtype_Declaration => return Null_Exclusion_Present (N); when N_Component_Definition | N_Formal_Object_Declaration => if Present (Subtype_Mark (N)) then return Null_Exclusion_Present (N); else pragma Assert (Present (Access_Definition (N))); return Null_Exclusion_Present (Access_Definition (N)); end if; when N_Object_Renaming_Declaration => if Present (Subtype_Mark (N)) then return Null_Exclusion_Present (N); elsif Present (Access_Definition (N)) then return Null_Exclusion_Present (Access_Definition (N)); else return False; -- Case of no subtype in renaming (AI12-0275) end if; when N_Discriminant_Specification => if Nkind (Discriminant_Type (N)) = N_Access_Definition then return Null_Exclusion_Present (Discriminant_Type (N)); else return Null_Exclusion_Present (N); end if; when N_Object_Declaration => if Nkind (Object_Definition (N)) = N_Access_Definition then return Null_Exclusion_Present (Object_Definition (N)); else return Null_Exclusion_Present (N); end if; when N_Parameter_Specification => if Nkind (Parameter_Type (N)) = N_Access_Definition then return Null_Exclusion_Present (Parameter_Type (N)) or else Null_Exclusion_Present (N); else return Null_Exclusion_Present (N); end if; when others => return False; end case; end Has_Null_Exclusion; ------------------------ -- Has_Null_Extension -- ------------------------ function Has_Null_Extension (T : Entity_Id) return Boolean is B : constant Entity_Id := Base_Type (T); Comps : Node_Id; Ext : Node_Id; begin if Nkind (Parent (B)) = N_Full_Type_Declaration and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) then Ext := Record_Extension_Part (Type_Definition (Parent (B))); if Present (Ext) then if Null_Present (Ext) then return True; else Comps := Component_List (Ext); -- The null component list is rewritten during analysis to -- include the parent component. Any other component indicates -- that the extension was not originally null. return Null_Present (Comps) or else No (Next (First (Component_Items (Comps)))); end if; else return False; end if; else return False; end if; end Has_Null_Extension; ------------------------- -- Has_Null_Refinement -- ------------------------- function Has_Null_Refinement (Id : Entity_Id) return Boolean is Constits : Elist_Id; begin pragma Assert (Ekind (Id) = E_Abstract_State); Constits := Refinement_Constituents (Id); -- For a refinement to be null, the state's sole constituent must be a -- null. return Present (Constits) and then Nkind (Node (First_Elmt (Constits))) = N_Null; end Has_Null_Refinement; ------------------------------- -- Has_Overriding_Initialize -- ------------------------------- function Has_Overriding_Initialize (T : Entity_Id) return Boolean is BT : constant Entity_Id := Base_Type (T); P : Elmt_Id; begin if Is_Controlled (BT) then if Is_RTU (Scope (BT), Ada_Finalization) then return False; elsif Present (Primitive_Operations (BT)) then P := First_Elmt (Primitive_Operations (BT)); while Present (P) loop declare Init : constant Entity_Id := Node (P); Formal : constant Entity_Id := First_Formal (Init); begin if Ekind (Init) = E_Procedure and then Chars (Init) = Name_Initialize and then Comes_From_Source (Init) and then Present (Formal) and then Etype (Formal) = BT and then No (Next_Formal (Formal)) and then (Ada_Version < Ada_2012 or else not Null_Present (Parent (Init))) then return True; end if; end; Next_Elmt (P); end loop; end if; -- Here if type itself does not have a non-null Initialize operation: -- check immediate ancestor. if Is_Derived_Type (BT) and then Has_Overriding_Initialize (Etype (BT)) then return True; end if; end if; return False; end Has_Overriding_Initialize; -------------------------------------- -- Has_Preelaborable_Initialization -- -------------------------------------- function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is Has_PE : Boolean; procedure Check_Components (E : Entity_Id); -- Check component/discriminant chain, sets Has_PE False if a component -- or discriminant does not meet the preelaborable initialization rules. ---------------------- -- Check_Components -- ---------------------- procedure Check_Components (E : Entity_Id) is Ent : Entity_Id; Exp : Node_Id; begin -- Loop through entities of record or protected type Ent := E; while Present (Ent) loop -- We are interested only in components and discriminants Exp := Empty; case Ekind (Ent) is when E_Component => -- Get default expression if any. If there is no declaration -- node, it means we have an internal entity. The parent and -- tag fields are examples of such entities. For such cases, -- we just test the type of the entity. if Present (Declaration_Node (Ent)) then Exp := Expression (Declaration_Node (Ent)); end if; when E_Discriminant => -- Note: for a renamed discriminant, the Declaration_Node -- may point to the one from the ancestor, and have a -- different expression, so use the proper attribute to -- retrieve the expression from the derived constraint. Exp := Discriminant_Default_Value (Ent); when others => goto Check_Next_Entity; end case; -- A component has PI if it has no default expression and the -- component type has PI. if No (Exp) then if not Has_Preelaborable_Initialization (Etype (Ent)) then Has_PE := False; exit; end if; -- Require the default expression to be preelaborable elsif not Is_Preelaborable_Construct (Exp) then Has_PE := False; exit; end if; <> Next_Entity (Ent); end loop; end Check_Components; -- Start of processing for Has_Preelaborable_Initialization begin -- Immediate return if already marked as known preelaborable init. This -- covers types for which this function has already been called once -- and returned True (in which case the result is cached), and also -- types to which a pragma Preelaborable_Initialization applies. if Known_To_Have_Preelab_Init (E) then return True; end if; -- If the type is a subtype representing a generic actual type, then -- test whether its base type has preelaborable initialization since -- the subtype representing the actual does not inherit this attribute -- from the actual or formal. (but maybe it should???) if Is_Generic_Actual_Type (E) then return Has_Preelaborable_Initialization (Base_Type (E)); end if; -- All elementary types have preelaborable initialization if Is_Elementary_Type (E) then Has_PE := True; -- Array types have PI if the component type has PI elsif Is_Array_Type (E) then Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); -- A derived type has preelaborable initialization if its parent type -- has preelaborable initialization and (in the case of a derived record -- extension) if the non-inherited components all have preelaborable -- initialization. However, a user-defined controlled type with an -- overriding Initialize procedure does not have preelaborable -- initialization. elsif Is_Derived_Type (E) then -- If the derived type is a private extension then it doesn't have -- preelaborable initialization. if Ekind (Base_Type (E)) = E_Record_Type_With_Private then return False; end if; -- First check whether ancestor type has preelaborable initialization Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); -- If OK, check extension components (if any) if Has_PE and then Is_Record_Type (E) then Check_Components (First_Entity (E)); end if; -- Check specifically for 10.2.1(11.4/2) exception: a controlled type -- with a user defined Initialize procedure does not have PI. If -- the type is untagged, the control primitives come from a component -- that has already been checked. if Has_PE and then Is_Controlled (E) and then Is_Tagged_Type (E) and then Has_Overriding_Initialize (E) then Has_PE := False; end if; -- Private types not derived from a type having preelaborable init and -- that are not marked with pragma Preelaborable_Initialization do not -- have preelaborable initialization. elsif Is_Private_Type (E) then return False; -- Record type has PI if it is non private and all components have PI elsif Is_Record_Type (E) then Has_PE := True; Check_Components (First_Entity (E)); -- Protected types must not have entries, and components must meet -- same set of rules as for record components. elsif Is_Protected_Type (E) then if Has_Entries (E) then Has_PE := False; else Has_PE := True; Check_Components (First_Entity (E)); Check_Components (First_Private_Entity (E)); end if; -- Type System.Address always has preelaborable initialization elsif Is_RTE (E, RE_Address) then Has_PE := True; -- In all other cases, type does not have preelaborable initialization else return False; end if; -- If type has preelaborable initialization, cache result if Has_PE then Set_Known_To_Have_Preelab_Init (E); end if; return Has_PE; end Has_Preelaborable_Initialization; ---------------- -- Has_Prefix -- ---------------- function Has_Prefix (N : Node_Id) return Boolean is begin return Nkind (N) in N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference | N_Indexed_Component | N_Reference | N_Selected_Component | N_Slice; end Has_Prefix; --------------------------- -- Has_Private_Component -- --------------------------- function Has_Private_Component (Type_Id : Entity_Id) return Boolean is Btype : Entity_Id := Base_Type (Type_Id); Component : Entity_Id; begin if Error_Posted (Type_Id) or else Error_Posted (Btype) then return False; end if; if Is_Class_Wide_Type (Btype) then Btype := Root_Type (Btype); end if; if Is_Private_Type (Btype) then declare UT : constant Entity_Id := Underlying_Type (Btype); begin if No (UT) then if No (Full_View (Btype)) then return not Is_Generic_Type (Btype) and then not Is_Generic_Type (Root_Type (Btype)); else return not Is_Generic_Type (Root_Type (Full_View (Btype))); end if; else return not Is_Frozen (UT) and then Has_Private_Component (UT); end if; end; elsif Is_Array_Type (Btype) then return Has_Private_Component (Component_Type (Btype)); elsif Is_Record_Type (Btype) then Component := First_Component (Btype); while Present (Component) loop if Has_Private_Component (Etype (Component)) then return True; end if; Next_Component (Component); end loop; return False; elsif Is_Protected_Type (Btype) and then Present (Corresponding_Record_Type (Btype)) then return Has_Private_Component (Corresponding_Record_Type (Btype)); else return False; end if; end Has_Private_Component; -------------------------------- -- Has_Relaxed_Initialization -- -------------------------------- function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is function Denotes_Relaxed_Parameter (Expr : Node_Id; Param : Entity_Id) return Boolean; -- Returns True iff expression Expr denotes a formal parameter or -- function Param (through its attribute Result). ------------------------------- -- Denotes_Relaxed_Parameter -- ------------------------------- function Denotes_Relaxed_Parameter (Expr : Node_Id; Param : Entity_Id) return Boolean is begin if Nkind (Expr) in N_Identifier | N_Expanded_Name then return Entity (Expr) = Param; else pragma Assert (Is_Attribute_Result (Expr)); return Entity (Prefix (Expr)) = Param; end if; end Denotes_Relaxed_Parameter; -- Start of processing for Has_Relaxed_Initialization begin -- When analyzing, we checked all syntax legality rules for the aspect -- Relaxed_Initialization, but didn't store the property anywhere (e.g. -- as an Einfo flag). To query the property we look directly at the AST, -- but now without any syntactic checks. case Ekind (E) is -- Abstract states have option Relaxed_Initialization when E_Abstract_State => return Is_Relaxed_Initialization_State (E); -- Constants have this aspect attached directly; for deferred -- constants, the aspect is attached to the partial view. when E_Constant => return Has_Aspect (E, Aspect_Relaxed_Initialization); -- Variables have this aspect attached directly when E_Variable => return Has_Aspect (E, Aspect_Relaxed_Initialization); -- Types have this aspect attached directly (though we only allow it -- to be specified for the first subtype). For private types, the -- aspect is attached to the partial view. when Type_Kind => pragma Assert (Is_First_Subtype (E)); return Has_Aspect (E, Aspect_Relaxed_Initialization); -- Formal parameters and functions have the Relaxed_Initialization -- aspect attached to the subprogram entity and must be listed in -- the aspect expression. when Formal_Kind | E_Function => declare Subp_Id : Entity_Id; Aspect_Expr : Node_Id; Param_Expr : Node_Id; Assoc : Node_Id; begin if Is_Formal (E) then Subp_Id := Scope (E); else Subp_Id := E; end if; if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then Aspect_Expr := Find_Value_Of_Aspect (Subp_Id, Aspect_Relaxed_Initialization); -- Aspect expression is either an aggregate with an optional -- Boolean expression (which defaults to True), e.g.: -- -- function F (X : Integer) return Integer -- with Relaxed_Initialization => (X => True, F'Result); if Nkind (Aspect_Expr) = N_Aggregate then if Present (Component_Associations (Aspect_Expr)) then Assoc := First (Component_Associations (Aspect_Expr)); while Present (Assoc) loop if Denotes_Relaxed_Parameter (First (Choices (Assoc)), E) then return Is_True (Static_Boolean (Expression (Assoc))); end if; Next (Assoc); end loop; end if; Param_Expr := First (Expressions (Aspect_Expr)); while Present (Param_Expr) loop if Denotes_Relaxed_Parameter (Param_Expr, E) then return True; end if; Next (Param_Expr); end loop; return False; -- or it is a single identifier, e.g.: -- -- function F (X : Integer) return Integer -- with Relaxed_Initialization => X; else return Denotes_Relaxed_Parameter (Aspect_Expr, E); end if; else return False; end if; end; when others => raise Program_Error; end case; end Has_Relaxed_Initialization; ---------------------- -- Has_Signed_Zeros -- ---------------------- function Has_Signed_Zeros (E : Entity_Id) return Boolean is begin return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target; end Has_Signed_Zeros; ------------------------------ -- Has_Significant_Contract -- ------------------------------ function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is Subp_Nam : constant Name_Id := Chars (Subp_Id); begin -- _Finalizer procedure if Subp_Nam = Name_uFinalizer then return False; -- _Postconditions procedure elsif Subp_Nam = Name_uPostconditions then return False; -- Predicate function elsif Ekind (Subp_Id) = E_Function and then Is_Predicate_Function (Subp_Id) then return False; -- TSS subprogram elsif Get_TSS_Name (Subp_Id) /= TSS_Null then return False; else return True; end if; end Has_Significant_Contract; ----------------------------- -- Has_Static_Array_Bounds -- ----------------------------- function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is All_Static : Boolean; Dummy : Boolean; begin Examine_Array_Bounds (Typ, All_Static, Dummy); return All_Static; end Has_Static_Array_Bounds; --------------------------------------- -- Has_Static_Non_Empty_Array_Bounds -- --------------------------------------- function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is All_Static : Boolean; Has_Empty : Boolean; begin Examine_Array_Bounds (Typ, All_Static, Has_Empty); return All_Static and not Has_Empty; end Has_Static_Non_Empty_Array_Bounds; ---------------- -- Has_Stream -- ---------------- function Has_Stream (T : Entity_Id) return Boolean is E : Entity_Id; begin if No (T) then return False; elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then return True; elsif Is_Array_Type (T) then return Has_Stream (Component_Type (T)); elsif Is_Record_Type (T) then E := First_Component (T); while Present (E) loop if Has_Stream (Etype (E)) then return True; else Next_Component (E); end if; end loop; return False; elsif Is_Private_Type (T) then return Has_Stream (Underlying_Type (T)); else return False; end if; end Has_Stream; ---------------- -- Has_Suffix -- ---------------- function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is begin Get_Name_String (Chars (E)); return Name_Buffer (Name_Len) = Suffix; end Has_Suffix; ---------------- -- Add_Suffix -- ---------------- function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is begin Get_Name_String (Chars (E)); Add_Char_To_Name_Buffer (Suffix); return Name_Find; end Add_Suffix; ------------------- -- Remove_Suffix -- ------------------- function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is begin pragma Assert (Has_Suffix (E, Suffix)); Get_Name_String (Chars (E)); Name_Len := Name_Len - 1; return Name_Find; end Remove_Suffix; ---------------------------------- -- Replace_Null_By_Null_Address -- ---------------------------------- procedure Replace_Null_By_Null_Address (N : Node_Id) is procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id); -- Replace operand Op with a reference to Null_Address when the operand -- denotes a null Address. Other_Op denotes the other operand. -------------------------- -- Replace_Null_Operand -- -------------------------- procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is begin -- Check the type of the complementary operand since the N_Null node -- has not been decorated yet. if Nkind (Op) = N_Null and then Is_Descendant_Of_Address (Etype (Other_Op)) then Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op))); end if; end Replace_Null_Operand; -- Start of processing for Replace_Null_By_Null_Address begin pragma Assert (Relaxed_RM_Semantics); pragma Assert (Nkind (N) in N_Null | N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne); if Nkind (N) = N_Null then Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); else declare L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); begin Replace_Null_Operand (L, Other_Op => R); Replace_Null_Operand (R, Other_Op => L); end; end if; end Replace_Null_By_Null_Address; -------------------------- -- Has_Tagged_Component -- -------------------------- function Has_Tagged_Component (Typ : Entity_Id) return Boolean is Comp : Entity_Id; begin if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then return Has_Tagged_Component (Underlying_Type (Typ)); elsif Is_Array_Type (Typ) then return Has_Tagged_Component (Component_Type (Typ)); elsif Is_Tagged_Type (Typ) then return True; elsif Is_Record_Type (Typ) then Comp := First_Component (Typ); while Present (Comp) loop if Has_Tagged_Component (Etype (Comp)) then return True; end if; Next_Component (Comp); end loop; return False; else return False; 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 -- ----------------------------- function Has_Undefined_Reference (Expr : Node_Id) return Boolean is Has_Undef_Ref : Boolean := False; -- Flag set when expression Expr contains at least one undefined -- reference. function Is_Undefined_Reference (N : Node_Id) return Traverse_Result; -- Determine whether N denotes a reference and if it does, whether it is -- undefined. ---------------------------- -- Is_Undefined_Reference -- ---------------------------- function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is begin if Is_Entity_Name (N) and then Present (Entity (N)) and then Entity (N) = Any_Id then Has_Undef_Ref := True; return Abandon; end if; return OK; end Is_Undefined_Reference; procedure Find_Undefined_References is new Traverse_Proc (Is_Undefined_Reference); -- Start of processing for Has_Undefined_Reference begin Find_Undefined_References (Expr); return Has_Undef_Ref; end Has_Undefined_Reference; ---------------------------- -- Has_Volatile_Component -- ---------------------------- function Has_Volatile_Component (Typ : Entity_Id) return Boolean is Comp : Entity_Id; begin if Has_Volatile_Components (Typ) then return True; elsif Is_Array_Type (Typ) then return Is_Volatile (Component_Type (Typ)); elsif Is_Record_Type (Typ) then Comp := First_Component (Typ); while Present (Comp) loop if Is_Volatile_Object (Comp) then return True; end if; Next_Component (Comp); end loop; end if; return False; end Has_Volatile_Component; ------------------------- -- Implementation_Kind -- ------------------------- function Implementation_Kind (Subp : Entity_Id) return Name_Id is Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); Arg : Node_Id; begin pragma Assert (Present (Impl_Prag)); Arg := Last (Pragma_Argument_Associations (Impl_Prag)); return Chars (Get_Pragma_Arg (Arg)); end Implementation_Kind; -------------------------- -- Implements_Interface -- -------------------------- function Implements_Interface (Typ_Ent : Entity_Id; Iface_Ent : Entity_Id; Exclude_Parents : Boolean := False) return Boolean is Ifaces_List : Elist_Id; Elmt : Elmt_Id; Iface : Entity_Id := Base_Type (Iface_Ent); Typ : Entity_Id := Base_Type (Typ_Ent); begin if Is_Class_Wide_Type (Typ) then Typ := Root_Type (Typ); end if; if not Has_Interfaces (Typ) then return False; end if; if Is_Class_Wide_Type (Iface) then Iface := Root_Type (Iface); end if; Collect_Interfaces (Typ, Ifaces_List); Elmt := First_Elmt (Ifaces_List); while Present (Elmt) loop if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True) and then Exclude_Parents then null; elsif Node (Elmt) = Iface then return True; end if; Next_Elmt (Elmt); end loop; return False; end Implements_Interface; -------------------------------- -- Implicitly_Designated_Type -- -------------------------------- function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is Desig : constant Entity_Id := Designated_Type (Typ); begin -- An implicit dereference is a legal occurrence of an incomplete type -- imported through a limited_with clause, if the full view is visible. if Is_Incomplete_Type (Desig) and then From_Limited_With (Desig) and then not From_Limited_With (Scope (Desig)) and then (Is_Immediately_Visible (Scope (Desig)) or else (Is_Child_Unit (Scope (Desig)) and then Is_Visible_Lib_Unit (Scope (Desig)))) then return Available_View (Desig); else return Desig; end if; end Implicitly_Designated_Type; ------------------------------------ -- In_Assertion_Expression_Pragma -- ------------------------------------ function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is Par : Node_Id; Prag : Node_Id := Empty; begin -- Climb the parent chain looking for an enclosing pragma Par := N; while Present (Par) loop if Nkind (Par) = N_Pragma then Prag := Par; exit; -- Precondition-like pragmas are expanded into if statements, check -- the original node instead. elsif Nkind (Original_Node (Par)) = N_Pragma then Prag := Original_Node (Par); exit; -- The expansion of attribute 'Old generates a constant to capture -- the result of the prefix. If the parent traversal reaches -- one of these constants, then the node technically came from a -- postcondition-like pragma. Note that the Ekind is not tested here -- because N may be the expression of an object declaration which is -- currently being analyzed. Such objects carry Ekind of E_Void. elsif Nkind (Par) = N_Object_Declaration and then Constant_Present (Par) and then Stores_Attribute_Old_Prefix (Defining_Entity (Par)) then return True; -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then return False; end if; Par := Parent (Par); end loop; return Present (Prag) and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag)); end In_Assertion_Expression_Pragma; ---------------------- -- In_Generic_Scope -- ---------------------- function In_Generic_Scope (E : Entity_Id) return Boolean is S : Entity_Id; begin S := Scope (E); while Present (S) and then S /= Standard_Standard loop if Is_Generic_Unit (S) then return True; end if; S := Scope (S); end loop; return False; end In_Generic_Scope; ----------------- -- In_Instance -- ----------------- function In_Instance return Boolean is Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); S : Entity_Id; begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop if Is_Generic_Instance (S) then -- A child instance is always compiled in the context of a parent -- instance. Nevertheless, its actuals must not be analyzed in an -- instance context. We detect this case by examining the current -- compilation unit, which must be a child instance, and checking -- that it has not been analyzed yet. if Is_Child_Unit (Curr_Unit) and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Instantiation and then Ekind (Curr_Unit) = E_Void then return False; else return True; end if; end if; S := Scope (S); end loop; return False; end In_Instance; ---------------------- -- In_Instance_Body -- ---------------------- function In_Instance_Body return Boolean is S : Entity_Id; begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop if Ekind (S) in E_Function | E_Procedure and then Is_Generic_Instance (S) then return True; elsif Ekind (S) = E_Package and then In_Package_Body (S) and then Is_Generic_Instance (S) then return True; end if; S := Scope (S); end loop; return False; end In_Instance_Body; ----------------------------- -- In_Instance_Not_Visible -- ----------------------------- function In_Instance_Not_Visible return Boolean is S : Entity_Id; begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop if Ekind (S) in E_Function | E_Procedure and then Is_Generic_Instance (S) then return True; elsif Ekind (S) = E_Package and then (In_Package_Body (S) or else In_Private_Part (S)) and then Is_Generic_Instance (S) then return True; end if; S := Scope (S); end loop; return False; end In_Instance_Not_Visible; ------------------------------ -- In_Instance_Visible_Part -- ------------------------------ function In_Instance_Visible_Part (Id : Entity_Id := Current_Scope) return Boolean is Inst : Entity_Id; begin Inst := Id; while Present (Inst) and then Inst /= Standard_Standard loop if Ekind (Inst) = E_Package and then Is_Generic_Instance (Inst) and then not In_Package_Body (Inst) and then not In_Private_Part (Inst) then return True; end if; Inst := Scope (Inst); end loop; return False; end In_Instance_Visible_Part; --------------------- -- In_Package_Body -- --------------------- function In_Package_Body return Boolean is S : Entity_Id; begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop if Ekind (S) = E_Package and then In_Package_Body (S) then return True; else S := Scope (S); end if; end loop; return False; end In_Package_Body; -------------------------- -- In_Pragma_Expression -- -------------------------- function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is P : Node_Id; begin P := Parent (N); loop if No (P) then return False; elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then return True; else P := Parent (P); end if; end loop; end In_Pragma_Expression; --------------------------- -- In_Pre_Post_Condition -- --------------------------- function In_Pre_Post_Condition (N : Node_Id) return Boolean is Par : Node_Id; Prag : Node_Id := Empty; Prag_Id : Pragma_Id; begin -- Climb the parent chain looking for an enclosing pragma Par := N; while Present (Par) loop if Nkind (Par) = N_Pragma then Prag := Par; exit; -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then exit; end if; Par := Parent (Par); end loop; if Present (Prag) then Prag_Id := Get_Pragma_Id (Prag); return Prag_Id = Pragma_Post or else Prag_Id = Pragma_Post_Class or else Prag_Id = Pragma_Postcondition or else Prag_Id = Pragma_Pre or else Prag_Id = Pragma_Pre_Class or else Prag_Id = Pragma_Precondition; -- Otherwise the node is not enclosed by a pre/postcondition pragma else return False; end if; end In_Pre_Post_Condition; ------------------------------ -- In_Quantified_Expression -- ------------------------------ function In_Quantified_Expression (N : Node_Id) return Boolean is P : Node_Id; begin P := Parent (N); loop if No (P) then return False; elsif Nkind (P) = N_Quantified_Expression then return True; else P := Parent (P); end if; end loop; end In_Quantified_Expression; ------------------------------------- -- In_Reverse_Storage_Order_Object -- ------------------------------------- function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is Pref : Node_Id; Btyp : Entity_Id := Empty; begin -- Climb up indexed components Pref := N; loop case Nkind (Pref) is when N_Selected_Component => Pref := Prefix (Pref); exit; when N_Indexed_Component => Pref := Prefix (Pref); when others => Pref := Empty; exit; end case; end loop; if Present (Pref) then Btyp := Base_Type (Etype (Pref)); end if; return Present (Btyp) and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) and then Reverse_Storage_Order (Btyp); end In_Reverse_Storage_Order_Object; ------------------------------ -- In_Same_Declarative_Part -- ------------------------------ function In_Same_Declarative_Part (Context : Node_Id; N : Node_Id) return Boolean is Cont : Node_Id := Context; Nod : Node_Id; begin if Nkind (Cont) = N_Compilation_Unit_Aux then Cont := Parent (Cont); end if; Nod := Parent (N); while Present (Nod) loop if Nod = Cont then return True; elsif Nkind (Nod) in N_Accept_Statement | N_Block_Statement | N_Compilation_Unit | N_Entry_Body | N_Package_Body | N_Package_Declaration | N_Protected_Body | N_Subprogram_Body | N_Task_Body then return False; elsif Nkind (Nod) = N_Subunit then Nod := Corresponding_Stub (Nod); else Nod := Parent (Nod); end if; end loop; return False; end In_Same_Declarative_Part; -------------------------------------- -- In_Subprogram_Or_Concurrent_Unit -- -------------------------------------- function In_Subprogram_Or_Concurrent_Unit return Boolean is E : Entity_Id; K : Entity_Kind; begin -- Use scope chain to check successively outer scopes E := Current_Scope; loop K := Ekind (E); if K in Subprogram_Kind or else K in Concurrent_Kind or else K in Generic_Subprogram_Kind then return True; elsif E = Standard_Standard then return False; end if; E := Scope (E); end loop; end In_Subprogram_Or_Concurrent_Unit; ---------------- -- In_Subtree -- ---------------- function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is Curr : Node_Id; begin Curr := N; while Present (Curr) loop if Curr = Root then return True; end if; Curr := Parent (Curr); end loop; return False; end In_Subtree; ---------------- -- In_Subtree -- ---------------- function In_Subtree (N : Node_Id; Root1 : Node_Id; Root2 : Node_Id) return Boolean is Curr : Node_Id; begin Curr := N; while Present (Curr) loop if Curr = Root1 or else Curr = Root2 then return True; end if; Curr := Parent (Curr); end loop; return False; end In_Subtree; --------------------- -- In_Return_Value -- --------------------- function In_Return_Value (Expr : Node_Id) return Boolean is Par : Node_Id; Prev_Par : Node_Id; Pre : Node_Id; In_Function_Call : Boolean := False; begin -- Move through parent nodes to determine if Expr contributes to the -- return value of the current subprogram. Par := Expr; Prev_Par := Empty; while Present (Par) loop case Nkind (Par) is -- Ignore ranges and they don't contribute to the result when N_Range => return False; -- An object declaration whose parent is an extended return -- statement is a return object. when N_Object_Declaration => if Present (Parent (Par)) and then Nkind (Parent (Par)) = N_Extended_Return_Statement then return True; end if; -- We hit a simple return statement, so we know we are in one when N_Simple_Return_Statement => return True; -- Only include one nexting level of function calls when N_Function_Call => if not In_Function_Call then In_Function_Call := True; else return False; end if; -- Check if we are on the right-hand side of an assignment -- statement to a return object. -- This is not specified in the RM ??? when N_Assignment_Statement => if Prev_Par = Name (Par) then return False; end if; Pre := Name (Par); while Present (Pre) loop if Is_Entity_Name (Pre) and then Is_Return_Object (Entity (Pre)) then return True; end if; exit when Nkind (Pre) not in N_Selected_Component | N_Indexed_Component | N_Slice; Pre := Prefix (Pre); end loop; -- Otherwise, we hit a master which was not relevant when others => if Is_Master (Par) then return False; end if; end case; -- Iterate up to the next parent, keeping track of the previous one Prev_Par := Par; Par := Parent (Par); end loop; return False; end In_Return_Value; --------------------- -- In_Visible_Part -- --------------------- function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is begin return Is_Package_Or_Generic_Package (Scope_Id) and then In_Open_Scopes (Scope_Id) and then not In_Package_Body (Scope_Id) and then not In_Private_Part (Scope_Id); end In_Visible_Part; ----------------------------- -- In_While_Loop_Condition -- ----------------------------- function In_While_Loop_Condition (N : Node_Id) return Boolean is Prev : Node_Id := N; P : Node_Id := Parent (N); -- P and Prev will be used for traversing the AST, while maintaining an -- invariant that P = Parent (Prev). begin loop if No (P) then return False; elsif Nkind (P) = N_Iteration_Scheme and then Prev = Condition (P) then return True; else Prev := P; P := Parent (P); end if; end loop; end In_While_Loop_Condition; -------------------------------- -- Incomplete_Or_Partial_View -- -------------------------------- function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is function Inspect_Decls (Decls : List_Id; Taft : Boolean := False) return Entity_Id; -- Check whether a declarative region contains the incomplete or partial -- view of Id. ------------------- -- Inspect_Decls -- ------------------- function Inspect_Decls (Decls : List_Id; Taft : Boolean := False) return Entity_Id is Decl : Node_Id; Match : Node_Id; begin Decl := First (Decls); while Present (Decl) loop Match := Empty; -- The partial view of a Taft-amendment type is an incomplete -- type. if Taft then if Nkind (Decl) = N_Incomplete_Type_Declaration then Match := Defining_Identifier (Decl); end if; -- Otherwise look for a private type whose full view matches the -- input type. Note that this checks full_type_declaration nodes -- to account for derivations from a private type where the type -- declaration hold the partial view and the full view is an -- itype. elsif Nkind (Decl) in N_Full_Type_Declaration | N_Private_Extension_Declaration | N_Private_Type_Declaration then Match := Defining_Identifier (Decl); end if; -- Guard against unanalyzed entities if Present (Match) and then Is_Type (Match) and then Present (Full_View (Match)) and then Full_View (Match) = Id then return Match; end if; Next (Decl); end loop; return Empty; end Inspect_Decls; -- Local variables Prev : Entity_Id; -- Start of processing for Incomplete_Or_Partial_View begin -- Deferred constant or incomplete type case Prev := Current_Entity_In_Scope (Id); if Present (Prev) and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant) and then Present (Full_View (Prev)) and then Full_View (Prev) = Id then return Prev; end if; -- Private or Taft amendment type case declare Pkg : constant Entity_Id := Scope (Id); Pkg_Decl : Node_Id := Pkg; begin if Present (Pkg) and then Is_Package_Or_Generic_Package (Pkg) then while Nkind (Pkg_Decl) /= N_Package_Specification loop Pkg_Decl := Parent (Pkg_Decl); end loop; -- It is knows that Typ has a private view, look for it in the -- visible declarations of the enclosing scope. A special case -- of this is when the two views have been exchanged - the full -- appears earlier than the private. if Has_Private_Declaration (Id) then Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); -- Exchanged view case, look in the private declarations if No (Prev) then Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); end if; return Prev; -- Otherwise if this is the package body, then Typ is a potential -- Taft amendment type. The incomplete view should be located in -- the private declarations of the enclosing scope. elsif In_Package_Body (Pkg) then return Inspect_Decls (Private_Declarations (Pkg_Decl), True); end if; end if; end; -- The type has no incomplete or private view return Empty; end Incomplete_Or_Partial_View; --------------------------------------- -- Incomplete_View_From_Limited_With -- --------------------------------------- function Incomplete_View_From_Limited_With (Typ : Entity_Id) return Entity_Id is begin -- It might make sense to make this an attribute in Einfo, and set it -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on -- slots for new attributes, and it seems a bit simpler to just search -- the Limited_View (if it exists) for an incomplete type whose -- Non_Limited_View is Typ. if Ekind (Scope (Typ)) = E_Package and then Present (Limited_View (Scope (Typ))) then declare Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ))); begin while Present (Ent) loop if Is_Incomplete_Type (Ent) and then Non_Limited_View (Ent) = Typ then return Ent; end if; Next_Entity (Ent); end loop; end; end if; return Typ; end Incomplete_View_From_Limited_With; ---------------------------------- -- Indexed_Component_Bit_Offset -- ---------------------------------- function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is Exp : constant Node_Id := First (Expressions (N)); Typ : constant Entity_Id := Etype (Prefix (N)); Off : constant Uint := Component_Size (Typ); Ind : Node_Id; begin -- Return early if the component size is not known or variable if Off = No_Uint or else Off < Uint_0 then return No_Uint; end if; -- Deal with the degenerate case of an empty component if Off = Uint_0 then return Off; end if; -- Check that both the index value and the low bound are known if not Compile_Time_Known_Value (Exp) then return No_Uint; end if; Ind := First_Index (Typ); if No (Ind) then return No_Uint; end if; if Nkind (Ind) = N_Subtype_Indication then Ind := Constraint (Ind); if Nkind (Ind) = N_Range_Constraint then Ind := Range_Expression (Ind); end if; end if; if Nkind (Ind) /= N_Range or else not Compile_Time_Known_Value (Low_Bound (Ind)) then return No_Uint; end if; -- Return the scaled offset return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind)))); end Indexed_Component_Bit_Offset; ----------------------------- -- Inherit_Predicate_Flags -- ----------------------------- procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is begin if Present (Predicate_Function (Subt)) then return; end if; Set_Has_Predicates (Subt, Has_Predicates (Par)); Set_Has_Static_Predicate_Aspect (Subt, Has_Static_Predicate_Aspect (Par)); Set_Has_Dynamic_Predicate_Aspect (Subt, Has_Dynamic_Predicate_Aspect (Par)); -- A named subtype does not inherit the predicate function of its -- parent but an itype declared for a loop index needs the discrete -- predicate information of its parent to execute the loop properly. -- A non-discrete type may has a static predicate (for example True) -- but has no static_discrete_predicate. if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then Set_Static_Discrete_Predicate (Subt, Static_Discrete_Predicate (Par)); end if; end if; end Inherit_Predicate_Flags; ---------------------------- -- Inherit_Rep_Item_Chain -- ---------------------------- procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is Item : Node_Id; Next_Item : Node_Id; begin -- There are several inheritance scenarios to consider depending on -- whether both types have rep item chains and whether the destination -- type already inherits part of the source type's rep item chain. -- 1) The source type lacks a rep item chain -- From_Typ ---> Empty -- -- Typ --------> Item (or Empty) -- In this case inheritance cannot take place because there are no items -- to inherit. -- 2) The destination type lacks a rep item chain -- From_Typ ---> Item ---> ... -- -- Typ --------> Empty -- Inheritance takes place by setting the First_Rep_Item of the -- destination type to the First_Rep_Item of the source type. -- From_Typ ---> Item ---> ... -- ^ -- Typ -----------+ -- 3.1) Both source and destination types have at least one rep item. -- The destination type does NOT inherit a rep item from the source -- type. -- From_Typ ---> Item ---> Item -- -- Typ --------> Item ---> Item -- Inheritance takes place by setting the Next_Rep_Item of the last item -- of the destination type to the First_Rep_Item of the source type. -- From_Typ -------------------> Item ---> Item -- ^ -- Typ --------> Item ---> Item --+ -- 3.2) Both source and destination types have at least one rep item. -- The destination type DOES inherit part of the rep item chain of the -- source type. -- From_Typ ---> Item ---> Item ---> Item -- ^ -- Typ --------> Item ------+ -- This rare case arises when the full view of a private extension must -- inherit the rep item chain from the full view of its parent type and -- the full view of the parent type contains extra rep items. Currently -- only invariants may lead to such form of inheritance. -- type From_Typ is tagged private -- with Type_Invariant'Class => Item_2; -- type Typ is new From_Typ with private -- with Type_Invariant => Item_4; -- At this point the rep item chains contain the following items -- From_Typ -----------> Item_2 ---> Item_3 -- ^ -- Typ --------> Item_4 --+ -- The full views of both types may introduce extra invariants -- type From_Typ is tagged null record -- with Type_Invariant => Item_1; -- type Typ is new From_Typ with null record; -- The full view of Typ would have to inherit any new rep items added to -- the full view of From_Typ. -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3 -- ^ -- Typ --------> Item_4 --+ -- To achieve this form of inheritance, the destination type must first -- sever the link between its own rep chain and that of the source type, -- then inheritance 3.1 takes place. -- Case 1: The source type lacks a rep item chain if No (First_Rep_Item (From_Typ)) then return; -- Case 2: The destination type lacks a rep item chain elsif No (First_Rep_Item (Typ)) then Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); -- Case 3: Both the source and destination types have at least one rep -- item. Traverse the rep item chain of the destination type to find the -- last rep item. else Item := Empty; Next_Item := First_Rep_Item (Typ); while Present (Next_Item) loop -- Detect a link between the destination type's rep chain and that -- of the source type. There are two possibilities: -- Variant 1 -- Next_Item -- V -- From_Typ ---> Item_1 ---> -- ^ -- Typ -----------+ -- -- Item is Empty -- Variant 2 -- Next_Item -- V -- From_Typ ---> Item_1 ---> Item_2 ---> -- ^ -- Typ --------> Item_3 ------+ -- ^ -- Item if Present_In_Rep_Item (From_Typ, Next_Item) then exit; end if; Item := Next_Item; Next_Item := Next_Rep_Item (Next_Item); end loop; -- Inherit the source type's rep item chain if Present (Item) then Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ)); else Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ)); end if; end if; end Inherit_Rep_Item_Chain; ------------------------------------ -- Inherits_From_Tagged_Full_View -- ------------------------------------ function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is begin return Is_Private_Type (Typ) and then Present (Full_View (Typ)) and then Is_Private_Type (Full_View (Typ)) and then not Is_Tagged_Type (Full_View (Typ)) and then Present (Underlying_Type (Full_View (Typ))) and then Is_Tagged_Type (Underlying_Type (Full_View (Typ))); end Inherits_From_Tagged_Full_View; --------------------------------- -- Insert_Explicit_Dereference -- --------------------------------- procedure Insert_Explicit_Dereference (N : Node_Id) is New_Prefix : constant Node_Id := Relocate_Node (N); Ent : Entity_Id := Empty; Pref : Node_Id := Empty; I : Interp_Index; It : Interp; T : Entity_Id; begin Save_Interps (N, New_Prefix); Rewrite (N, Make_Explicit_Dereference (Sloc (Parent (N)), Prefix => New_Prefix)); Set_Etype (N, Designated_Type (Etype (New_Prefix))); if Is_Overloaded (New_Prefix) then -- The dereference is also overloaded, and its interpretations are -- the designated types of the interpretations of the original node. Set_Etype (N, Any_Type); Get_First_Interp (New_Prefix, I, It); while Present (It.Nam) loop T := It.Typ; if Is_Access_Type (T) then Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); end if; Get_Next_Interp (I, It); end loop; End_Interp_List; else -- Prefix is unambiguous: mark the original prefix (which might -- Come_From_Source) as a reference, since the new (relocated) one -- won't be taken into account. if Is_Entity_Name (New_Prefix) then Ent := Entity (New_Prefix); Pref := New_Prefix; -- For a retrieval of a subcomponent of some composite object, -- retrieve the ultimate entity if there is one. elsif Nkind (New_Prefix) in N_Selected_Component | N_Indexed_Component then Pref := Prefix (New_Prefix); while Present (Pref) and then Nkind (Pref) in N_Selected_Component | N_Indexed_Component loop Pref := Prefix (Pref); end loop; if Present (Pref) and then Is_Entity_Name (Pref) then Ent := Entity (Pref); end if; end if; -- Place the reference on the entity node if Present (Ent) then Generate_Reference (Ent, Pref); end if; end if; end Insert_Explicit_Dereference; ------------------------------------------ -- Inspect_Deferred_Constant_Completion -- ------------------------------------------ procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is Decl : Node_Id; begin Decl := First (Decls); while Present (Decl) loop -- Deferred constant signature if Nkind (Decl) = N_Object_Declaration and then Constant_Present (Decl) and then No (Expression (Decl)) -- No need to check internally generated constants and then Comes_From_Source (Decl) -- The constant is not completed. A full object declaration or a -- pragma Import complete a deferred constant. and then not Has_Completion (Defining_Identifier (Decl)) then Error_Msg_N ("constant declaration requires initialization expression", Defining_Identifier (Decl)); end if; Next (Decl); end loop; end Inspect_Deferred_Constant_Completion; ------------------------------- -- Install_Elaboration_Model -- ------------------------------- procedure Install_Elaboration_Model (Unit_Id : Entity_Id) is function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id; -- Try to find pragma Elaboration_Checks in arbitrary list L. Return -- Empty if there is no such pragma. ------------------------------------ -- Find_Elaboration_Checks_Pragma -- ------------------------------------ function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id is Item : Node_Id; begin Item := First (L); while Present (Item) loop if Nkind (Item) = N_Pragma and then Pragma_Name (Item) = Name_Elaboration_Checks then return Item; end if; Next (Item); end loop; return Empty; end Find_Elaboration_Checks_Pragma; -- Local variables Args : List_Id; Model : Node_Id; Prag : Node_Id; Unit : Node_Id; -- Start of processing for Install_Elaboration_Model begin -- Nothing to do when the unit does not exist if No (Unit_Id) then return; end if; Unit := Parent (Unit_Declaration_Node (Unit_Id)); -- Nothing to do when the unit is not a library unit if Nkind (Unit) /= N_Compilation_Unit then return; end if; Prag := Find_Elaboration_Checks_Pragma (Context_Items (Unit)); -- The compilation unit is subject to pragma Elaboration_Checks. Set the -- elaboration model as specified by the pragma. if Present (Prag) then Args := Pragma_Argument_Associations (Prag); -- Guard against an illegal pragma. The sole argument must be an -- identifier which specifies either Dynamic or Static model. if Present (Args) then Model := Get_Pragma_Arg (First (Args)); if Nkind (Model) = N_Identifier then Dynamic_Elaboration_Checks := Chars (Model) = Name_Dynamic; end if; end if; end if; end Install_Elaboration_Model; ----------------------------- -- Install_Generic_Formals -- ----------------------------- procedure Install_Generic_Formals (Subp_Id : Entity_Id) is E : Entity_Id; begin pragma Assert (Is_Generic_Subprogram (Subp_Id)); E := First_Entity (Subp_Id); while Present (E) loop Install_Entity (E); Next_Entity (E); end loop; end Install_Generic_Formals; ------------------------ -- Install_SPARK_Mode -- ------------------------ procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id) is begin SPARK_Mode := Mode; SPARK_Mode_Pragma := Prag; end Install_SPARK_Mode; -------------------------- -- Invalid_Scalar_Value -- -------------------------- function Invalid_Scalar_Value (Loc : Source_Ptr; Scal_Typ : Scalar_Id) return Node_Id is function Invalid_Binder_Value return Node_Id; -- Return a reference to the corresponding invalid value for type -- Scal_Typ as defined in unit System.Scalar_Values. function Invalid_Float_Value return Node_Id; -- Return the invalid value of float type Scal_Typ function Invalid_Integer_Value return Node_Id; -- Return the invalid value of integer type Scal_Typ procedure Set_Invalid_Binder_Values; -- Set the contents of collection Invalid_Binder_Values -------------------------- -- Invalid_Binder_Value -- -------------------------- function Invalid_Binder_Value return Node_Id is Val_Id : Entity_Id; begin -- Initialize the collection of invalid binder values the first time -- around. Set_Invalid_Binder_Values; -- Obtain the corresponding variable from System.Scalar_Values which -- holds the invalid value for this type. Val_Id := Invalid_Binder_Values (Scal_Typ); pragma Assert (Present (Val_Id)); return New_Occurrence_Of (Val_Id, Loc); end Invalid_Binder_Value; ------------------------- -- Invalid_Float_Value -- ------------------------- function Invalid_Float_Value return Node_Id is Value : constant Ureal := Invalid_Floats (Scal_Typ); begin -- Pragma Invalid_Scalars did not specify an invalid value for this -- type. Fall back to the value provided by the binder. if Value = No_Ureal then return Invalid_Binder_Value; else return Make_Real_Literal (Loc, Realval => Value); end if; end Invalid_Float_Value; --------------------------- -- Invalid_Integer_Value -- --------------------------- function Invalid_Integer_Value return Node_Id is Value : constant Uint := Invalid_Integers (Scal_Typ); begin -- Pragma Invalid_Scalars did not specify an invalid value for this -- type. Fall back to the value provided by the binder. if Value = No_Uint then return Invalid_Binder_Value; else return Make_Integer_Literal (Loc, Intval => Value); end if; end Invalid_Integer_Value; ------------------------------- -- Set_Invalid_Binder_Values -- ------------------------------- procedure Set_Invalid_Binder_Values is begin if not Invalid_Binder_Values_Set then Invalid_Binder_Values_Set := True; -- Initialize the contents of the collection once since RTE calls -- are not cheap. Invalid_Binder_Values := (Name_Short_Float => RTE (RE_IS_Isf), Name_Float => RTE (RE_IS_Ifl), Name_Long_Float => RTE (RE_IS_Ilf), Name_Long_Long_Float => RTE (RE_IS_Ill), Name_Signed_8 => RTE (RE_IS_Is1), Name_Signed_16 => RTE (RE_IS_Is2), Name_Signed_32 => RTE (RE_IS_Is4), Name_Signed_64 => RTE (RE_IS_Is8), Name_Signed_128 => Empty, Name_Unsigned_8 => RTE (RE_IS_Iu1), Name_Unsigned_16 => RTE (RE_IS_Iu2), Name_Unsigned_32 => RTE (RE_IS_Iu4), Name_Unsigned_64 => RTE (RE_IS_Iu8), Name_Unsigned_128 => Empty); if System_Max_Integer_Size < 128 then Invalid_Binder_Values (Name_Signed_128) := RTE (RE_IS_Is8); Invalid_Binder_Values (Name_Unsigned_128) := RTE (RE_IS_Iu8); else Invalid_Binder_Values (Name_Signed_128) := RTE (RE_IS_Is16); Invalid_Binder_Values (Name_Unsigned_128) := RTE (RE_IS_Iu16); end if; end if; end Set_Invalid_Binder_Values; -- Start of processing for Invalid_Scalar_Value begin if Scal_Typ in Float_Scalar_Id then return Invalid_Float_Value; else pragma Assert (Scal_Typ in Integer_Scalar_Id); return Invalid_Integer_Value; 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 -- ------------------------ function Is_Access_Variable (E : Entity_Id) return Boolean is begin return Is_Access_Object_Type (E) and then not Is_Access_Constant (E); end Is_Access_Variable; ----------------------------- -- Is_Actual_Out_Parameter -- ----------------------------- function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is Formal : Entity_Id; Call : Node_Id; begin Find_Actual (N, Formal, Call); return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; end Is_Actual_Out_Parameter; -------------------------------- -- Is_Actual_In_Out_Parameter -- -------------------------------- function Is_Actual_In_Out_Parameter (N : Node_Id) return Boolean is Formal : Entity_Id; Call : Node_Id; begin Find_Actual (N, Formal, Call); return Present (Formal) and then Ekind (Formal) = E_In_Out_Parameter; end Is_Actual_In_Out_Parameter; ------------------------- -- Is_Actual_Parameter -- ------------------------- function Is_Actual_Parameter (N : Node_Id) return Boolean is PK : constant Node_Kind := Nkind (Parent (N)); begin case PK is when N_Parameter_Association => return N = Explicit_Actual_Parameter (Parent (N)); when N_Subprogram_Call => return Is_List_Member (N) and then List_Containing (N) = Parameter_Associations (Parent (N)); when others => return False; end case; end Is_Actual_Parameter; -------------------------------- -- Is_Actual_Tagged_Parameter -- -------------------------------- function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is Formal : Entity_Id; Call : Node_Id; begin Find_Actual (N, Formal, Call); return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); end Is_Actual_Tagged_Parameter; --------------------- -- Is_Aliased_View -- --------------------- function Is_Aliased_View (Obj : Node_Id) return Boolean is E : Entity_Id; begin if Is_Entity_Name (Obj) then E := Entity (Obj); return (Is_Object (E) and then (Is_Aliased (E) or else (Present (Renamed_Object (E)) and then Is_Aliased_View (Renamed_Object (E))))) or else ((Is_Formal (E) or else Is_Formal_Object (E)) and then Is_Tagged_Type (Etype (E))) or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) -- Current instance of type, either directly or as rewritten -- reference to the current object. or else (Is_Entity_Name (Original_Node (Obj)) and then Present (Entity (Original_Node (Obj))) and then Is_Type (Entity (Original_Node (Obj)))) or else (Is_Type (E) and then E = Current_Scope) or else (Is_Incomplete_Or_Private_Type (E) and then Full_View (E) = Current_Scope) -- Ada 2012 AI05-0053: the return object of an extended return -- statement is aliased if its type is immutably limited. or else (Is_Return_Object (E) and then Is_Limited_View (Etype (E))); elsif Nkind (Obj) = N_Selected_Component then return Is_Aliased (Entity (Selector_Name (Obj))); elsif Nkind (Obj) = N_Indexed_Component then return Has_Aliased_Components (Etype (Prefix (Obj))) or else (Is_Access_Type (Etype (Prefix (Obj))) and then Has_Aliased_Components (Designated_Type (Etype (Prefix (Obj))))); elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then return Is_Tagged_Type (Etype (Obj)) and then Is_Aliased_View (Expression (Obj)); -- Ada 202x AI12-0228 elsif Nkind (Obj) = N_Qualified_Expression and then Ada_Version >= Ada_2012 then return Is_Aliased_View (Expression (Obj)); elsif Nkind (Obj) = N_Explicit_Dereference then return Nkind (Original_Node (Obj)) /= N_Function_Call; else return False; end if; end Is_Aliased_View; ------------------------- -- Is_Ancestor_Package -- ------------------------- function Is_Ancestor_Package (E1 : Entity_Id; E2 : Entity_Id) return Boolean is Par : Entity_Id; begin Par := E2; while Present (Par) and then Par /= Standard_Standard loop if Par = E1 then return True; end if; Par := Scope (Par); end loop; return False; end Is_Ancestor_Package; ---------------------- -- Is_Atomic_Object -- ---------------------- function Is_Atomic_Object (N : Node_Id) return Boolean is function Prefix_Has_Atomic_Components (P : Node_Id) return Boolean; -- Determine whether prefix P has atomic components. This requires the -- presence of an Atomic_Components aspect/pragma. --------------------------------- -- Prefix_Has_Atomic_Components -- --------------------------------- function Prefix_Has_Atomic_Components (P : Node_Id) return Boolean is Typ : constant Entity_Id := Etype (P); begin if Is_Access_Type (Typ) then return Has_Atomic_Components (Designated_Type (Typ)); elsif Has_Atomic_Components (Typ) then return True; elsif Is_Entity_Name (P) and then Has_Atomic_Components (Entity (P)) then return True; else return False; end if; end Prefix_Has_Atomic_Components; -- Start of processing for Is_Atomic_Object begin if Is_Entity_Name (N) then return Is_Atomic_Object_Entity (Entity (N)); elsif Is_Atomic (Etype (N)) then return True; elsif Nkind (N) = N_Indexed_Component then return Prefix_Has_Atomic_Components (Prefix (N)); elsif Nkind (N) = N_Selected_Component then return Is_Atomic (Entity (Selector_Name (N))); else return False; end if; end Is_Atomic_Object; ----------------------------- -- Is_Atomic_Object_Entity -- ----------------------------- function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean is begin return Is_Object (Id) and then (Is_Atomic (Id) or else Is_Atomic (Etype (Id))); end Is_Atomic_Object_Entity; ----------------------------- -- Is_Attribute_Loop_Entry -- ----------------------------- function Is_Attribute_Loop_Entry (N : Node_Id) return Boolean is begin return Nkind (N) = N_Attribute_Reference and then Attribute_Name (N) = Name_Loop_Entry; end Is_Attribute_Loop_Entry; ---------------------- -- Is_Attribute_Old -- ---------------------- function Is_Attribute_Old (N : Node_Id) return Boolean is begin return Nkind (N) = N_Attribute_Reference and then Attribute_Name (N) = Name_Old; end Is_Attribute_Old; ------------------------- -- Is_Attribute_Result -- ------------------------- function Is_Attribute_Result (N : Node_Id) return Boolean is begin return Nkind (N) = N_Attribute_Reference and then Attribute_Name (N) = Name_Result; end Is_Attribute_Result; ------------------------- -- Is_Attribute_Update -- ------------------------- function Is_Attribute_Update (N : Node_Id) return Boolean is begin return Nkind (N) = N_Attribute_Reference and then Attribute_Name (N) = Name_Update; end Is_Attribute_Update; ------------------------------------ -- Is_Body_Or_Package_Declaration -- ------------------------------------ function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is begin return Is_Body (N) or else Nkind (N) = N_Package_Declaration; end Is_Body_Or_Package_Declaration; ----------------------- -- Is_Bounded_String -- ----------------------- function Is_Bounded_String (T : Entity_Id) return Boolean is Under : constant Entity_Id := Underlying_Type (Root_Type (T)); begin -- Check whether T is ultimately derived from Ada.Strings.Superbounded. -- Super_String, or one of the [Wide_]Wide_ versions. This will -- be True for all the Bounded_String types in instances of the -- Generic_Bounded_Length generics, and for types derived from those. return Present (Under) and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else Is_RTE (Root_Type (Under), RO_WI_Super_String) or else Is_RTE (Root_Type (Under), RO_WW_Super_String)); end Is_Bounded_String; ------------------------------- -- Is_By_Protected_Procedure -- ------------------------------- function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean is begin return Ekind (Id) = E_Procedure and then Present (Get_Rep_Pragma (Id, Name_Implemented)) and then Implementation_Kind (Id) = Name_By_Protected_Procedure; end Is_By_Protected_Procedure; --------------------- -- Is_CCT_Instance -- --------------------- function Is_CCT_Instance (Ref_Id : Entity_Id; Context_Id : Entity_Id) return Boolean is begin pragma Assert (Ekind (Ref_Id) in E_Protected_Type | E_Task_Type); if Is_Single_Task_Object (Context_Id) then return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id); else pragma Assert (Ekind (Context_Id) in E_Entry | E_Entry_Family | E_Function | E_Package | E_Procedure | E_Protected_Type | E_Task_Type or else Is_Record_Type (Context_Id)); return Scope_Within_Or_Same (Context_Id, Ref_Id); end if; end Is_CCT_Instance; ------------------------- -- Is_Child_Or_Sibling -- ------------------------- function Is_Child_Or_Sibling (Pack_1 : Entity_Id; Pack_2 : Entity_Id) return Boolean is function Distance_From_Standard (Pack : Entity_Id) return Nat; -- Given an arbitrary package, return the number of "climbs" necessary -- to reach scope Standard_Standard. procedure Equalize_Depths (Pack : in out Entity_Id; Depth : in out Nat; Depth_To_Reach : Nat); -- Given an arbitrary package, its depth and a target depth to reach, -- climb the scope chain until the said depth is reached. The pointer -- to the package and its depth a modified during the climb. ---------------------------- -- Distance_From_Standard -- ---------------------------- function Distance_From_Standard (Pack : Entity_Id) return Nat is Dist : Nat; Scop : Entity_Id; begin Dist := 0; Scop := Pack; while Present (Scop) and then Scop /= Standard_Standard loop Dist := Dist + 1; Scop := Scope (Scop); end loop; return Dist; end Distance_From_Standard; --------------------- -- Equalize_Depths -- --------------------- procedure Equalize_Depths (Pack : in out Entity_Id; Depth : in out Nat; Depth_To_Reach : Nat) is begin -- The package must be at a greater or equal depth if Depth < Depth_To_Reach then raise Program_Error; end if; -- Climb the scope chain until the desired depth is reached while Present (Pack) and then Depth /= Depth_To_Reach loop Pack := Scope (Pack); Depth := Depth - 1; end loop; end Equalize_Depths; -- Local variables P_1 : Entity_Id := Pack_1; P_1_Child : Boolean := False; P_1_Depth : Nat := Distance_From_Standard (P_1); P_2 : Entity_Id := Pack_2; P_2_Child : Boolean := False; P_2_Depth : Nat := Distance_From_Standard (P_2); -- Start of processing for Is_Child_Or_Sibling begin pragma Assert (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); -- Both packages denote the same entity, therefore they cannot be -- children or siblings. if P_1 = P_2 then return False; -- One of the packages is at a deeper level than the other. Note that -- both may still come from different hierarchies. -- (root) P_2 -- / \ : -- X P_2 or X -- : : -- P_1 P_1 elsif P_1_Depth > P_2_Depth then Equalize_Depths (Pack => P_1, Depth => P_1_Depth, Depth_To_Reach => P_2_Depth); P_1_Child := True; -- (root) P_1 -- / \ : -- P_1 X or X -- : : -- P_2 P_2 elsif P_2_Depth > P_1_Depth then Equalize_Depths (Pack => P_2, Depth => P_2_Depth, Depth_To_Reach => P_1_Depth); P_2_Child := True; end if; -- At this stage the package pointers have been elevated to the same -- depth. If the related entities are the same, then one package is a -- potential child of the other: -- P_1 -- : -- X became P_1 P_2 or vice versa -- : -- P_2 if P_1 = P_2 then if P_1_Child then return Is_Child_Unit (Pack_1); else pragma Assert (P_2_Child); return Is_Child_Unit (Pack_2); end if; -- The packages may come from the same package chain or from entirely -- different hierarcies. To determine this, climb the scope stack until -- a common root is found. -- (root) (root 1) (root 2) -- / \ | | -- P_1 P_2 P_1 P_2 else while Present (P_1) and then Present (P_2) loop -- The two packages may be siblings if P_1 = P_2 then return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2); end if; P_1 := Scope (P_1); P_2 := Scope (P_2); end loop; end if; return False; end Is_Child_Or_Sibling; ------------------- -- Is_Confirming -- ------------------- function Is_Confirming (Aspect : Nonoverridable_Aspect_Id; Aspect_Spec_1, Aspect_Spec_2 : Node_Id) return Boolean is function Names_Match (Nm1, Nm2 : Node_Id) return Boolean; function Names_Match (Nm1, Nm2 : Node_Id) return Boolean is begin if Nkind (Nm1) /= Nkind (Nm2) then return False; end if; case Nkind (Nm1) is when N_Identifier => return Name_Equals (Chars (Nm1), Chars (Nm2)); when N_Expanded_Name => return Names_Match (Prefix (Nm1), Prefix (Nm2)) and then Names_Match (Selector_Name (Nm1), Selector_Name (Nm2)); when N_Empty => return True; -- needed for Aggregate aspect checking when others => -- e.g., 'Class attribute references if Is_Entity_Name (Nm1) and Is_Entity_Name (Nm2) then return Entity (Nm1) = Entity (Nm2); end if; raise Program_Error; end case; end Names_Match; begin -- allow users to disable "shall be confirming" check, at least for now if Relaxed_RM_Semantics then return True; end if; -- ??? Type conversion here (along with "when others =>" below) is a -- workaround for a bootstrapping problem related to casing on a -- static-predicate-bearing subtype. case Aspect_Id (Aspect) is -- name-valued aspects; compare text of names, not resolution. when Aspect_Default_Iterator | Aspect_Iterator_Element | Aspect_Constant_Indexing | Aspect_Variable_Indexing | Aspect_Implicit_Dereference => declare Item_1 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_1); Item_2 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_2); begin if (Nkind (Item_1) /= N_Attribute_Definition_Clause) or (Nkind (Item_2) /= N_Attribute_Definition_Clause) then pragma Assert (Serious_Errors_Detected > 0); return True; end if; return Names_Match (Expression (Item_1), Expression (Item_2)); end; -- one of a kind when Aspect_Aggregate => declare Empty_1, Add_Named_1, Add_Unnamed_1, New_Indexed_1, Assign_Indexed_1, Empty_2, Add_Named_2, Add_Unnamed_2, New_Indexed_2, Assign_Indexed_2 : Node_Id := Empty; begin Parse_Aspect_Aggregate (N => Expression (Aspect_Spec_1), Empty_Subp => Empty_1, Add_Named_Subp => Add_Named_1, Add_Unnamed_Subp => Add_Unnamed_1, New_Indexed_Subp => New_Indexed_1, Assign_Indexed_Subp => Assign_Indexed_1); Parse_Aspect_Aggregate (N => Expression (Aspect_Spec_2), Empty_Subp => Empty_2, Add_Named_Subp => Add_Named_2, Add_Unnamed_Subp => Add_Unnamed_2, New_Indexed_Subp => New_Indexed_2, Assign_Indexed_Subp => Assign_Indexed_2); return Names_Match (Empty_1, Empty_2) and then Names_Match (Add_Named_1, Add_Named_2) and then Names_Match (Add_Unnamed_1, Add_Unnamed_2) and then Names_Match (New_Indexed_1, New_Indexed_2) and then Names_Match (Assign_Indexed_1, Assign_Indexed_2); end; -- scalar-valued aspects; compare (static) values. when Aspect_Max_Entry_Queue_Length -- | Aspect_No_Controlled_Parts => -- This should be unreachable. No_Controlled_Parts is -- not yet supported at all in GNAT and Max_Entry_Queue_Length -- is supported only for protected entries, not for types. pragma Assert (Serious_Errors_Detected /= 0); return True; when others => raise Program_Error; end case; end Is_Confirming; ----------------------------- -- Is_Concurrent_Interface -- ----------------------------- function Is_Concurrent_Interface (T : Entity_Id) return Boolean is begin return Is_Interface (T) and then (Is_Protected_Interface (T) or else Is_Synchronized_Interface (T) or else Is_Task_Interface (T)); end Is_Concurrent_Interface; ----------------------- -- Is_Constant_Bound -- ----------------------- function Is_Constant_Bound (Exp : Node_Id) return Boolean is begin if Compile_Time_Known_Value (Exp) then return True; elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then return Is_Constant_Object (Entity (Exp)) or else Ekind (Entity (Exp)) = E_Enumeration_Literal; elsif Nkind (Exp) in N_Binary_Op then return Is_Constant_Bound (Left_Opnd (Exp)) and then Is_Constant_Bound (Right_Opnd (Exp)) and then Scope (Entity (Exp)) = Standard_Standard; else return False; end if; end Is_Constant_Bound; --------------------------- -- Is_Container_Element -- --------------------------- function Is_Container_Element (Exp : Node_Id) return Boolean is Loc : constant Source_Ptr := Sloc (Exp); Pref : constant Node_Id := Prefix (Exp); Call : Node_Id; -- Call to an indexing aspect Cont_Typ : Entity_Id; -- The type of the container being accessed Elem_Typ : Entity_Id; -- Its element type Indexing : Entity_Id; Is_Const : Boolean; -- Indicates that constant indexing is used, and the element is thus -- a constant. Ref_Typ : Entity_Id; -- The reference type returned by the indexing operation begin -- If C is a container, in a context that imposes the element type of -- that container, the indexing notation C (X) is rewritten as: -- Indexing (C, X).Discr.all -- where Indexing is one of the indexing aspects of the container. -- If the context does not require a reference, the construct can be -- rewritten as -- Element (C, X) -- First, verify that the construct has the proper form if not Expander_Active then return False; elsif Nkind (Pref) /= N_Selected_Component then return False; elsif Nkind (Prefix (Pref)) /= N_Function_Call then return False; else Call := Prefix (Pref); Ref_Typ := Etype (Call); end if; if not Has_Implicit_Dereference (Ref_Typ) or else No (First (Parameter_Associations (Call))) or else not Is_Entity_Name (Name (Call)) then return False; end if; -- Retrieve type of container object, and its iterator aspects Cont_Typ := Etype (First (Parameter_Associations (Call))); Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing); Is_Const := False; if No (Indexing) then -- Container should have at least one indexing operation return False; elsif Entity (Name (Call)) /= Entity (Indexing) then -- This may be a variable indexing operation Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing); if No (Indexing) or else Entity (Name (Call)) /= Entity (Indexing) then return False; end if; else Is_Const := True; end if; Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element); if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then return False; end if; -- Check that the expression is not the target of an assignment, in -- which case the rewriting is not possible. if not Is_Const then declare Par : Node_Id; begin Par := Exp; while Present (Par) loop if Nkind (Parent (Par)) = N_Assignment_Statement and then Par = Name (Parent (Par)) then return False; -- A renaming produces a reference, and the transformation -- does not apply. elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then return False; elsif Nkind (Parent (Par)) in N_Function_Call | N_Procedure_Call_Statement | N_Entry_Call_Statement then -- Check that the element is not part of an actual for an -- in-out parameter. declare F : Entity_Id; A : Node_Id; begin F := First_Formal (Entity (Name (Parent (Par)))); A := First (Parameter_Associations (Parent (Par))); while Present (F) loop if A = Par and then Ekind (F) /= E_In_Parameter then return False; end if; Next_Formal (F); Next (A); end loop; end; -- E_In_Parameter in a call: element is not modified. exit; end if; Par := Parent (Par); end loop; end; end if; -- The expression has the proper form and the context requires the -- element type. Retrieve the Element function of the container and -- rewrite the construct as a call to it. declare Op : Elmt_Id; begin Op := First_Elmt (Primitive_Operations (Cont_Typ)); while Present (Op) loop exit when Chars (Node (Op)) = Name_Element; Next_Elmt (Op); end loop; if No (Op) then return False; else Rewrite (Exp, Make_Function_Call (Loc, Name => New_Occurrence_Of (Node (Op), Loc), Parameter_Associations => Parameter_Associations (Call))); Analyze_And_Resolve (Exp, Entity (Elem_Typ)); return True; end if; end; end Is_Container_Element; ---------------------------- -- Is_Contract_Annotation -- ---------------------------- function Is_Contract_Annotation (Item : Node_Id) return Boolean is begin return Is_Package_Contract_Annotation (Item) or else Is_Subprogram_Contract_Annotation (Item); end Is_Contract_Annotation; -------------------------------------- -- Is_Controlling_Limited_Procedure -- -------------------------------------- function Is_Controlling_Limited_Procedure (Proc_Nam : Entity_Id) return Boolean is Param : Node_Id; Param_Typ : Entity_Id := Empty; begin if Ekind (Proc_Nam) = E_Procedure and then Present (Parameter_Specifications (Parent (Proc_Nam))) then Param := Parameter_Type (First (Parameter_Specifications (Parent (Proc_Nam)))); -- The formal may be an anonymous access type if Nkind (Param) = N_Access_Definition then Param_Typ := Entity (Subtype_Mark (Param)); else Param_Typ := Etype (Param); end if; -- In the case where an Itype was created for a dispatchin call, the -- procedure call has been rewritten. The actual may be an access to -- interface type in which case it is the designated type that is the -- controlling type. elsif Present (Associated_Node_For_Itype (Proc_Nam)) and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) and then Present (Parameter_Associations (Associated_Node_For_Itype (Proc_Nam))) then Param_Typ := Etype (First (Parameter_Associations (Associated_Node_For_Itype (Proc_Nam)))); if Ekind (Param_Typ) = E_Anonymous_Access_Type then Param_Typ := Directly_Designated_Type (Param_Typ); end if; end if; if Present (Param_Typ) then return Is_Interface (Param_Typ) and then Is_Limited_Record (Param_Typ); end if; return False; end Is_Controlling_Limited_Procedure; ----------------------------- -- Is_CPP_Constructor_Call -- ----------------------------- function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is begin return Nkind (N) = N_Function_Call and then Is_CPP_Class (Etype (Etype (N))) and then Is_Constructor (Entity (Name (N))) and then Is_Imported (Entity (Name (N))); end Is_CPP_Constructor_Call; ------------------------- -- Is_Current_Instance -- ------------------------- function Is_Current_Instance (N : Node_Id) return Boolean is Typ : constant Entity_Id := Entity (N); P : Node_Id; begin -- Simplest case: entity is a concurrent type and we are currently -- inside the body. This will eventually be expanded into a call to -- Self (for tasks) or _object (for protected objects). if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then return True; else -- Check whether the context is a (sub)type declaration for the -- type entity. P := Parent (N); while Present (P) loop if Nkind (P) in N_Full_Type_Declaration | N_Private_Type_Declaration | N_Subtype_Declaration and then Comes_From_Source (P) and then Defining_Entity (P) = Typ then return True; -- A subtype name may appear in an aspect specification for a -- Predicate_Failure aspect, for which we do not construct a -- wrapper procedure. The subtype will be replaced by the -- expression being tested when the corresponding predicate -- check is expanded. elsif Nkind (P) = N_Aspect_Specification and then Nkind (Parent (P)) = N_Subtype_Declaration then return True; elsif Nkind (P) = N_Pragma and then Get_Pragma_Id (P) = Pragma_Predicate_Failure then return True; end if; P := Parent (P); end loop; end if; -- In any other context this is not a current occurrence return False; end Is_Current_Instance; -------------------------------------------------- -- Is_Current_Instance_Reference_In_Type_Aspect -- -------------------------------------------------- function Is_Current_Instance_Reference_In_Type_Aspect (N : Node_Id) return Boolean is begin -- When a current_instance is referenced within an aspect_specification -- of a type or subtype, it will show up as a reference to the formal -- parameter of the aspect's associated subprogram rather than as a -- reference to the type or subtype itself (in fact, the original name -- is never even analyzed). We check for predicate, invariant, and -- Default_Initial_Condition subprograms (in theory there could be -- other cases added, in which case this function will need updating). if Is_Entity_Name (N) then return Present (Entity (N)) and then Ekind (Entity (N)) = E_In_Parameter and then Ekind (Scope (Entity (N))) in E_Function | E_Procedure and then (Is_Predicate_Function (Scope (Entity (N))) or else Is_Predicate_Function_M (Scope (Entity (N))) or else Is_Invariant_Procedure (Scope (Entity (N))) or else Is_Partial_Invariant_Procedure (Scope (Entity (N))) or else Is_DIC_Procedure (Scope (Entity (N)))); else case Nkind (N) is when N_Indexed_Component | N_Slice => return Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N)); when N_Selected_Component => return Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N)); when N_Type_Conversion => return Is_Current_Instance_Reference_In_Type_Aspect (Expression (N)); when N_Qualified_Expression => return Is_Current_Instance_Reference_In_Type_Aspect (Expression (N)); when others => return False; end case; end if; end Is_Current_Instance_Reference_In_Type_Aspect; -------------------- -- Is_Declaration -- -------------------- function Is_Declaration (N : Node_Id; Body_OK : Boolean := True; Concurrent_OK : Boolean := True; Formal_OK : Boolean := True; Generic_OK : Boolean := True; Instantiation_OK : Boolean := True; Renaming_OK : Boolean := True; Stub_OK : Boolean := True; Subprogram_OK : Boolean := True; Type_OK : Boolean := True) return Boolean is begin case Nkind (N) is -- Body declarations when N_Proper_Body => return Body_OK; -- Concurrent type declarations when N_Protected_Type_Declaration | N_Single_Protected_Declaration | N_Single_Task_Declaration | N_Task_Type_Declaration => return Concurrent_OK or Type_OK; -- Formal declarations when N_Formal_Abstract_Subprogram_Declaration | N_Formal_Concrete_Subprogram_Declaration | N_Formal_Object_Declaration | N_Formal_Package_Declaration | N_Formal_Type_Declaration => return Formal_OK; -- Generic declarations when N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration => return Generic_OK; -- Generic instantiations when N_Function_Instantiation | N_Package_Instantiation | N_Procedure_Instantiation => return Instantiation_OK; -- Generic renaming declarations when N_Generic_Renaming_Declaration => return Generic_OK or Renaming_OK; -- Renaming declarations when N_Exception_Renaming_Declaration | N_Object_Renaming_Declaration | N_Package_Renaming_Declaration | N_Subprogram_Renaming_Declaration => return Renaming_OK; -- Stub declarations when N_Body_Stub => return Stub_OK; -- Subprogram declarations when N_Abstract_Subprogram_Declaration | N_Entry_Declaration | N_Expression_Function | N_Subprogram_Declaration => return Subprogram_OK; -- Type declarations when N_Full_Type_Declaration | N_Incomplete_Type_Declaration | N_Private_Extension_Declaration | N_Private_Type_Declaration | N_Subtype_Declaration => return Type_OK; -- Miscellaneous when N_Component_Declaration | N_Exception_Declaration | N_Implicit_Label_Declaration | N_Number_Declaration | N_Object_Declaration | N_Package_Declaration => return True; when others => return False; end case; end Is_Declaration; -------------------------------- -- Is_Declared_Within_Variant -- -------------------------------- function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is Comp_Decl : constant Node_Id := Parent (Comp); Comp_List : constant Node_Id := Parent (Comp_Decl); begin return Nkind (Parent (Comp_List)) = N_Variant; end Is_Declared_Within_Variant; ---------------------------------------------- -- Is_Dependent_Component_Of_Mutable_Object -- ---------------------------------------------- function Is_Dependent_Component_Of_Mutable_Object (Object : Node_Id) return Boolean is P : Node_Id; Prefix_Type : Entity_Id; P_Aliased : Boolean := False; Comp : Entity_Id; Deref : Node_Id := Object; -- Dereference node, in something like X.all.Y(2) -- Start of processing for Is_Dependent_Component_Of_Mutable_Object begin -- Find the dereference node if any while Nkind (Deref) in N_Indexed_Component | N_Selected_Component | N_Slice loop Deref := Prefix (Deref); end loop; Deref := Original_Node (Deref); -- If the prefix is a qualified expression of a variable, then function -- Is_Variable will return False for that because a qualified expression -- denotes a constant view, so we need to get the name being qualified -- so we can test below whether that's a variable (or a dereference). if Nkind (Deref) = N_Qualified_Expression then Deref := Expression (Deref); end if; -- Ada 2005: If we have a component or slice of a dereference, something -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable -- will return False, because it is indeed a constant view. But it might -- be a view of a variable object, so we want the following condition to -- be True in that case. if Is_Variable (Object) or else Is_Variable (Deref) or else (Ada_Version >= Ada_2005 and then (Nkind (Deref) = N_Explicit_Dereference or else (Present (Etype (Deref)) and then Is_Access_Type (Etype (Deref))))) then if Nkind (Object) = N_Selected_Component then -- If the selector is not a component, then we definitely return -- False (it could be a function selector in a prefix form call -- occurring in an iterator specification). if Ekind (Entity (Selector_Name (Object))) not in E_Component | E_Discriminant then return False; end if; -- Get the original node of the prefix in case it has been -- rewritten, which can occur, for example, in qualified -- expression cases. Also, a discriminant check on a selected -- component may be expanded into a dereference when removing -- side effects, and the subtype of the original node may be -- unconstrained. P := Original_Node (Prefix (Object)); Prefix_Type := Etype (P); -- If the prefix is a qualified expression, we want to look at its -- operand. if Nkind (P) = N_Qualified_Expression then P := Expression (P); Prefix_Type := Etype (P); end if; if Is_Entity_Name (P) then if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then Prefix_Type := Base_Type (Prefix_Type); end if; if Is_Aliased (Entity (P)) then P_Aliased := True; end if; -- For explicit dereferences we get the access prefix so we can -- treat this similarly to implicit dereferences and examine the -- kind of the access type and its designated subtype further -- below. elsif Nkind (P) = N_Explicit_Dereference then P := Prefix (P); Prefix_Type := Etype (P); else -- Check for prefix being an aliased component??? null; end if; -- A heap object is constrained by its initial value -- Ada 2005 (AI-363): Always assume the object could be mutable in -- the dereferenced case, since the access value might denote an -- unconstrained aliased object, whereas in Ada 95 the designated -- object is guaranteed to be constrained. A worst-case assumption -- has to apply in Ada 2005 because we can't tell at compile -- time whether the object is "constrained by its initial value", -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic -- rules (these rules are acknowledged to need fixing). We don't -- impose this more stringent checking for earlier Ada versions or -- when Relaxed_RM_Semantics applies (the latter for CodePeer's -- benefit, though it's unclear on why using -gnat95 would not be -- sufficient???). if Ada_Version < Ada_2005 or else Relaxed_RM_Semantics then if Is_Access_Type (Prefix_Type) or else Nkind (P) = N_Explicit_Dereference then return False; end if; else pragma Assert (Ada_Version >= Ada_2005); if Is_Access_Type (Prefix_Type) then -- We need to make sure we have the base subtype, in case -- this is actually an access subtype (whose Ekind will be -- E_Access_Subtype). Prefix_Type := Etype (Prefix_Type); -- If the access type is pool-specific, and there is no -- constrained partial view of the designated type, then the -- designated object is known to be constrained. If it's a -- formal access type and the renaming is in the generic -- spec, we also treat it as pool-specific (known to be -- constrained), but assume the worst if in the generic body -- (see RM 3.3(23.3/3)). if Ekind (Prefix_Type) = E_Access_Type and then (not Is_Generic_Type (Prefix_Type) or else not In_Generic_Body (Current_Scope)) and then not Object_Type_Has_Constrained_Partial_View (Typ => Designated_Type (Prefix_Type), Scop => Current_Scope) then return False; -- Otherwise (general access type, or there is a constrained -- partial view of the designated type), we need to check -- based on the designated type. else Prefix_Type := Designated_Type (Prefix_Type); end if; end if; end if; Comp := Original_Record_Component (Entity (Selector_Name (Object))); -- As per AI-0017, the renaming is illegal in a generic body, even -- if the subtype is indefinite (only applies to prefixes of an -- untagged formal type, see RM 3.3 (23.11/3)). -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable if not Is_Constrained (Prefix_Type) and then (Is_Definite_Subtype (Prefix_Type) or else (not Is_Tagged_Type (Prefix_Type) and then Is_Generic_Type (Prefix_Type) and then In_Generic_Body (Current_Scope))) and then (Is_Declared_Within_Variant (Comp) or else Has_Discriminant_Dependent_Constraint (Comp)) and then (not P_Aliased or else Ada_Version >= Ada_2005) then return True; -- If the prefix is of an access type at this point, then we want -- to return False, rather than calling this function recursively -- on the access object (which itself might be a discriminant- -- dependent component of some other object, but that isn't -- relevant to checking the object passed to us). This avoids -- issuing wrong errors when compiling with -gnatc, where there -- can be implicit dereferences that have not been expanded. elsif Is_Access_Type (Etype (Prefix (Object))) then return False; else return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); end if; elsif Nkind (Object) = N_Indexed_Component or else Nkind (Object) = N_Slice then return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); -- A type conversion that Is_Variable is a view conversion: -- go back to the denoted object. elsif Nkind (Object) = N_Type_Conversion then return Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); end if; end if; return False; end Is_Dependent_Component_Of_Mutable_Object; --------------------- -- Is_Dereferenced -- --------------------- function Is_Dereferenced (N : Node_Id) return Boolean is P : constant Node_Id := Parent (N); begin return Nkind (P) in N_Selected_Component | N_Explicit_Dereference | N_Indexed_Component | N_Slice and then Prefix (P) = N; end Is_Dereferenced; ---------------------- -- Is_Descendant_Of -- ---------------------- function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is T : Entity_Id; Etyp : Entity_Id; begin pragma Assert (Nkind (T1) in N_Entity); pragma Assert (Nkind (T2) in N_Entity); T := Base_Type (T1); -- Immediate return if the types match if T = T2 then return True; -- Comment needed here ??? elsif Ekind (T) = E_Class_Wide_Type then return Etype (T) = T2; -- All other cases else loop Etyp := Etype (T); -- Done if we found the type we are looking for if Etyp = T2 then return True; -- Done if no more derivations to check elsif T = T1 or else T = Etyp then return False; -- Following test catches error cases resulting from prev errors elsif No (Etyp) then return False; elsif Is_Private_Type (T) and then Etyp = Full_View (T) then return False; elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then return False; end if; T := Base_Type (Etyp); end loop; end if; end Is_Descendant_Of; ---------------------------------------- -- Is_Descendant_Of_Suspension_Object -- ---------------------------------------- function Is_Descendant_Of_Suspension_Object (Typ : Entity_Id) return Boolean is Cur_Typ : Entity_Id; Par_Typ : Entity_Id; begin -- Climb the type derivation chain checking each parent type against -- Suspension_Object. Cur_Typ := Base_Type (Typ); while Present (Cur_Typ) loop Par_Typ := Etype (Cur_Typ); -- The current type is a match if Is_Suspension_Object (Cur_Typ) then return True; -- Stop the traversal once the root of the derivation chain has been -- reached. In that case the current type is its own base type. elsif Cur_Typ = Par_Typ then exit; end if; Cur_Typ := Base_Type (Par_Typ); end loop; return False; end Is_Descendant_Of_Suspension_Object; --------------------------------------------- -- Is_Double_Precision_Floating_Point_Type -- --------------------------------------------- function Is_Double_Precision_Floating_Point_Type (E : Entity_Id) return Boolean is begin return Is_Floating_Point_Type (E) and then Machine_Radix_Value (E) = Uint_2 and then Machine_Mantissa_Value (E) = UI_From_Int (53) and then Machine_Emax_Value (E) = Uint_2 ** Uint_10 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10); end Is_Double_Precision_Floating_Point_Type; ----------------------------- -- Is_Effectively_Volatile -- ----------------------------- function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is begin if Is_Type (Id) then -- An arbitrary type is effectively volatile when it is subject to -- pragma Atomic or Volatile. if Is_Volatile (Id) then return True; -- An array type is effectively volatile when it is subject to pragma -- Atomic_Components or Volatile_Components or its component type is -- effectively volatile. elsif Is_Array_Type (Id) then if Has_Volatile_Components (Id) then return True; else declare Anc : Entity_Id := Base_Type (Id); begin if Is_Private_Type (Anc) then Anc := Full_View (Anc); end if; -- Test for presence of ancestor, as the full view of a -- private type may be missing in case of error. return Present (Anc) and then Is_Effectively_Volatile (Component_Type (Anc)); end; end if; -- A protected type is always volatile elsif Is_Protected_Type (Id) then return True; -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is -- automatically volatile. elsif Is_Descendant_Of_Suspension_Object (Id) then return True; -- Otherwise the type is not effectively volatile else return False; end if; -- Otherwise Id denotes an object else pragma Assert (Is_Object (Id)); -- A volatile object for which No_Caching is enabled is not -- effectively volatile. return (Is_Volatile (Id) and then not (Ekind (Id) = E_Variable and then No_Caching_Enabled (Id))) or else Has_Volatile_Components (Id) or else Is_Effectively_Volatile (Etype (Id)); end if; end Is_Effectively_Volatile; ----------------------------------------- -- Is_Effectively_Volatile_For_Reading -- ----------------------------------------- function Is_Effectively_Volatile_For_Reading (Id : Entity_Id) return Boolean is begin -- A concurrent type is effectively volatile for reading if Is_Concurrent_Type (Id) then return True; elsif Is_Effectively_Volatile (Id) then -- Other volatile types and objects are effectively volatile for -- reading when they have property Async_Writers or Effective_Reads -- set to True. This includes the case of an array type whose -- Volatile_Components aspect is True (hence it is effectively -- volatile) which does not have the properties Async_Writers -- and Effective_Reads set to False. if Async_Writers_Enabled (Id) or else Effective_Reads_Enabled (Id) then return True; -- In addition, an array type is effectively volatile for reading -- when its component type is effectively volatile for reading. elsif Is_Array_Type (Id) then declare Anc : Entity_Id := Base_Type (Id); begin if Is_Private_Type (Anc) then Anc := Full_View (Anc); end if; -- Test for presence of ancestor, as the full view of a -- private type may be missing in case of error. return Present (Anc) and then Is_Effectively_Volatile_For_Reading (Component_Type (Anc)); end; end if; end if; return False; end Is_Effectively_Volatile_For_Reading; ------------------------------------ -- Is_Effectively_Volatile_Object -- ------------------------------------ function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is function Is_Effectively_Volatile_Object_Inst is new Is_Effectively_Volatile_Object_Shared (Is_Effectively_Volatile); begin return Is_Effectively_Volatile_Object_Inst (N); end Is_Effectively_Volatile_Object; ------------------------------------------------ -- Is_Effectively_Volatile_Object_For_Reading -- ------------------------------------------------ function Is_Effectively_Volatile_Object_For_Reading (N : Node_Id) return Boolean is function Is_Effectively_Volatile_Object_For_Reading_Inst is new Is_Effectively_Volatile_Object_Shared (Is_Effectively_Volatile_For_Reading); begin return Is_Effectively_Volatile_Object_For_Reading_Inst (N); end Is_Effectively_Volatile_Object_For_Reading; ------------------------------------------- -- Is_Effectively_Volatile_Object_Shared -- ------------------------------------------- function Is_Effectively_Volatile_Object_Shared (N : Node_Id) return Boolean is begin if Is_Entity_Name (N) then return Is_Object (Entity (N)) and then Is_Effectively_Volatile_Entity (Entity (N)); elsif Nkind (N) in N_Indexed_Component | N_Slice then return Is_Effectively_Volatile_Object_Shared (Prefix (N)); elsif Nkind (N) = N_Selected_Component then return Is_Effectively_Volatile_Object_Shared (Prefix (N)) or else Is_Effectively_Volatile_Object_Shared (Selector_Name (N)); elsif Nkind (N) in N_Qualified_Expression | N_Unchecked_Type_Conversion | N_Type_Conversion then return Is_Effectively_Volatile_Object_Shared (Expression (N)); else return False; end if; end Is_Effectively_Volatile_Object_Shared; ------------------- -- Is_Entry_Body -- ------------------- function Is_Entry_Body (Id : Entity_Id) return Boolean is begin return Is_Entry (Id) and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body; end Is_Entry_Body; -------------------------- -- Is_Entry_Declaration -- -------------------------- function Is_Entry_Declaration (Id : Entity_Id) return Boolean is begin return Is_Entry (Id) and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration; end Is_Entry_Declaration; ------------------------------------ -- Is_Expanded_Priority_Attribute -- ------------------------------------ function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean is begin return Nkind (E) = N_Function_Call and then not Configurable_Run_Time_Mode and then Nkind (Original_Node (E)) = N_Attribute_Reference and then (Entity (Name (E)) = RTE (RE_Get_Ceiling) or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling)); end Is_Expanded_Priority_Attribute; ---------------------------- -- Is_Expression_Function -- ---------------------------- function Is_Expression_Function (Subp : Entity_Id) return Boolean is begin if Ekind (Subp) in E_Function | E_Subprogram_Body then return Nkind (Original_Node (Unit_Declaration_Node (Subp))) = N_Expression_Function; else return False; end if; end Is_Expression_Function; ------------------------------------------ -- Is_Expression_Function_Or_Completion -- ------------------------------------------ function Is_Expression_Function_Or_Completion (Subp : Entity_Id) return Boolean is Subp_Decl : Node_Id; begin if Ekind (Subp) = E_Function then Subp_Decl := Unit_Declaration_Node (Subp); -- The function declaration is either an expression function or is -- completed by an expression function body. return Is_Expression_Function (Subp) or else (Nkind (Subp_Decl) = N_Subprogram_Declaration and then Present (Corresponding_Body (Subp_Decl)) and then Is_Expression_Function (Corresponding_Body (Subp_Decl))); elsif Ekind (Subp) = E_Subprogram_Body then return Is_Expression_Function (Subp); else return False; end if; end Is_Expression_Function_Or_Completion; ----------------------- -- Is_EVF_Expression -- ----------------------- function Is_EVF_Expression (N : Node_Id) return Boolean is Orig_N : constant Node_Id := Original_Node (N); Alt : Node_Id; Expr : Node_Id; Id : Entity_Id; begin -- Detect a reference to a formal parameter of a specific tagged type -- whose related subprogram is subject to pragma Expresions_Visible with -- value "False". if Is_Entity_Name (N) and then Present (Entity (N)) then Id := Entity (N); return Is_Formal (Id) and then Is_Specific_Tagged_Type (Etype (Id)) and then Extensions_Visible_Status (Id) = Extensions_Visible_False; -- A case expression is an EVF expression when it contains at least one -- EVF dependent_expression. Note that a case expression may have been -- expanded, hence the use of Original_Node. elsif Nkind (Orig_N) = N_Case_Expression then Alt := First (Alternatives (Orig_N)); while Present (Alt) loop if Is_EVF_Expression (Expression (Alt)) then return True; end if; Next (Alt); end loop; -- An if expression is an EVF expression when it contains at least one -- EVF dependent_expression. Note that an if expression may have been -- expanded, hence the use of Original_Node. elsif Nkind (Orig_N) = N_If_Expression then Expr := Next (First (Expressions (Orig_N))); while Present (Expr) loop if Is_EVF_Expression (Expr) then return True; end if; Next (Expr); end loop; -- A qualified expression or a type conversion is an EVF expression when -- its operand is an EVF expression. elsif Nkind (N) in N_Qualified_Expression | N_Unchecked_Type_Conversion | N_Type_Conversion then return Is_EVF_Expression (Expression (N)); -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when -- their prefix denotes an EVF expression. elsif Nkind (N) = N_Attribute_Reference and then Attribute_Name (N) in Name_Loop_Entry | Name_Old | Name_Update then return Is_EVF_Expression (Prefix (N)); end if; return False; end Is_EVF_Expression; -------------- -- Is_False -- -------------- function Is_False (U : Uint) return Boolean is begin return (U = 0); end Is_False; --------------------------- -- Is_Fixed_Model_Number -- --------------------------- function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is S : constant Ureal := Small_Value (T); M : Urealp.Save_Mark; R : Boolean; begin M := Urealp.Mark; R := (U = UR_Trunc (U / S) * S); Urealp.Release (M); return R; end Is_Fixed_Model_Number; ----------------------------- -- Is_Full_Access_Object -- ----------------------------- function Is_Full_Access_Object (N : Node_Id) return Boolean is begin return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N); end Is_Full_Access_Object; ------------------------------- -- Is_Fully_Initialized_Type -- ------------------------------- function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is begin -- Scalar types if Is_Scalar_Type (Typ) then -- A scalar type with an aspect Default_Value is fully initialized -- Note: Iniitalize/Normalize_Scalars also ensure full initialization -- of a scalar type, but we don't take that into account here, since -- we don't want these to affect warnings. return Has_Default_Aspect (Typ); elsif Is_Access_Type (Typ) then return True; elsif Is_Array_Type (Typ) then if Is_Fully_Initialized_Type (Component_Type (Typ)) or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ)) then return True; end if; -- An interesting case, if we have a constrained type one of whose -- bounds is known to be null, then there are no elements to be -- initialized, so all the elements are initialized. if Is_Constrained (Typ) then declare Indx : Node_Id; Indx_Typ : Entity_Id; Lbd, Hbd : Node_Id; begin Indx := First_Index (Typ); while Present (Indx) loop if Etype (Indx) = Any_Type then return False; -- If index is a range, use directly elsif Nkind (Indx) = N_Range then Lbd := Low_Bound (Indx); Hbd := High_Bound (Indx); else Indx_Typ := Etype (Indx); if Is_Private_Type (Indx_Typ) then Indx_Typ := Full_View (Indx_Typ); end if; if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then return False; else Lbd := Type_Low_Bound (Indx_Typ); Hbd := Type_High_Bound (Indx_Typ); end if; end if; if Compile_Time_Known_Value (Lbd) and then Compile_Time_Known_Value (Hbd) then if Expr_Value (Hbd) < Expr_Value (Lbd) then return True; end if; end if; Next_Index (Indx); end loop; end; end if; -- If no null indexes, then type is not fully initialized return False; -- Record types elsif Is_Record_Type (Typ) then if Has_Discriminants (Typ) and then Present (Discriminant_Default_Value (First_Discriminant (Typ))) and then Is_Fully_Initialized_Variant (Typ) then return True; end if; -- We consider bounded string types to be fully initialized, because -- otherwise we get false alarms when the Data component is not -- default-initialized. if Is_Bounded_String (Typ) then return True; end if; -- Controlled records are considered to be fully initialized if -- there is a user defined Initialize routine. This may not be -- entirely correct, but as the spec notes, we are guessing here -- what is best from the point of view of issuing warnings. if Is_Controlled (Typ) then declare Utyp : constant Entity_Id := Underlying_Type (Typ); begin if Present (Utyp) then declare Init : constant Entity_Id := (Find_Optional_Prim_Op (Underlying_Type (Typ), Name_Initialize)); begin if Present (Init) and then Comes_From_Source (Init) and then not In_Predefined_Unit (Init) then return True; elsif Has_Null_Extension (Typ) and then Is_Fully_Initialized_Type (Etype (Base_Type (Typ))) then return True; end if; end; end if; end; end if; -- Otherwise see if all record components are initialized declare Ent : Entity_Id; begin Ent := First_Entity (Typ); while Present (Ent) loop if Ekind (Ent) = E_Component and then (No (Parent (Ent)) or else No (Expression (Parent (Ent)))) and then not Is_Fully_Initialized_Type (Etype (Ent)) -- Special VM case for tag components, which need to be -- defined in this case, but are never initialized as VMs -- are using other dispatching mechanisms. Ignore this -- uninitialized case. Note that this applies both to the -- uTag entry and the main vtable pointer (CPP_Class case). and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) then return False; end if; Next_Entity (Ent); end loop; end; -- No uninitialized components, so type is fully initialized. -- Note that this catches the case of no components as well. return True; elsif Is_Concurrent_Type (Typ) then return True; elsif Is_Private_Type (Typ) then declare U : constant Entity_Id := Underlying_Type (Typ); begin if No (U) then return False; else return Is_Fully_Initialized_Type (U); end if; end; else return False; end if; end Is_Fully_Initialized_Type; ---------------------------------- -- Is_Fully_Initialized_Variant -- ---------------------------------- function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is Loc : constant Source_Ptr := Sloc (Typ); Constraints : constant List_Id := New_List; Components : constant Elist_Id := New_Elmt_List; Comp_Elmt : Elmt_Id; Comp_Id : Node_Id; Comp_List : Node_Id; Discr : Entity_Id; Discr_Val : Node_Id; Report_Errors : Boolean; pragma Warnings (Off, Report_Errors); begin if Serious_Errors_Detected > 0 then return False; end if; if Is_Record_Type (Typ) and then Nkind (Parent (Typ)) = N_Full_Type_Declaration and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition then Comp_List := Component_List (Type_Definition (Parent (Typ))); Discr := First_Discriminant (Typ); while Present (Discr) loop if Nkind (Parent (Discr)) = N_Discriminant_Specification then Discr_Val := Expression (Parent (Discr)); if Present (Discr_Val) and then Is_OK_Static_Expression (Discr_Val) then Append_To (Constraints, Make_Component_Association (Loc, Choices => New_List (New_Occurrence_Of (Discr, Loc)), Expression => New_Copy (Discr_Val))); else return False; end if; else return False; end if; Next_Discriminant (Discr); end loop; Gather_Components (Typ => Typ, Comp_List => Comp_List, Governed_By => Constraints, Into => Components, Report_Errors => Report_Errors); -- Check that each component present is fully initialized Comp_Elmt := First_Elmt (Components); while Present (Comp_Elmt) loop Comp_Id := Node (Comp_Elmt); if Ekind (Comp_Id) = E_Component and then (No (Parent (Comp_Id)) or else No (Expression (Parent (Comp_Id)))) and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) then return False; end if; Next_Elmt (Comp_Elmt); end loop; return True; elsif Is_Private_Type (Typ) then declare U : constant Entity_Id := Underlying_Type (Typ); begin if No (U) then return False; else return Is_Fully_Initialized_Variant (U); end if; end; else return False; end if; end Is_Fully_Initialized_Variant; ------------------------------------ -- Is_Generic_Declaration_Or_Body -- ------------------------------------ function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is Spec_Decl : Node_Id; begin -- Package/subprogram body if Nkind (Decl) in N_Package_Body | N_Subprogram_Body and then Present (Corresponding_Spec (Decl)) then Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl)); -- Package/subprogram body stub elsif Nkind (Decl) in N_Package_Body_Stub | N_Subprogram_Body_Stub and then Present (Corresponding_Spec_Of_Stub (Decl)) then Spec_Decl := Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl)); -- All other cases else Spec_Decl := Decl; end if; -- Rather than inspecting the defining entity of the spec declaration, -- look at its Nkind. This takes care of the case where the analysis of -- a generic body modifies the Ekind of its spec to allow for recursive -- calls. return Nkind (Spec_Decl) in N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration; end Is_Generic_Declaration_Or_Body; --------------------------- -- Is_Independent_Object -- --------------------------- function Is_Independent_Object (N : Node_Id) return Boolean is function Is_Independent_Object_Entity (Id : Entity_Id) return Boolean; -- Determine whether arbitrary entity Id denotes an object that is -- Independent. function Prefix_Has_Independent_Components (P : Node_Id) return Boolean; -- Determine whether prefix P has independent components. This requires -- the presence of an Independent_Components aspect/pragma. ------------------------------------ -- Is_Independent_Object_Entity -- ------------------------------------ function Is_Independent_Object_Entity (Id : Entity_Id) return Boolean is begin return Is_Object (Id) and then (Is_Independent (Id) or else Is_Independent (Etype (Id))); end Is_Independent_Object_Entity; ------------------------------------- -- Prefix_Has_Independent_Components -- ------------------------------------- function Prefix_Has_Independent_Components (P : Node_Id) return Boolean is Typ : constant Entity_Id := Etype (P); begin if Is_Access_Type (Typ) then return Has_Independent_Components (Designated_Type (Typ)); elsif Has_Independent_Components (Typ) then return True; elsif Is_Entity_Name (P) and then Has_Independent_Components (Entity (P)) then return True; else return False; end if; end Prefix_Has_Independent_Components; -- Start of processing for Is_Independent_Object begin if Is_Entity_Name (N) then return Is_Independent_Object_Entity (Entity (N)); elsif Is_Independent (Etype (N)) then return True; elsif Nkind (N) = N_Indexed_Component then return Prefix_Has_Independent_Components (Prefix (N)); elsif Nkind (N) = N_Selected_Component then return Prefix_Has_Independent_Components (Prefix (N)) or else Is_Independent (Entity (Selector_Name (N))); else return False; end if; end Is_Independent_Object; ---------------------------- -- Is_Inherited_Operation -- ---------------------------- function Is_Inherited_Operation (E : Entity_Id) return Boolean is pragma Assert (Is_Overloadable (E)); Kind : constant Node_Kind := Nkind (Parent (E)); begin return Kind = N_Full_Type_Declaration or else Kind = N_Private_Extension_Declaration or else Kind = N_Subtype_Declaration or else (Ekind (E) = E_Enumeration_Literal and then Is_Derived_Type (Etype (E))); end Is_Inherited_Operation; ------------------------------------- -- Is_Inherited_Operation_For_Type -- ------------------------------------- function Is_Inherited_Operation_For_Type (E : Entity_Id; Typ : Entity_Id) return Boolean is begin -- Check that the operation has been created by the type declaration return Is_Inherited_Operation (E) and then Defining_Identifier (Parent (E)) = Typ; end Is_Inherited_Operation_For_Type; -------------------------------------- -- Is_Inlinable_Expression_Function -- -------------------------------------- function Is_Inlinable_Expression_Function (Subp : Entity_Id) return Boolean is Return_Expr : Node_Id; begin if Is_Expression_Function_Or_Completion (Subp) and then Has_Pragma_Inline_Always (Subp) and then Needs_No_Actuals (Subp) and then No (Contract (Subp)) and then not Is_Dispatching_Operation (Subp) and then Needs_Finalization (Etype (Subp)) and then not Is_Class_Wide_Type (Etype (Subp)) and then not Has_Invariants (Etype (Subp)) and then Present (Subprogram_Body (Subp)) and then Was_Expression_Function (Subprogram_Body (Subp)) then Return_Expr := Expression_Of_Expression_Function (Subp); -- The returned object must not have a qualified expression and its -- nominal subtype must be statically compatible with the result -- subtype of the expression function. return Nkind (Return_Expr) = N_Identifier and then Etype (Return_Expr) = Etype (Subp); end if; return False; end Is_Inlinable_Expression_Function; ----------------- -- Is_Iterator -- ----------------- function Is_Iterator (Typ : Entity_Id) return Boolean is function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean; -- Determine whether type Iter_Typ is a predefined forward or reversible -- iterator. ---------------------- -- Denotes_Iterator -- ---------------------- function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is begin -- Check that the name matches, and that the ultimate ancestor is in -- a predefined unit, i.e the one that declares iterator interfaces. return Chars (Iter_Typ) in Name_Forward_Iterator | Name_Reversible_Iterator and then In_Predefined_Unit (Root_Type (Iter_Typ)); end Denotes_Iterator; -- Local variables Iface_Elmt : Elmt_Id; Ifaces : Elist_Id; -- Start of processing for Is_Iterator begin -- The type may be a subtype of a descendant of the proper instance of -- the predefined interface type, so we must use the root type of the -- given type. The same is done for Is_Reversible_Iterator. if Is_Class_Wide_Type (Typ) and then Denotes_Iterator (Root_Type (Typ)) then return True; elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then return False; elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then return True; else Collect_Interfaces (Typ, Ifaces); Iface_Elmt := First_Elmt (Ifaces); while Present (Iface_Elmt) loop if Denotes_Iterator (Node (Iface_Elmt)) then return True; end if; Next_Elmt (Iface_Elmt); end loop; return False; end if; end Is_Iterator; ---------------------------- -- Is_Iterator_Over_Array -- ---------------------------- function Is_Iterator_Over_Array (N : Node_Id) return Boolean is Container : constant Node_Id := Name (N); Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); begin return Is_Array_Type (Container_Typ); end Is_Iterator_Over_Array; ------------ -- Is_LHS -- ------------ -- We seem to have a lot of overlapping functions that do similar things -- (testing for left hand sides or lvalues???). function Is_LHS (N : Node_Id) return Is_LHS_Result is P : constant Node_Id := Parent (N); begin -- Return True if we are the left hand side of an assignment statement if Nkind (P) = N_Assignment_Statement then if Name (P) = N then return Yes; else return No; end if; -- Case of prefix of indexed or selected component or slice elsif Nkind (P) in N_Indexed_Component | N_Selected_Component | N_Slice and then N = Prefix (P) then -- Here we have the case where the parent P is N.Q or N(Q .. R). -- If P is an LHS, then N is also effectively an LHS, but there -- is an important exception. If N is of an access type, then -- what we really have is N.all.Q (or N.all(Q .. R)). In either -- case this makes N.all a left hand side but not N itself. -- If we don't know the type yet, this is the case where we return -- Unknown, since the answer depends on the type which is unknown. if No (Etype (N)) then return Unknown; -- We have an Etype set, so we can check it elsif Is_Access_Type (Etype (N)) then return No; -- OK, not access type case, so just test whole expression else return Is_LHS (P); end if; -- All other cases are not left hand sides else return No; end if; end Is_LHS; ----------------------------- -- Is_Library_Level_Entity -- ----------------------------- function Is_Library_Level_Entity (E : Entity_Id) return Boolean is begin -- The following is a small optimization, and it also properly handles -- discriminals, which in task bodies might appear in expressions before -- the corresponding procedure has been created, and which therefore do -- not have an assigned scope. if Is_Formal (E) then return False; end if; -- Normal test is simply that the enclosing dynamic scope is Standard return Enclosing_Dynamic_Scope (E) = Standard_Standard; end Is_Library_Level_Entity; -------------------------------- -- Is_Limited_Class_Wide_Type -- -------------------------------- function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is begin return Is_Class_Wide_Type (Typ) and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ)); end Is_Limited_Class_Wide_Type; --------------------------------- -- Is_Local_Variable_Reference -- --------------------------------- function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is begin if not Is_Entity_Name (Expr) then return False; else declare Ent : constant Entity_Id := Entity (Expr); Sub : constant Entity_Id := Enclosing_Subprogram (Ent); begin if Ekind (Ent) not in E_Variable | E_In_Out_Parameter then return False; else return Present (Sub) and then Sub = Current_Subprogram; end if; end; end if; end Is_Local_Variable_Reference; --------------- -- Is_Master -- --------------- function Is_Master (N : Node_Id) return Boolean is Disable_Subexpression_Masters : constant Boolean := True; begin if Nkind (N) in N_Subprogram_Body | N_Task_Body | N_Entry_Body or else Is_Statement (N) then return True; end if; -- We avoid returning True when the master is a subexpression described -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ??? if not Disable_Subexpression_Masters and then Nkind (N) in N_Subexpr then declare Par : Node_Id := N; subtype N_Simple_Statement_Other_Than_Simple_Return is Node_Kind with Static_Predicate => N_Simple_Statement_Other_Than_Simple_Return in N_Abort_Statement | N_Assignment_Statement | N_Code_Statement | N_Delay_Statement | N_Entry_Call_Statement | N_Free_Statement | N_Goto_Statement | N_Null_Statement | N_Raise_Statement | N_Requeue_Statement | N_Exit_Statement | N_Procedure_Call_Statement; begin while Present (Par) loop Par := Parent (Par); if Nkind (Par) in N_Subexpr | N_Simple_Statement_Other_Than_Simple_Return then return False; end if; end loop; return True; end; end if; return False; end Is_Master; ----------------------- -- Is_Name_Reference -- ----------------------- function Is_Name_Reference (N : Node_Id) return Boolean is begin if Is_Entity_Name (N) then return Present (Entity (N)) and then Is_Object (Entity (N)); end if; case Nkind (N) is when N_Indexed_Component | N_Slice => return Is_Name_Reference (Prefix (N)) or else Is_Access_Type (Etype (Prefix (N))); -- Attributes 'Input, 'Old and 'Result produce objects when N_Attribute_Reference => return Attribute_Name (N) in Name_Input | Name_Old | Name_Result; when N_Selected_Component => return Is_Name_Reference (Selector_Name (N)) and then (Is_Name_Reference (Prefix (N)) or else Is_Access_Type (Etype (Prefix (N)))); when N_Explicit_Dereference => return True; -- A view conversion of a tagged name is a name reference when N_Type_Conversion => return Is_Tagged_Type (Etype (Subtype_Mark (N))) and then Is_Tagged_Type (Etype (Expression (N))) and then Is_Name_Reference (Expression (N)); -- An unchecked type conversion is considered to be a name if the -- operand is a name (this construction arises only as a result of -- expansion activities). when N_Unchecked_Type_Conversion => return Is_Name_Reference (Expression (N)); when others => return False; end case; end Is_Name_Reference; ------------------------------------ -- Is_Non_Preelaborable_Construct -- ------------------------------------ function Is_Non_Preelaborable_Construct (N : Node_Id) return Boolean is -- NOTE: the routines within Is_Non_Preelaborable_Construct are -- intentionally unnested to avoid deep indentation of code. Non_Preelaborable : exception; -- This exception is raised when the construct violates preelaborability -- to terminate the recursion. procedure Visit (Nod : Node_Id); -- Semantically inspect construct Nod to determine whether it violates -- preelaborability. This routine raises Non_Preelaborable. procedure Visit_List (List : List_Id); pragma Inline (Visit_List); -- Invoke Visit on each element of list List. This routine raises -- Non_Preelaborable. procedure Visit_Pragma (Prag : Node_Id); pragma Inline (Visit_Pragma); -- Semantically inspect pragma Prag to determine whether it violates -- preelaborability. This routine raises Non_Preelaborable. procedure Visit_Subexpression (Expr : Node_Id); pragma Inline (Visit_Subexpression); -- Semantically inspect expression Expr to determine whether it violates -- preelaborability. This routine raises Non_Preelaborable. ----------- -- Visit -- ----------- procedure Visit (Nod : Node_Id) is begin case Nkind (Nod) is -- Declarations when N_Component_Declaration => -- Defining_Identifier is left out because it is not relevant -- for preelaborability. Visit (Component_Definition (Nod)); Visit (Expression (Nod)); when N_Derived_Type_Definition => -- Interface_List is left out because it is not relevant for -- preelaborability. Visit (Record_Extension_Part (Nod)); Visit (Subtype_Indication (Nod)); when N_Entry_Declaration => -- A protected type with at leat one entry is not preelaborable -- while task types are never preelaborable. This renders entry -- declarations non-preelaborable. raise Non_Preelaborable; when N_Full_Type_Declaration => -- Defining_Identifier and Discriminant_Specifications are left -- out because they are not relevant for preelaborability. Visit (Type_Definition (Nod)); when N_Function_Instantiation | N_Package_Instantiation | N_Procedure_Instantiation => -- Defining_Unit_Name and Name are left out because they are -- not relevant for preelaborability. Visit_List (Generic_Associations (Nod)); when N_Object_Declaration => -- Defining_Identifier is left out because it is not relevant -- for preelaborability. Visit (Object_Definition (Nod)); if Has_Init_Expression (Nod) then Visit (Expression (Nod)); elsif not Has_Preelaborable_Initialization (Etype (Defining_Entity (Nod))) then raise Non_Preelaborable; end if; when N_Private_Extension_Declaration | N_Subtype_Declaration => -- Defining_Identifier, Discriminant_Specifications, and -- Interface_List are left out because they are not relevant -- for preelaborability. Visit (Subtype_Indication (Nod)); when N_Protected_Type_Declaration | N_Single_Protected_Declaration => -- Defining_Identifier, Discriminant_Specifications, and -- Interface_List are left out because they are not relevant -- for preelaborability. Visit (Protected_Definition (Nod)); -- A [single] task type is never preelaborable when N_Single_Task_Declaration | N_Task_Type_Declaration => raise Non_Preelaborable; -- Pragmas when N_Pragma => Visit_Pragma (Nod); -- Statements when N_Statement_Other_Than_Procedure_Call => if Nkind (Nod) /= N_Null_Statement then raise Non_Preelaborable; end if; -- Subexpressions when N_Subexpr => Visit_Subexpression (Nod); -- Special when N_Access_To_Object_Definition => Visit (Subtype_Indication (Nod)); when N_Case_Expression_Alternative => Visit (Expression (Nod)); Visit_List (Discrete_Choices (Nod)); when N_Component_Definition => Visit (Access_Definition (Nod)); Visit (Subtype_Indication (Nod)); when N_Component_List => Visit_List (Component_Items (Nod)); Visit (Variant_Part (Nod)); when N_Constrained_Array_Definition => Visit_List (Discrete_Subtype_Definitions (Nod)); Visit (Component_Definition (Nod)); when N_Delta_Constraint | N_Digits_Constraint => -- Delta_Expression and Digits_Expression are left out because -- they are not relevant for preelaborability. Visit (Range_Constraint (Nod)); when N_Discriminant_Specification => -- Defining_Identifier and Expression are left out because they -- are not relevant for preelaborability. Visit (Discriminant_Type (Nod)); when N_Generic_Association => -- Selector_Name is left out because it is not relevant for -- preelaborability. Visit (Explicit_Generic_Actual_Parameter (Nod)); when N_Index_Or_Discriminant_Constraint => Visit_List (Constraints (Nod)); when N_Iterator_Specification => -- Defining_Identifier is left out because it is not relevant -- for preelaborability. Visit (Name (Nod)); Visit (Subtype_Indication (Nod)); when N_Loop_Parameter_Specification => -- Defining_Identifier is left out because it is not relevant -- for preelaborability. Visit (Discrete_Subtype_Definition (Nod)); when N_Parameter_Association => Visit (Explicit_Actual_Parameter (N)); when N_Protected_Definition => -- End_Label is left out because it is not relevant for -- preelaborability. Visit_List (Private_Declarations (Nod)); Visit_List (Visible_Declarations (Nod)); when N_Range_Constraint => Visit (Range_Expression (Nod)); when N_Record_Definition | N_Variant => -- End_Label, Discrete_Choices, and Interface_List are left out -- because they are not relevant for preelaborability. Visit (Component_List (Nod)); when N_Subtype_Indication => -- Subtype_Mark is left out because it is not relevant for -- preelaborability. Visit (Constraint (Nod)); when N_Unconstrained_Array_Definition => -- Subtype_Marks is left out because it is not relevant for -- preelaborability. Visit (Component_Definition (Nod)); when N_Variant_Part => -- Name is left out because it is not relevant for -- preelaborability. Visit_List (Variants (Nod)); -- Default when others => null; end case; end Visit; ---------------- -- Visit_List -- ---------------- procedure Visit_List (List : List_Id) is Nod : Node_Id; begin if Present (List) then Nod := First (List); while Present (Nod) loop Visit (Nod); Next (Nod); end loop; end if; end Visit_List; ------------------ -- Visit_Pragma -- ------------------ procedure Visit_Pragma (Prag : Node_Id) is begin case Get_Pragma_Id (Prag) is when Pragma_Assert | Pragma_Assert_And_Cut | Pragma_Assume | Pragma_Async_Readers | Pragma_Async_Writers | Pragma_Attribute_Definition | Pragma_Check | Pragma_Constant_After_Elaboration | Pragma_CPU | Pragma_Deadline_Floor | Pragma_Dispatching_Domain | Pragma_Effective_Reads | Pragma_Effective_Writes | Pragma_Extensions_Visible | Pragma_Ghost | Pragma_Secondary_Stack_Size | Pragma_Task_Name | Pragma_Volatile_Function => Visit_List (Pragma_Argument_Associations (Prag)); -- Default when others => null; end case; end Visit_Pragma; ------------------------- -- Visit_Subexpression -- ------------------------- procedure Visit_Subexpression (Expr : Node_Id) is procedure Visit_Aggregate (Aggr : Node_Id); pragma Inline (Visit_Aggregate); -- Semantically inspect aggregate Aggr to determine whether it -- violates preelaborability. --------------------- -- Visit_Aggregate -- --------------------- procedure Visit_Aggregate (Aggr : Node_Id) is begin if not Is_Preelaborable_Aggregate (Aggr) then raise Non_Preelaborable; end if; end Visit_Aggregate; -- Start of processing for Visit_Subexpression begin case Nkind (Expr) is when N_Allocator | N_Qualified_Expression | N_Type_Conversion | N_Unchecked_Expression | N_Unchecked_Type_Conversion => -- Subpool_Handle_Name and Subtype_Mark are left out because -- they are not relevant for preelaborability. Visit (Expression (Expr)); when N_Aggregate | N_Extension_Aggregate => Visit_Aggregate (Expr); when N_Attribute_Reference | N_Explicit_Dereference | N_Reference => -- Attribute_Name and Expressions are left out because they are -- not relevant for preelaborability. Visit (Prefix (Expr)); when N_Case_Expression => -- End_Span is left out because it is not relevant for -- preelaborability. Visit_List (Alternatives (Expr)); Visit (Expression (Expr)); when N_Delta_Aggregate => Visit_Aggregate (Expr); Visit (Expression (Expr)); when N_Expression_With_Actions => Visit_List (Actions (Expr)); Visit (Expression (Expr)); when N_Function_Call => -- Ada 2020 (AI12-0175): Calls to certain functions that are -- essentially unchecked conversions are preelaborable. if Ada_Version >= Ada_2020 and then Nkind (Expr) = N_Function_Call and then Is_Entity_Name (Name (Expr)) and then Is_Preelaborable_Function (Entity (Name (Expr))) then Visit_List (Parameter_Associations (Expr)); else raise Non_Preelaborable; end if; when N_If_Expression => Visit_List (Expressions (Expr)); when N_Quantified_Expression => Visit (Condition (Expr)); Visit (Iterator_Specification (Expr)); Visit (Loop_Parameter_Specification (Expr)); when N_Range => Visit (High_Bound (Expr)); Visit (Low_Bound (Expr)); when N_Slice => Visit (Discrete_Range (Expr)); Visit (Prefix (Expr)); -- Default when others => -- The evaluation of an object name is not preelaborable, -- unless the name is a static expression (checked further -- below), or statically denotes a discriminant. if Is_Entity_Name (Expr) then Object_Name : declare Id : constant Entity_Id := Entity (Expr); begin if Is_Object (Id) then if Ekind (Id) = E_Discriminant then null; elsif Ekind (Id) in E_Constant | E_In_Parameter and then Present (Discriminal_Link (Id)) then null; else raise Non_Preelaborable; end if; end if; end Object_Name; -- A non-static expression is not preelaborable elsif not Is_OK_Static_Expression (Expr) then raise Non_Preelaborable; end if; end case; end Visit_Subexpression; -- Start of processing for Is_Non_Preelaborable_Construct begin Visit (N); -- At this point it is known that the construct is preelaborable return False; exception -- The elaboration of the construct performs an action which violates -- preelaborability. when Non_Preelaborable => return True; end Is_Non_Preelaborable_Construct; --------------------------------- -- Is_Nontrivial_DIC_Procedure -- --------------------------------- function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean is Body_Decl : Node_Id; Stmt : Node_Id; begin if Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id) then Body_Decl := Unit_Declaration_Node (Corresponding_Body (Unit_Declaration_Node (Id))); -- The body of the Default_Initial_Condition procedure must contain -- at least one statement, otherwise the generation of the subprogram -- body failed. pragma Assert (Present (Handled_Statement_Sequence (Body_Decl))); -- To qualify as nontrivial, the first statement of the procedure -- must be a check in the form of an if statement. If the original -- Default_Initial_Condition expression was folded, then the first -- statement is not a check. Stmt := First (Statements (Handled_Statement_Sequence (Body_Decl))); return Nkind (Stmt) = N_If_Statement and then Nkind (Original_Node (Stmt)) = N_Pragma; end if; return False; end Is_Nontrivial_DIC_Procedure; ------------------------- -- Is_Null_Record_Type -- ------------------------- function Is_Null_Record_Type (T : Entity_Id) return Boolean is Decl : constant Node_Id := Parent (T); begin return Nkind (Decl) = N_Full_Type_Declaration and then Nkind (Type_Definition (Decl)) = N_Record_Definition and then (No (Component_List (Type_Definition (Decl))) or else Null_Present (Component_List (Type_Definition (Decl)))); end Is_Null_Record_Type; --------------------- -- Is_Object_Image -- --------------------- function Is_Object_Image (Prefix : Node_Id) return Boolean is begin -- Here we test for the case that the prefix is not a type and assume -- if it is not then it must be a named value or an object reference. -- This is because the parser always checks that prefixes of attributes -- are named. return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix))); end Is_Object_Image; ------------------------- -- Is_Object_Reference -- ------------------------- function Is_Object_Reference (N : Node_Id) return Boolean is begin -- AI12-0068: Note that a current instance reference in a type or -- subtype's aspect_specification is considered a value, not an object -- (see RM 8.6(18/5)). if Is_Entity_Name (N) then return Present (Entity (N)) and then Is_Object (Entity (N)) and then not Is_Current_Instance_Reference_In_Type_Aspect (N); else case Nkind (N) is when N_Indexed_Component | N_Slice => return Is_Object_Reference (Prefix (N)) or else Is_Access_Type (Etype (Prefix (N))); -- In Ada 95, a function call is a constant object; a procedure -- call is not. -- Note that predefined operators are functions as well, and so -- are attributes that are (can be renamed as) functions. when N_Function_Call | N_Op => return Etype (N) /= Standard_Void_Type; -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result -- yield objects, even though they are not functions. when N_Attribute_Reference => return Attribute_Name (N) in Name_Loop_Entry | Name_Old | Name_Priority | Name_Result or else Is_Function_Attribute_Name (Attribute_Name (N)); when N_Selected_Component => return Is_Object_Reference (Selector_Name (N)) and then (Is_Object_Reference (Prefix (N)) or else Is_Access_Type (Etype (Prefix (N)))); -- An explicit dereference denotes an object, except that a -- conditional expression gets turned into an explicit dereference -- in some cases, and conditional expressions are not object -- names. when N_Explicit_Dereference => return Nkind (Original_Node (N)) not in N_Case_Expression | N_If_Expression; -- A view conversion of a tagged object is an object reference when N_Type_Conversion => if Ada_Version <= Ada_2012 then -- A view conversion of a tagged object is an object -- reference. return Is_Tagged_Type (Etype (Subtype_Mark (N))) and then Is_Tagged_Type (Etype (Expression (N))) and then Is_Object_Reference (Expression (N)); else -- AI12-0226: In Ada 202x a value conversion of an object is -- an object. return Is_Object_Reference (Expression (N)); end if; -- An unchecked type conversion is considered to be an object if -- the operand is an object (this construction arises only as a -- result of expansion activities). when N_Unchecked_Type_Conversion => return True; -- AI05-0003: In Ada 2012 a qualified expression is a name. -- This allows disambiguation of function calls and the use -- of aggregates in more contexts. when N_Qualified_Expression => return Ada_Version >= Ada_2012 and then Is_Object_Reference (Expression (N)); -- In Ada 95 an aggregate is an object reference when N_Aggregate => return Ada_Version >= Ada_95; -- A string literal is not an object reference, but it might come -- from rewriting of an object reference, e.g. from folding of an -- aggregate. when N_String_Literal => return Is_Rewrite_Substitution (N) and then Is_Object_Reference (Original_Node (N)); -- AI12-0125: Target name represents a constant object when N_Target_Name => return True; when others => return False; end case; end if; end Is_Object_Reference; ----------------------------------- -- Is_OK_Variable_For_Out_Formal -- ----------------------------------- function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is begin Note_Possible_Modification (AV, Sure => True); -- We must reject parenthesized variable names. Comes_From_Source is -- checked because there are currently cases where the compiler violates -- this rule (e.g. passing a task object to its controlled Initialize -- routine). This should be properly documented in sinfo??? if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then return False; -- A variable is always allowed elsif Is_Variable (AV) then return True; -- Generalized indexing operations are rewritten as explicit -- dereferences, and it is only during resolution that we can -- check whether the context requires an access_to_variable type. elsif Nkind (AV) = N_Explicit_Dereference and then Present (Etype (Original_Node (AV))) and then Has_Implicit_Dereference (Etype (Original_Node (AV))) and then Ada_Version >= Ada_2012 then return not Is_Access_Constant (Etype (Prefix (AV))); -- Unchecked conversions are allowed only if they come from the -- generated code, which sometimes uses unchecked conversions for out -- parameters in cases where code generation is unaffected. We tell -- source unchecked conversions by seeing if they are rewrites of -- an original Unchecked_Conversion function call, or of an explicit -- conversion of a function call or an aggregate (as may happen in the -- expansion of a packed array aggregate). elsif Nkind (AV) = N_Unchecked_Type_Conversion then if Nkind (Original_Node (AV)) in N_Function_Call | N_Aggregate then return False; elsif Comes_From_Source (AV) and then Nkind (Original_Node (Expression (AV))) = N_Function_Call then return False; elsif Nkind (Original_Node (AV)) = N_Type_Conversion then return Is_OK_Variable_For_Out_Formal (Expression (AV)); else return True; end if; -- Normal type conversions are allowed if argument is a variable elsif Nkind (AV) = N_Type_Conversion then if Is_Variable (Expression (AV)) and then Paren_Count (Expression (AV)) = 0 then Note_Possible_Modification (Expression (AV), Sure => True); return True; -- We also allow a non-parenthesized expression that raises -- constraint error if it rewrites what used to be a variable elsif Raises_Constraint_Error (Expression (AV)) and then Paren_Count (Expression (AV)) = 0 and then Is_Variable (Original_Node (Expression (AV))) then return True; -- Type conversion of something other than a variable else return False; end if; -- If this node is rewritten, then test the original form, if that is -- OK, then we consider the rewritten node OK (for example, if the -- original node is a conversion, then Is_Variable will not be true -- but we still want to allow the conversion if it converts a variable). elsif Is_Rewrite_Substitution (AV) then return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); -- All other non-variables are rejected else return False; end if; end Is_OK_Variable_For_Out_Formal; ---------------------------- -- Is_OK_Volatile_Context -- ---------------------------- function Is_OK_Volatile_Context (Context : Node_Id; Obj_Ref : Node_Id) return Boolean is function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean; -- Determine whether an arbitrary node denotes a call to a protected -- entry, function, or procedure in prefixed form where the prefix is -- Obj_Ref. function Within_Check (Nod : Node_Id) return Boolean; -- Determine whether an arbitrary node appears in a check node function Within_Volatile_Function (Id : Entity_Id) return Boolean; -- Determine whether an arbitrary entity appears in a volatile function --------------------------------- -- Is_Protected_Operation_Call -- --------------------------------- function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is Pref : Node_Id; Subp : Node_Id; begin -- A call to a protected operations retains its selected component -- form as opposed to other prefixed calls that are transformed in -- expanded names. if Nkind (Nod) = N_Selected_Component then Pref := Prefix (Nod); Subp := Selector_Name (Nod); return Pref = Obj_Ref and then Present (Etype (Pref)) and then Is_Protected_Type (Etype (Pref)) and then Is_Entity_Name (Subp) and then Present (Entity (Subp)) and then Ekind (Entity (Subp)) in E_Entry | E_Entry_Family | E_Function | E_Procedure; else return False; end if; end Is_Protected_Operation_Call; ------------------ -- Within_Check -- ------------------ function Within_Check (Nod : Node_Id) return Boolean is Par : Node_Id; begin -- Climb the parent chain looking for a check node Par := Nod; while Present (Par) loop if Nkind (Par) in N_Raise_xxx_Error then return True; -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then exit; end if; Par := Parent (Par); end loop; return False; end Within_Check; ------------------------------ -- Within_Volatile_Function -- ------------------------------ function Within_Volatile_Function (Id : Entity_Id) return Boolean is Func_Id : Entity_Id; begin -- Traverse the scope stack looking for a [generic] function Func_Id := Id; while Present (Func_Id) and then Func_Id /= Standard_Standard loop if Ekind (Func_Id) in E_Function | E_Generic_Function then return Is_Volatile_Function (Func_Id); end if; Func_Id := Scope (Func_Id); end loop; return False; end Within_Volatile_Function; -- Local variables Obj_Id : Entity_Id; -- Start of processing for Is_OK_Volatile_Context begin -- The volatile object appears on either side of an assignment if Nkind (Context) = N_Assignment_Statement then return True; -- The volatile object is part of the initialization expression of -- another object. elsif Nkind (Context) = N_Object_Declaration and then Present (Expression (Context)) and then Expression (Context) = Obj_Ref and then Nkind (Parent (Context)) /= N_Expression_With_Actions then Obj_Id := Defining_Entity (Context); -- The volatile object acts as the initialization expression of an -- extended return statement. This is valid context as long as the -- function is volatile. if Is_Return_Object (Obj_Id) then return Within_Volatile_Function (Obj_Id); -- Otherwise this is a normal object initialization else return True; end if; -- The volatile object acts as the name of a renaming declaration elsif Nkind (Context) = N_Object_Renaming_Declaration and then Name (Context) = Obj_Ref then return True; -- The volatile object appears as an actual parameter in a call to an -- instance of Unchecked_Conversion whose result is renamed. elsif Nkind (Context) = N_Function_Call and then Is_Entity_Name (Name (Context)) and then Is_Unchecked_Conversion_Instance (Entity (Name (Context))) and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration then return True; -- The volatile object is actually the prefix in a protected entry, -- function, or procedure call. elsif Is_Protected_Operation_Call (Context) then return True; -- The volatile object appears as the expression of a simple return -- statement that applies to a volatile function. elsif Nkind (Context) = N_Simple_Return_Statement and then Expression (Context) = Obj_Ref then return Within_Volatile_Function (Return_Statement_Entity (Context)); -- The volatile object appears as the prefix of a name occurring in a -- non-interfering context. elsif Nkind (Context) in N_Attribute_Reference | N_Explicit_Dereference | N_Indexed_Component | N_Selected_Component | N_Slice and then Prefix (Context) = Obj_Ref and then Is_OK_Volatile_Context (Context => Parent (Context), Obj_Ref => Context) then return True; -- The volatile object appears as the prefix of attributes Address, -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length, -- Position, Size, Storage_Size. elsif Nkind (Context) = N_Attribute_Reference and then Prefix (Context) = Obj_Ref and then Attribute_Name (Context) in Name_Address | Name_Alignment | Name_Component_Size | Name_First | Name_First_Bit | Name_Last | Name_Last_Bit | Name_Length | Name_Position | Name_Size | Name_Storage_Size then return True; -- The volatile object appears as the expression of a type conversion -- occurring in a non-interfering context. elsif Nkind (Context) in N_Qualified_Expression | N_Type_Conversion | N_Unchecked_Type_Conversion and then Expression (Context) = Obj_Ref and then Is_OK_Volatile_Context (Context => Parent (Context), Obj_Ref => Context) then return True; -- The volatile object appears as the expression in a delay statement elsif Nkind (Context) in N_Delay_Statement then return True; -- Allow references to volatile objects in various checks. This is not a -- direct SPARK 2014 requirement. elsif Within_Check (Context) then return True; -- Assume that references to effectively volatile objects that appear -- as actual parameters in a subprogram call are always legal. A full -- legality check is done when the actuals are resolved (see routine -- Resolve_Actuals). elsif Within_Subprogram_Call (Context) then return True; -- Otherwise the context is not suitable for an effectively volatile -- object. else return False; end if; end Is_OK_Volatile_Context; ------------------------------------ -- Is_Package_Contract_Annotation -- ------------------------------------ function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is Nam : Name_Id; begin if Nkind (Item) = N_Aspect_Specification then Nam := Chars (Identifier (Item)); else pragma Assert (Nkind (Item) = N_Pragma); Nam := Pragma_Name (Item); end if; return Nam = Name_Abstract_State or else Nam = Name_Initial_Condition or else Nam = Name_Initializes or else Nam = Name_Refined_State; end Is_Package_Contract_Annotation; ----------------------------------- -- Is_Partially_Initialized_Type -- ----------------------------------- function Is_Partially_Initialized_Type (Typ : Entity_Id; Include_Implicit : Boolean := True) return Boolean is begin if Is_Scalar_Type (Typ) then return Has_Default_Aspect (Base_Type (Typ)); elsif Is_Access_Type (Typ) then return Include_Implicit; elsif Is_Array_Type (Typ) then -- If component type is partially initialized, so is array type if Has_Default_Aspect (Base_Type (Typ)) or else Is_Partially_Initialized_Type (Component_Type (Typ), Include_Implicit) then return True; -- Otherwise we are only partially initialized if we are fully -- initialized (this is the empty array case, no point in us -- duplicating that code here). else return Is_Fully_Initialized_Type (Typ); end if; elsif Is_Record_Type (Typ) then -- A discriminated type is always partially initialized if in -- all mode if Has_Discriminants (Typ) and then Include_Implicit then return True; -- A tagged type is always partially initialized elsif Is_Tagged_Type (Typ) then return True; -- Case of non-discriminated record else declare Comp : Entity_Id; Component_Present : Boolean := False; -- Set True if at least one component is present. If no -- components are present, then record type is fully -- initialized (another odd case, like the null array). begin -- Loop through components Comp := First_Component (Typ); while Present (Comp) loop Component_Present := True; -- If a component has an initialization expression then the -- enclosing record type is partially initialized if Present (Parent (Comp)) and then Present (Expression (Parent (Comp))) then return True; -- If a component is of a type which is itself partially -- initialized, then the enclosing record type is also. elsif Is_Partially_Initialized_Type (Etype (Comp), Include_Implicit) then return True; end if; Next_Component (Comp); end loop; -- No initialized components found. If we found any components -- they were all uninitialized so the result is false. if Component_Present then return False; -- But if we found no components, then all the components are -- initialized so we consider the type to be initialized. else return True; end if; end; end if; -- Concurrent types are always fully initialized elsif Is_Concurrent_Type (Typ) then return True; -- For a private type, go to underlying type. If there is no underlying -- type then just assume this partially initialized. Not clear if this -- can happen in a non-error case, but no harm in testing for this. elsif Is_Private_Type (Typ) then declare U : constant Entity_Id := Underlying_Type (Typ); begin if No (U) then return True; else return Is_Partially_Initialized_Type (U, Include_Implicit); end if; end; -- For any other type (are there any?) assume partially initialized else return True; end if; end Is_Partially_Initialized_Type; ------------------------------------ -- Is_Potentially_Persistent_Type -- ------------------------------------ function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is Comp : Entity_Id; Indx : Node_Id; begin -- For private type, test corresponding full type if Is_Private_Type (T) then return Is_Potentially_Persistent_Type (Full_View (T)); -- Scalar types are potentially persistent elsif Is_Scalar_Type (T) then return True; -- Record type is potentially persistent if not tagged and the types of -- all it components are potentially persistent, and no component has -- an initialization expression. elsif Is_Record_Type (T) and then not Is_Tagged_Type (T) and then not Is_Partially_Initialized_Type (T) then Comp := First_Component (T); while Present (Comp) loop if not Is_Potentially_Persistent_Type (Etype (Comp)) then return False; else Next_Entity (Comp); end if; end loop; return True; -- Array type is potentially persistent if its component type is -- potentially persistent and if all its constraints are static. elsif Is_Array_Type (T) then if not Is_Potentially_Persistent_Type (Component_Type (T)) then return False; end if; Indx := First_Index (T); while Present (Indx) loop if not Is_OK_Static_Subtype (Etype (Indx)) then return False; else Next_Index (Indx); end if; end loop; return True; -- All other types are not potentially persistent else return False; end if; end Is_Potentially_Persistent_Type; -------------------------------- -- Is_Potentially_Unevaluated -- -------------------------------- function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean; -- Aggr is an array aggregate with static bounds and an others clause; -- return True if the others choice of the given array aggregate does -- not cover any component (i.e. is null). function Immediate_Context_Implies_Is_Potentially_Unevaluated (Expr : Node_Id) return Boolean; -- Return True if the *immediate* context of this expression tells us -- that it is potentially unevaluated; return False if the *immediate* -- context doesn't provide an answer to this question and we need to -- keep looking. function Non_Static_Or_Null_Range (N : Node_Id) return Boolean; -- Return True if the given range is nonstatic or null ---------------------------- -- Has_Null_Others_Choice -- ---------------------------- function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean is Idx : constant Node_Id := First_Index (Etype (Aggr)); Hiv : constant Uint := Expr_Value (Type_High_Bound (Etype (Idx))); Lov : constant Uint := Expr_Value (Type_Low_Bound (Etype (Idx))); begin declare Intervals : constant Interval_Lists.Discrete_Interval_List := Interval_Lists.Aggregate_Intervals (Aggr); begin -- The others choice is null if, after normalization, we -- have a single interval covering the whole aggregate. return Intervals'Length = 1 and then Intervals (Intervals'First).Low = Lov and then Intervals (Intervals'First).High = Hiv; end; -- If the aggregate is malformed (that is, indexes are not disjoint) -- then no action is needed at this stage; the error will be reported -- later by the frontend. exception when Interval_Lists.Intervals_Error => return False; end Has_Null_Others_Choice; ---------------------------------------------------------- -- Immediate_Context_Implies_Is_Potentially_Unevaluated -- ---------------------------------------------------------- function Immediate_Context_Implies_Is_Potentially_Unevaluated (Expr : Node_Id) return Boolean is Par : constant Node_Id := Parent (Expr); function Aggregate_Type return Node_Id is (Etype (Parent (Par))); begin if Nkind (Par) = N_If_Expression then return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); elsif Nkind (Par) = N_Case_Expression then return Expr /= Expression (Par); elsif Nkind (Par) in N_And_Then | N_Or_Else then return Expr = Right_Opnd (Par); elsif Nkind (Par) in N_In | N_Not_In then -- If the membership includes several alternatives, only the first -- is definitely evaluated. if Present (Alternatives (Par)) then return Expr /= First (Alternatives (Par)); -- If this is a range membership both bounds are evaluated else return False; end if; elsif Nkind (Par) = N_Quantified_Expression then return Expr = Condition (Par); elsif Nkind (Par) = N_Component_Association and then Expr = Expression (Par) and then Nkind (Parent (Par)) in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate and then Present (Aggregate_Type) and then Aggregate_Type /= Any_Composite then if Is_Array_Type (Aggregate_Type) then if Ada_Version >= Ada_2020 then -- For Ada_2020, this predicate returns True for -- any "repeatedly evaluated" expression. return True; end if; declare Choice : Node_Id; In_Others_Choice : Boolean := False; Array_Agg : constant Node_Id := Parent (Par); begin -- The expression of an array_component_association is -- potentially unevaluated if the associated choice is a -- subtype_indication or range that defines a nonstatic or -- null range. Choice := First (Choices (Par)); while Present (Choice) loop if Nkind (Choice) = N_Range and then Non_Static_Or_Null_Range (Choice) then return True; elsif Nkind (Choice) = N_Identifier and then Present (Scalar_Range (Etype (Choice))) and then Non_Static_Or_Null_Range (Scalar_Range (Etype (Choice))) then return True; elsif Nkind (Choice) = N_Others_Choice then In_Others_Choice := True; end if; Next (Choice); end loop; -- It is also potentially unevaluated if the associated -- choice is an others choice and the applicable index -- constraint is nonstatic or null. if In_Others_Choice then if not Compile_Time_Known_Bounds (Aggregate_Type) then return True; else return Has_Null_Others_Choice (Array_Agg); end if; end if; end; elsif Is_Container_Aggregate (Parent (Par)) then -- a component of a container aggregate return True; end if; return False; else return False; end if; end Immediate_Context_Implies_Is_Potentially_Unevaluated; ------------------------------ -- Non_Static_Or_Null_Range -- ------------------------------ function Non_Static_Or_Null_Range (N : Node_Id) return Boolean is Low, High : Node_Id; begin Get_Index_Bounds (N, Low, High); -- Check static bounds if not Compile_Time_Known_Value (Low) or else not Compile_Time_Known_Value (High) then return True; -- Check null range elsif Expr_Value (High) < Expr_Value (Low) then return True; end if; return False; end Non_Static_Or_Null_Range; -- Local variables Par : Node_Id; Expr : Node_Id; -- Start of processing for Is_Potentially_Unevaluated begin Expr := N; Par := N; -- A postcondition whose expression is a short-circuit is broken down -- into individual aspects for better exception reporting. The original -- short-circuit expression is rewritten as the second operand, and an -- occurrence of 'Old in that operand is potentially unevaluated. -- See sem_ch13.adb for details of this transformation. The reference -- to 'Old may appear within an expression, so we must look for the -- enclosing pragma argument in the tree that contains the reference. while Present (Par) and then Nkind (Par) /= N_Pragma_Argument_Association loop if Is_Rewrite_Substitution (Par) and then Nkind (Original_Node (Par)) = N_And_Then then return True; end if; Par := Parent (Par); end loop; -- Other cases; 'Old appears within other expression (not the top-level -- conjunct in a postcondition) with a potentially unevaluated operand. Par := Parent (Expr); while Present (Par) and then Nkind (Par) /= N_Pragma_Argument_Association loop if Comes_From_Source (Par) and then Immediate_Context_Implies_Is_Potentially_Unevaluated (Expr) then return True; -- For component associations continue climbing; it may be part of -- an array aggregate. elsif Nkind (Par) = N_Component_Association then null; -- If the context is not an expression, or if is the result of -- expansion of an enclosing construct (such as another attribute) -- the predicate does not apply. elsif Nkind (Par) = N_Case_Expression_Alternative then null; elsif Nkind (Par) not in N_Subexpr or else not Comes_From_Source (Par) then return False; end if; Expr := Par; Par := Parent (Par); end loop; return False; end Is_Potentially_Unevaluated; ----------------------------------------- -- Is_Predefined_Dispatching_Operation -- ----------------------------------------- function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean is TSS_Name : TSS_Name_Type; begin if not Is_Dispatching_Operation (E) then return False; end if; Get_Name_String (Chars (E)); -- Most predefined primitives have internally generated names. Equality -- must be treated differently; the predefined operation is recognized -- as a homogeneous binary operator that returns Boolean. if Name_Len > TSS_Name_Type'Last then TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); if Chars (E) in Name_uAssign | Name_uSize or else (Chars (E) = Name_Op_Eq and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize or else TSS_Name = TSS_Stream_Input or else TSS_Name = TSS_Stream_Output or else TSS_Name = TSS_Stream_Read or else TSS_Name = TSS_Stream_Write or else TSS_Name = TSS_Put_Image or else Is_Predefined_Interface_Primitive (E) then return True; end if; end if; return False; end Is_Predefined_Dispatching_Operation; --------------------------------------- -- Is_Predefined_Interface_Primitive -- --------------------------------------- function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is begin -- In VM targets we don't restrict the functionality of this test to -- compiling in Ada 2005 mode since in VM targets any tagged type has -- these primitives. return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion) and then Chars (E) in Name_uDisp_Asynchronous_Select | Name_uDisp_Conditional_Select | Name_uDisp_Get_Prim_Op_Kind | Name_uDisp_Get_Task_Id | Name_uDisp_Requeue | Name_uDisp_Timed_Select; end Is_Predefined_Interface_Primitive; --------------------------------------- -- Is_Predefined_Internal_Operation -- --------------------------------------- function Is_Predefined_Internal_Operation (E : Entity_Id) return Boolean is TSS_Name : TSS_Name_Type; begin if not Is_Dispatching_Operation (E) then return False; end if; Get_Name_String (Chars (E)); -- Most predefined primitives have internally generated names. Equality -- must be treated differently; the predefined operation is recognized -- as a homogeneous binary operator that returns Boolean. if Name_Len > TSS_Name_Type'Last then TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); if Chars (E) in Name_uSize | Name_uAssign or else (Chars (E) = Name_Op_Eq and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize or else Is_Predefined_Interface_Primitive (E) then return True; end if; end if; return False; end Is_Predefined_Internal_Operation; -------------------------------- -- Is_Preelaborable_Aggregate -- -------------------------------- function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is Aggr_Typ : constant Entity_Id := Etype (Aggr); Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ); Anc_Part : Node_Id; Assoc : Node_Id; Choice : Node_Id; Comp_Typ : Entity_Id := Empty; -- init to avoid warning Expr : Node_Id; begin if Array_Aggr then Comp_Typ := Component_Type (Aggr_Typ); end if; -- Inspect the ancestor part if Nkind (Aggr) = N_Extension_Aggregate then Anc_Part := Ancestor_Part (Aggr); -- The ancestor denotes a subtype mark if Is_Entity_Name (Anc_Part) and then Is_Type (Entity (Anc_Part)) then if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then return False; end if; -- Otherwise the ancestor denotes an expression elsif not Is_Preelaborable_Construct (Anc_Part) then return False; end if; end if; -- Inspect the positional associations Expr := First (Expressions (Aggr)); while Present (Expr) loop if not Is_Preelaborable_Construct (Expr) then return False; end if; Next (Expr); end loop; -- Inspect the named associations Assoc := First (Component_Associations (Aggr)); while Present (Assoc) loop -- Inspect the choices of the current named association Choice := First (Choices (Assoc)); while Present (Choice) loop if Array_Aggr then -- For a choice to be preelaborable, it must denote either a -- static range or a static expression. if Nkind (Choice) = N_Others_Choice then null; elsif Nkind (Choice) = N_Range then if not Is_OK_Static_Range (Choice) then return False; end if; elsif not Is_OK_Static_Expression (Choice) then return False; end if; else Comp_Typ := Etype (Choice); end if; Next (Choice); end loop; -- The type of the choice must have preelaborable initialization if -- the association carries a <>. pragma Assert (Present (Comp_Typ)); if Box_Present (Assoc) then if not Has_Preelaborable_Initialization (Comp_Typ) then return False; end if; -- The type of the expression must have preelaborable initialization elsif not Is_Preelaborable_Construct (Expression (Assoc)) then return False; end if; Next (Assoc); end loop; -- At this point the aggregate is preelaborable return True; end Is_Preelaborable_Aggregate; -------------------------------- -- Is_Preelaborable_Construct -- -------------------------------- function Is_Preelaborable_Construct (N : Node_Id) return Boolean is begin -- Aggregates if Nkind (N) in N_Aggregate | N_Extension_Aggregate then return Is_Preelaborable_Aggregate (N); -- Attributes are allowed in general, even if their prefix is a formal -- type. It seems that certain attributes known not to be static might -- not be allowed, but there are no rules to prevent them. elsif Nkind (N) = N_Attribute_Reference then return True; -- Expressions elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then return True; elsif Nkind (N) = N_Qualified_Expression then return Is_Preelaborable_Construct (Expression (N)); -- Names are preelaborable when they denote a discriminant of an -- enclosing type. Discriminals are also considered for this check. elsif Is_Entity_Name (N) and then Present (Entity (N)) and then (Ekind (Entity (N)) = E_Discriminant or else (Ekind (Entity (N)) in E_Constant | E_In_Parameter and then Present (Discriminal_Link (Entity (N))))) then return True; -- Statements elsif Nkind (N) = N_Null then return True; -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially -- unchecked conversions are preelaborable. elsif Ada_Version >= Ada_2020 and then Nkind (N) = N_Function_Call and then Is_Entity_Name (Name (N)) and then Is_Preelaborable_Function (Entity (Name (N))) then declare A : Node_Id; begin A := First_Actual (N); while Present (A) loop if not Is_Preelaborable_Construct (A) then return False; end if; Next_Actual (A); end loop; end; return True; -- Otherwise the construct is not preelaborable else return False; end if; end Is_Preelaborable_Construct; ------------------------------- -- Is_Preelaborable_Function -- ------------------------------- function Is_Preelaborable_Function (Id : Entity_Id) return Boolean is SATAC : constant Rtsfind.RTU_Id := System_Address_To_Access_Conversions; Scop : constant Entity_Id := Scope (Id); begin -- Small optimization: every allowed function has convention Intrinsic -- (see Analyze_Subprogram_Instantiation for the subtlety in the test). if not Is_Intrinsic_Subprogram (Id) and then Convention (Id) /= Convention_Intrinsic then return False; end if; -- An instance of Unchecked_Conversion if Is_Unchecked_Conversion_Instance (Id) then return True; end if; -- A function declared in System.Storage_Elements if Is_RTU (Scop, System_Storage_Elements) then return True; end if; -- The functions To_Pointer and To_Address declared in an instance of -- System.Address_To_Access_Conversions (they are the only ones). if Ekind (Scop) = E_Package and then Nkind (Parent (Scop)) = N_Package_Specification and then Present (Generic_Parent (Parent (Scop))) and then Is_RTU (Generic_Parent (Parent (Scop)), SATAC) then return True; end if; return False; end Is_Preelaborable_Function; --------------------------------- -- Is_Protected_Self_Reference -- --------------------------------- function Is_Protected_Self_Reference (N : Node_Id) return Boolean is function In_Access_Definition (N : Node_Id) return Boolean; -- Returns true if N belongs to an access definition -------------------------- -- In_Access_Definition -- -------------------------- function In_Access_Definition (N : Node_Id) return Boolean is P : Node_Id; begin P := Parent (N); while Present (P) loop if Nkind (P) = N_Access_Definition then return True; end if; P := Parent (P); end loop; return False; end In_Access_Definition; -- Start of processing for Is_Protected_Self_Reference begin -- Verify that prefix is analyzed and has the proper form. Note that -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also -- produce the address of an entity, do not analyze their prefix -- because they denote entities that are not necessarily visible. -- Neither of them can apply to a protected type. return Ada_Version >= Ada_2005 and then Is_Entity_Name (N) and then Present (Entity (N)) and then Is_Protected_Type (Entity (N)) and then In_Open_Scopes (Entity (N)) and then not In_Access_Definition (N); end Is_Protected_Self_Reference; ----------------------------- -- Is_RCI_Pkg_Spec_Or_Body -- ----------------------------- function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; -- Return True if the unit of Cunit is an RCI package declaration --------------------------- -- Is_RCI_Pkg_Decl_Cunit -- --------------------------- function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is The_Unit : constant Node_Id := Unit (Cunit); begin if Nkind (The_Unit) /= N_Package_Declaration then return False; end if; return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); end Is_RCI_Pkg_Decl_Cunit; -- Start of processing for Is_RCI_Pkg_Spec_Or_Body begin return Is_RCI_Pkg_Decl_Cunit (Cunit) or else (Nkind (Unit (Cunit)) = N_Package_Body and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); end Is_RCI_Pkg_Spec_Or_Body; ----------------------------------------- -- Is_Remote_Access_To_Class_Wide_Type -- ----------------------------------------- function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean is begin -- A remote access to class-wide type is a general access to object type -- declared in the visible part of a Remote_Types or Remote_Call_ -- Interface unit. return Ekind (E) = E_General_Access_Type and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); end Is_Remote_Access_To_Class_Wide_Type; ----------------------------------------- -- Is_Remote_Access_To_Subprogram_Type -- ----------------------------------------- function Is_Remote_Access_To_Subprogram_Type (E : Entity_Id) return Boolean is begin return (Ekind (E) = E_Access_Subprogram_Type or else (Ekind (E) = E_Record_Type and then Present (Corresponding_Remote_Type (E)))) and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); end Is_Remote_Access_To_Subprogram_Type; -------------------- -- Is_Remote_Call -- -------------------- function Is_Remote_Call (N : Node_Id) return Boolean is begin if Nkind (N) not in N_Subprogram_Call then -- An entry call cannot be remote return False; elsif Nkind (Name (N)) in N_Has_Entity and then Is_Remote_Call_Interface (Entity (Name (N))) then -- A subprogram declared in the spec of a RCI package is remote return True; elsif Nkind (Name (N)) = N_Explicit_Dereference and then Is_Remote_Access_To_Subprogram_Type (Etype (Prefix (Name (N)))) then -- The dereference of a RAS is a remote call return True; elsif Present (Controlling_Argument (N)) and then Is_Remote_Access_To_Class_Wide_Type (Etype (Controlling_Argument (N))) then -- Any primitive operation call with a controlling argument of -- a RACW type is a remote call. return True; end if; -- All other calls are local calls return False; end Is_Remote_Call; ---------------------- -- Is_Renamed_Entry -- ---------------------- function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is Orig_Node : Node_Id := Empty; Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); function Is_Entry (Nam : Node_Id) return Boolean; -- Determine whether Nam is an entry. Traverse selectors if there are -- nested selected components. -------------- -- Is_Entry -- -------------- function Is_Entry (Nam : Node_Id) return Boolean is begin if Nkind (Nam) = N_Selected_Component then return Is_Entry (Selector_Name (Nam)); end if; return Ekind (Entity (Nam)) = E_Entry; end Is_Entry; -- Start of processing for Is_Renamed_Entry begin if Present (Alias (Proc_Nam)) then Subp_Decl := Parent (Parent (Alias (Proc_Nam))); end if; -- Look for a rewritten subprogram renaming declaration if Nkind (Subp_Decl) = N_Subprogram_Declaration and then Present (Original_Node (Subp_Decl)) then Orig_Node := Original_Node (Subp_Decl); end if; -- The rewritten subprogram is actually an entry if Present (Orig_Node) and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration and then Is_Entry (Name (Orig_Node)) then return True; end if; return False; end Is_Renamed_Entry; ---------------------------- -- Is_Reversible_Iterator -- ---------------------------- function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is Ifaces_List : Elist_Id; Iface_Elmt : Elmt_Id; Iface : Entity_Id; begin if Is_Class_Wide_Type (Typ) and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator and then In_Predefined_Unit (Root_Type (Typ)) then return True; elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then return False; else Collect_Interfaces (Typ, Ifaces_List); Iface_Elmt := First_Elmt (Ifaces_List); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); if Chars (Iface) = Name_Reversible_Iterator and then In_Predefined_Unit (Iface) then return True; end if; Next_Elmt (Iface_Elmt); end loop; end if; return False; end Is_Reversible_Iterator; ---------------------- -- Is_Selector_Name -- ---------------------- function Is_Selector_Name (N : Node_Id) return Boolean is begin if not Is_List_Member (N) then declare P : constant Node_Id := Parent (N); begin return Nkind (P) in N_Expanded_Name | N_Generic_Association | N_Parameter_Association | N_Selected_Component and then Selector_Name (P) = N; end; else declare L : constant List_Id := List_Containing (N); P : constant Node_Id := Parent (L); begin return (Nkind (P) = N_Discriminant_Association and then Selector_Names (P) = L) or else (Nkind (P) = N_Component_Association and then Choices (P) = L); end; end if; end Is_Selector_Name; --------------------------------- -- Is_Single_Concurrent_Object -- --------------------------------- function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is begin return Is_Single_Protected_Object (Id) or else Is_Single_Task_Object (Id); end Is_Single_Concurrent_Object; ------------------------------- -- Is_Single_Concurrent_Type -- ------------------------------- function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is begin return Ekind (Id) in E_Protected_Type | E_Task_Type and then Is_Single_Concurrent_Type_Declaration (Declaration_Node (Id)); end Is_Single_Concurrent_Type; ------------------------------------------- -- Is_Single_Concurrent_Type_Declaration -- ------------------------------------------- function Is_Single_Concurrent_Type_Declaration (N : Node_Id) return Boolean is begin return Nkind (Original_Node (N)) in N_Single_Protected_Declaration | N_Single_Task_Declaration; end Is_Single_Concurrent_Type_Declaration; --------------------------------------------- -- Is_Single_Precision_Floating_Point_Type -- --------------------------------------------- function Is_Single_Precision_Floating_Point_Type (E : Entity_Id) return Boolean is begin return Is_Floating_Point_Type (E) and then Machine_Radix_Value (E) = Uint_2 and then Machine_Mantissa_Value (E) = Uint_24 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7); end Is_Single_Precision_Floating_Point_Type; -------------------------------- -- Is_Single_Protected_Object -- -------------------------------- function Is_Single_Protected_Object (Id : Entity_Id) return Boolean is begin return Ekind (Id) = E_Variable and then Ekind (Etype (Id)) = E_Protected_Type and then Is_Single_Concurrent_Type (Etype (Id)); end Is_Single_Protected_Object; --------------------------- -- Is_Single_Task_Object -- --------------------------- function Is_Single_Task_Object (Id : Entity_Id) return Boolean is begin return Ekind (Id) = E_Variable and then Ekind (Etype (Id)) = E_Task_Type 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 -- ----------------------------- function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is Full_Typ : Entity_Id; begin -- Handle private types if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then Full_Typ := Full_View (Typ); else Full_Typ := Typ; end if; -- A specific tagged type is a non-class-wide tagged type return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ); end Is_Specific_Tagged_Type; ------------------ -- Is_Statement -- ------------------ function Is_Statement (N : Node_Id) return Boolean is begin return Nkind (N) in N_Statement_Other_Than_Procedure_Call or else Nkind (N) = N_Procedure_Call_Statement; end Is_Statement; ------------------------ -- Is_Static_Function -- ------------------------ function Is_Static_Function (Subp : Entity_Id) return Boolean is begin -- Always return False for pre Ada 2020 to e.g. ignore the Static -- aspect in package Interfaces for Ada_Version < 2020 and also -- for efficiency. return Ada_Version >= Ada_2020 and then Has_Aspect (Subp, Aspect_Static) and then (No (Find_Value_Of_Aspect (Subp, Aspect_Static)) or else Is_True (Static_Boolean (Find_Value_Of_Aspect (Subp, Aspect_Static)))); end Is_Static_Function; ----------------------------- -- Is_Static_Function_Call -- ----------------------------- function Is_Static_Function_Call (Call : Node_Id) return Boolean is function Has_All_Static_Actuals (Call : Node_Id) return Boolean; -- Return whether all actual parameters of Call are static expressions ---------------------------- -- Has_All_Static_Actuals -- ---------------------------- function Has_All_Static_Actuals (Call : Node_Id) return Boolean is Actual : Node_Id := First_Actual (Call); String_Result : constant Boolean := Is_String_Type (Etype (Entity (Name (Call)))); begin while Present (Actual) loop if not Is_Static_Expression (Actual) then -- ??? In the string-returning case we want to avoid a call -- being made to Establish_Transient_Scope in Resolve_Call, -- but at the point where that's tested for (which now includes -- a call to test Is_Static_Function_Call), the actuals of the -- call haven't been resolved, so expressions of the actuals -- may not have been marked Is_Static_Expression yet, so we -- force them to be resolved here, so we can tell if they're -- static. Calling Resolve here is admittedly a kludge, and we -- limit this call to string-returning cases. if String_Result then Resolve (Actual); end if; -- Test flag again in case it's now True due to above Resolve if not Is_Static_Expression (Actual) then return False; end if; end if; Next_Actual (Actual); end loop; return True; end Has_All_Static_Actuals; begin return Nkind (Call) = N_Function_Call and then Is_Entity_Name (Name (Call)) and then Is_Static_Function (Entity (Name (Call))) and then Has_All_Static_Actuals (Call); end Is_Static_Function_Call; ------------------------------------------- -- Is_Subcomponent_Of_Full_Access_Object -- ------------------------------------------- function Is_Subcomponent_Of_Full_Access_Object (N : Node_Id) return Boolean is R : Node_Id; begin R := Get_Referenced_Object (N); while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice loop R := Get_Referenced_Object (Prefix (R)); -- If the prefix is an access value, only the designated type matters if Is_Access_Type (Etype (R)) then if Is_Full_Access (Designated_Type (Etype (R))) then return True; end if; else if Is_Full_Access_Object (R) then return True; end if; end if; end loop; return False; end Is_Subcomponent_Of_Full_Access_Object; --------------------------------------- -- Is_Subprogram_Contract_Annotation -- --------------------------------------- function Is_Subprogram_Contract_Annotation (Item : Node_Id) return Boolean is Nam : Name_Id; begin if Nkind (Item) = N_Aspect_Specification then Nam := Chars (Identifier (Item)); else pragma Assert (Nkind (Item) = N_Pragma); Nam := Pragma_Name (Item); end if; return Nam = Name_Contract_Cases or else Nam = Name_Depends or else Nam = Name_Extensions_Visible or else Nam = Name_Global or else Nam = Name_Post or else Nam = Name_Post_Class or else Nam = Name_Postcondition or else Nam = Name_Pre or else Nam = Name_Pre_Class or else Nam = Name_Precondition or else Nam = Name_Refined_Depends or else Nam = Name_Refined_Global or else Nam = Name_Refined_Post or else Nam = Name_Subprogram_Variant or else Nam = Name_Test_Case; end Is_Subprogram_Contract_Annotation; -------------------------------------------------- -- Is_Subprogram_Stub_Without_Prior_Declaration -- -------------------------------------------------- function Is_Subprogram_Stub_Without_Prior_Declaration (N : Node_Id) return Boolean is begin pragma Assert (Nkind (N) = N_Subprogram_Body_Stub); case Ekind (Defining_Entity (N)) is -- A subprogram stub without prior declaration serves as declaration -- for the actual subprogram body. As such, it has an attached -- defining entity of E_Function or E_Procedure. when E_Function | E_Procedure => return True; -- Otherwise, it is completes a [generic] subprogram declaration when E_Generic_Function | E_Generic_Procedure | E_Subprogram_Body => return False; when others => raise Program_Error; end case; end Is_Subprogram_Stub_Without_Prior_Declaration; --------------------------- -- Is_Suitable_Primitive -- --------------------------- function Is_Suitable_Primitive (Subp_Id : Entity_Id) return Boolean is begin -- The Default_Initial_Condition and invariant procedures must not be -- treated as primitive operations even when they apply to a tagged -- type. These routines must not act as targets of dispatching calls -- because they already utilize class-wide-precondition semantics to -- handle inheritance and overriding. if Ekind (Subp_Id) = E_Procedure and then (Is_DIC_Procedure (Subp_Id) or else Is_Invariant_Procedure (Subp_Id)) then return False; end if; return True; end Is_Suitable_Primitive; -------------------------- -- Is_Suspension_Object -- -------------------------- function Is_Suspension_Object (Id : Entity_Id) return Boolean is begin -- This approach does an exact name match rather than to rely on -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the -- front end at point where all auxiliary tables are locked and any -- modifications to them are treated as violations. Do not tamper with -- the tables, instead examine the Chars fields of all the scopes of Id. return Chars (Id) = Name_Suspension_Object and then Present (Scope (Id)) and then Chars (Scope (Id)) = Name_Synchronous_Task_Control and then Present (Scope (Scope (Id))) and then Chars (Scope (Scope (Id))) = Name_Ada and then Present (Scope (Scope (Scope (Id)))) and then Scope (Scope (Scope (Id))) = Standard_Standard; end Is_Suspension_Object; ---------------------------- -- Is_Synchronized_Object -- ---------------------------- function Is_Synchronized_Object (Id : Entity_Id) return Boolean is Prag : Node_Id; begin if Is_Object (Id) then -- The object is synchronized if it is of a type that yields a -- synchronized object. if Yields_Synchronized_Object (Etype (Id)) then return True; -- The object is synchronized if it is atomic and Async_Writers is -- enabled. elsif Is_Atomic_Object_Entity (Id) and then Async_Writers_Enabled (Id) then return True; -- A constant is a synchronized object by default, unless its type is -- access-to-variable type. elsif Ekind (Id) = E_Constant and then not Is_Access_Variable (Etype (Id)) then return True; -- A variable is a synchronized object if it is subject to pragma -- Constant_After_Elaboration. elsif Ekind (Id) = E_Variable then Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration); return Present (Prag) and then Is_Enabled_Pragma (Prag); end if; end if; -- Otherwise the input is not an object or it does not qualify as a -- synchronized object. return False; end Is_Synchronized_Object; --------------------------------- -- Is_Synchronized_Tagged_Type -- --------------------------------- function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is Kind : constant Entity_Kind := Ekind (Base_Type (E)); begin -- A task or protected type derived from an interface is a tagged type. -- Such a tagged type is called a synchronized tagged type, as are -- synchronized interfaces and private extensions whose declaration -- includes the reserved word synchronized. return (Is_Tagged_Type (E) and then (Kind = E_Task_Type or else Kind = E_Protected_Type)) or else (Is_Interface (E) and then Is_Synchronized_Interface (E)) or else (Ekind (E) = E_Record_Type_With_Private and then Nkind (Parent (E)) = N_Private_Extension_Declaration and then (Synchronized_Present (Parent (E)) or else Is_Synchronized_Interface (Etype (E)))); end Is_Synchronized_Tagged_Type; ----------------- -- Is_Transfer -- ----------------- function Is_Transfer (N : Node_Id) return Boolean is Kind : constant Node_Kind := Nkind (N); begin if Kind = N_Simple_Return_Statement or else Kind = N_Extended_Return_Statement or else Kind = N_Goto_Statement or else Kind = N_Raise_Statement or else Kind = N_Requeue_Statement then return True; elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) and then No (Condition (N)) then return True; elsif Kind = N_Procedure_Call_Statement and then Is_Entity_Name (Name (N)) and then Present (Entity (Name (N))) and then No_Return (Entity (Name (N))) then return True; elsif Nkind (Original_Node (N)) = N_Raise_Statement then return True; else return False; end if; end Is_Transfer; ------------- -- Is_True -- ------------- function Is_True (U : Uint) return Boolean is begin return U /= 0; end Is_True; -------------------------------------- -- Is_Unchecked_Conversion_Instance -- -------------------------------------- function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is Par : Node_Id; begin -- Look for a function whose generic parent is the predefined intrinsic -- function Unchecked_Conversion, or for one that renames such an -- instance. if Ekind (Id) = E_Function then Par := Parent (Id); if Nkind (Par) = N_Function_Specification then Par := Generic_Parent (Par); if Present (Par) then return Chars (Par) = Name_Unchecked_Conversion and then Is_Intrinsic_Subprogram (Par) and then In_Predefined_Unit (Par); else return Present (Alias (Id)) and then Is_Unchecked_Conversion_Instance (Alias (Id)); end if; end if; end if; return False; end Is_Unchecked_Conversion_Instance; ------------------------------- -- Is_Universal_Numeric_Type -- ------------------------------- function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is begin return T = Universal_Integer or else T = Universal_Real; end Is_Universal_Numeric_Type; ------------------------------ -- Is_User_Defined_Equality -- ------------------------------ function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is begin return Ekind (Id) = E_Function and then Chars (Id) = Name_Op_Eq and then Comes_From_Source (Id) -- Internally generated equalities have a full type declaration -- as their parent. and then Nkind (Parent (Id)) = N_Function_Specification; end Is_User_Defined_Equality; -------------------------------------- -- Is_Validation_Variable_Reference -- -------------------------------------- function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is Var : constant Node_Id := Unqual_Conv (N); Var_Id : Entity_Id; begin Var_Id := Empty; if Is_Entity_Name (Var) then Var_Id := Entity (Var); end if; return Present (Var_Id) and then Ekind (Var_Id) = E_Variable and then Present (Validated_Object (Var_Id)); end Is_Validation_Variable_Reference; ---------------------------- -- Is_Variable_Size_Array -- ---------------------------- function Is_Variable_Size_Array (E : Entity_Id) return Boolean is Idx : Node_Id; begin pragma Assert (Is_Array_Type (E)); -- Check if some index is initialized with a non-constant value Idx := First_Index (E); while Present (Idx) loop if Nkind (Idx) = N_Range then if not Is_Constant_Bound (Low_Bound (Idx)) or else not Is_Constant_Bound (High_Bound (Idx)) then return True; end if; end if; Next_Index (Idx); end loop; return False; end Is_Variable_Size_Array; ----------------------------- -- Is_Variable_Size_Record -- ----------------------------- function Is_Variable_Size_Record (E : Entity_Id) return Boolean is Comp : Entity_Id; Comp_Typ : Entity_Id; begin pragma Assert (Is_Record_Type (E)); Comp := First_Component (E); while Present (Comp) loop Comp_Typ := Underlying_Type (Etype (Comp)); -- Recursive call if the record type has discriminants if Is_Record_Type (Comp_Typ) and then Has_Discriminants (Comp_Typ) and then Is_Variable_Size_Record (Comp_Typ) then return True; elsif Is_Array_Type (Comp_Typ) and then Is_Variable_Size_Array (Comp_Typ) then return True; end if; Next_Component (Comp); end loop; return False; end Is_Variable_Size_Record; ----------------- -- Is_Variable -- ----------------- function Is_Variable (N : Node_Id; Use_Original_Node : Boolean := True) return Boolean is Orig_Node : Node_Id; function In_Protected_Function (E : Entity_Id) return Boolean; -- Within a protected function, the private components of the enclosing -- protected type are constants. A function nested within a (protected) -- procedure is not itself protected. Within the body of a protected -- function the current instance of the protected type is a constant. function Is_Variable_Prefix (P : Node_Id) return Boolean; -- Prefixes can involve implicit dereferences, in which case we must -- test for the case of a reference of a constant access type, which can -- can never be a variable. --------------------------- -- In_Protected_Function -- --------------------------- function In_Protected_Function (E : Entity_Id) return Boolean is Prot : Entity_Id; S : Entity_Id; begin -- E is the current instance of a type if Is_Type (E) then Prot := E; -- E is an object else Prot := Scope (E); end if; if not Is_Protected_Type (Prot) then return False; else S := Current_Scope; while Present (S) and then S /= Prot loop if Ekind (S) = E_Function and then Scope (S) = Prot then return True; end if; S := Scope (S); end loop; return False; end if; end In_Protected_Function; ------------------------ -- Is_Variable_Prefix -- ------------------------ function Is_Variable_Prefix (P : Node_Id) return Boolean is begin if Is_Access_Type (Etype (P)) then return not Is_Access_Constant (Root_Type (Etype (P))); -- For the case of an indexed component whose prefix has a packed -- array type, the prefix has been rewritten into a type conversion. -- Determine variable-ness from the converted expression. elsif Nkind (P) = N_Type_Conversion and then not Comes_From_Source (P) and then Is_Array_Type (Etype (P)) and then Is_Packed (Etype (P)) then return Is_Variable (Expression (P)); else return Is_Variable (P); end if; end Is_Variable_Prefix; -- Start of processing for Is_Variable begin -- Special check, allow x'Deref(expr) as a variable if Nkind (N) = N_Attribute_Reference and then Attribute_Name (N) = Name_Deref then return True; end if; -- Check if we perform the test on the original node since this may be a -- test of syntactic categories which must not be disturbed by whatever -- rewriting might have occurred. For example, an aggregate, which is -- certainly NOT a variable, could be turned into a variable by -- expansion. if Use_Original_Node then Orig_Node := Original_Node (N); else Orig_Node := N; end if; -- Definitely OK if Assignment_OK is set. Since this is something that -- only gets set for expanded nodes, the test is on N, not Orig_Node. if Nkind (N) in N_Subexpr and then Assignment_OK (N) then return True; -- Normally we go to the original node, but there is one exception where -- we use the rewritten node, namely when it is an explicit dereference. -- The generated code may rewrite a prefix which is an access type with -- an explicit dereference. The dereference is a variable, even though -- the original node may not be (since it could be a constant of the -- access type). -- In Ada 2005 we have a further case to consider: the prefix may be a -- function call given in prefix notation. The original node appears to -- be a selected component, but we need to examine the call. elsif Nkind (N) = N_Explicit_Dereference and then Nkind (Orig_Node) /= N_Explicit_Dereference and then Present (Etype (Orig_Node)) and then Is_Access_Type (Etype (Orig_Node)) then -- Note that if the prefix is an explicit dereference that does not -- come from source, we must check for a rewritten function call in -- prefixed notation before other forms of rewriting, to prevent a -- compiler crash. return (Nkind (Orig_Node) = N_Function_Call and then not Is_Access_Constant (Etype (Prefix (N)))) or else Is_Variable_Prefix (Original_Node (Prefix (N))); -- Generalized indexing operations are rewritten as explicit -- dereferences, and it is only during resolution that we can -- check whether the context requires an access_to_variable type. elsif Nkind (N) = N_Explicit_Dereference and then Present (Etype (Orig_Node)) and then Has_Implicit_Dereference (Etype (Orig_Node)) and then Ada_Version >= Ada_2012 then return not Is_Access_Constant (Etype (Prefix (N))); -- A function call is never a variable elsif Nkind (N) = N_Function_Call then return False; -- All remaining checks use the original node elsif Is_Entity_Name (Orig_Node) and then Present (Entity (Orig_Node)) then declare E : constant Entity_Id := Entity (Orig_Node); K : constant Entity_Kind := Ekind (E); begin if Is_Loop_Parameter (E) then return False; end if; return (K = E_Variable and then Nkind (Parent (E)) /= N_Exception_Handler) or else (K = E_Component and then not In_Protected_Function (E)) or else K = E_Out_Parameter or else K = E_In_Out_Parameter or else K = E_Generic_In_Out_Parameter -- Current instance of type. If this is a protected type, check -- we are not within the body of one of its protected functions. or else (Is_Type (E) and then In_Open_Scopes (E) and then not In_Protected_Function (E)) or else (Is_Incomplete_Or_Private_Type (E) and then In_Open_Scopes (Full_View (E))); end; else case Nkind (Orig_Node) is when N_Indexed_Component | N_Slice => return Is_Variable_Prefix (Prefix (Orig_Node)); when N_Selected_Component => return (Is_Variable (Selector_Name (Orig_Node)) and then Is_Variable_Prefix (Prefix (Orig_Node))) or else (Nkind (N) = N_Expanded_Name and then Scope (Entity (N)) = Entity (Prefix (N))); -- For an explicit dereference, the type of the prefix cannot -- be an access to constant or an access to subprogram. when N_Explicit_Dereference => declare Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); begin return Is_Access_Type (Typ) and then not Is_Access_Constant (Root_Type (Typ)) and then Ekind (Typ) /= E_Access_Subprogram_Type; end; -- The type conversion is the case where we do not deal with the -- context dependent special case of an actual parameter. Thus -- the type conversion is only considered a variable for the -- purposes of this routine if the target type is tagged. However, -- a type conversion is considered to be a variable if it does not -- come from source (this deals for example with the conversions -- of expressions to their actual subtypes). when N_Type_Conversion => return Is_Variable (Expression (Orig_Node)) and then (not Comes_From_Source (Orig_Node) or else (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) and then Is_Tagged_Type (Etype (Expression (Orig_Node))))); -- GNAT allows an unchecked type conversion as a variable. This -- only affects the generation of internal expanded code, since -- calls to instantiations of Unchecked_Conversion are never -- considered variables (since they are function calls). when N_Unchecked_Type_Conversion => return Is_Variable (Expression (Orig_Node)); when others => return False; end case; end if; end Is_Variable; ------------------------ -- Is_View_Conversion -- ------------------------ function Is_View_Conversion (N : Node_Id) return Boolean is begin if Nkind (N) = N_Type_Conversion and then Nkind (Unqual_Conv (N)) in N_Has_Etype then if Is_Tagged_Type (Etype (N)) and then Is_Tagged_Type (Etype (Unqual_Conv (N))) then return True; elsif Is_Actual_Parameter (N) and then (Is_Actual_Out_Parameter (N) or else Is_Actual_In_Out_Parameter (N)) then return True; end if; end if; return False; end Is_View_Conversion; --------------------------- -- Is_Visibly_Controlled -- --------------------------- function Is_Visibly_Controlled (T : Entity_Id) return Boolean is Root : constant Entity_Id := Root_Type (T); begin return Chars (Scope (Root)) = Name_Finalization and then Chars (Scope (Scope (Root))) = Name_Ada and then Scope (Scope (Scope (Root))) = Standard_Standard; end Is_Visibly_Controlled; -------------------------------------- -- Is_Volatile_Full_Access_Object -- -------------------------------------- function Is_Volatile_Full_Access_Object (N : Node_Id) return Boolean is function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean; -- Determine whether arbitrary entity Id denotes an object that is -- Volatile_Full_Access. ---------------------------- -- Is_VFA_Object_Entity -- ---------------------------- function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean is begin return Is_Object (Id) and then (Is_Volatile_Full_Access (Id) or else Is_Volatile_Full_Access (Etype (Id))); end Is_VFA_Object_Entity; -- Start of processing for Is_Volatile_Full_Access_Object begin if Is_Entity_Name (N) then return Is_VFA_Object_Entity (Entity (N)); elsif Is_Volatile_Full_Access (Etype (N)) then return True; elsif Nkind (N) = N_Selected_Component then return Is_Volatile_Full_Access (Entity (Selector_Name (N))); else return False; end if; end Is_Volatile_Full_Access_Object; -------------------------- -- Is_Volatile_Function -- -------------------------- function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is begin pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function); -- A function declared within a protected type is volatile if Is_Protected_Type (Scope (Func_Id)) then return True; -- An instance of Ada.Unchecked_Conversion is a volatile function if -- either the source or the target are effectively volatile. elsif Is_Unchecked_Conversion_Instance (Func_Id) and then Has_Effectively_Volatile_Profile (Func_Id) then return True; -- Otherwise the function is treated as volatile if it is subject to -- enabled pragma Volatile_Function. else return Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function)); end if; end Is_Volatile_Function; ------------------------ -- Is_Volatile_Object -- ------------------------ function Is_Volatile_Object (N : Node_Id) return Boolean is function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean; -- Determine whether arbitrary entity Id denotes an object that is -- Volatile. function Prefix_Has_Volatile_Components (P : Node_Id) return Boolean; -- Determine whether prefix P has volatile components. This requires -- the presence of a Volatile_Components aspect/pragma or that P be -- itself a volatile object as per RM C.6(8). --------------------------------- -- Is_Volatile_Object_Entity -- --------------------------------- function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean is begin return Is_Object (Id) and then (Is_Volatile (Id) or else Is_Volatile (Etype (Id))); end Is_Volatile_Object_Entity; ------------------------------------ -- Prefix_Has_Volatile_Components -- ------------------------------------ function Prefix_Has_Volatile_Components (P : Node_Id) return Boolean is Typ : constant Entity_Id := Etype (P); begin if Is_Access_Type (Typ) then declare Dtyp : constant Entity_Id := Designated_Type (Typ); begin return Has_Volatile_Components (Dtyp) or else Is_Volatile (Dtyp); end; elsif Has_Volatile_Components (Typ) then return True; elsif Is_Entity_Name (P) and then Has_Volatile_Component (Entity (P)) then return True; elsif Is_Volatile_Object (P) then return True; else return False; end if; end Prefix_Has_Volatile_Components; -- Start of processing for Is_Volatile_Object begin if Is_Entity_Name (N) then return Is_Volatile_Object_Entity (Entity (N)); elsif Is_Volatile (Etype (N)) then return True; elsif Nkind (N) = N_Indexed_Component then return Prefix_Has_Volatile_Components (Prefix (N)); elsif Nkind (N) = N_Selected_Component then return Prefix_Has_Volatile_Components (Prefix (N)) or else Is_Volatile (Entity (Selector_Name (N))); else return False; end if; end Is_Volatile_Object; ----------------------------- -- Iterate_Call_Parameters -- ----------------------------- procedure Iterate_Call_Parameters (Call : Node_Id) is Actual : Node_Id := First_Actual (Call); Formal : Entity_Id := First_Formal (Get_Called_Entity (Call)); begin while Present (Formal) and then Present (Actual) loop Handle_Parameter (Formal, Actual); Next_Formal (Formal); Next_Actual (Actual); end loop; pragma Assert (No (Formal)); pragma Assert (No (Actual)); end Iterate_Call_Parameters; --------------------------- -- Itype_Has_Declaration -- --------------------------- function Itype_Has_Declaration (Id : Entity_Id) return Boolean is begin pragma Assert (Is_Itype (Id)); return Present (Parent (Id)) and then Nkind (Parent (Id)) in N_Full_Type_Declaration | N_Subtype_Declaration and then Defining_Entity (Parent (Id)) = Id; end Itype_Has_Declaration; ------------------------- -- Kill_Current_Values -- ------------------------- procedure Kill_Current_Values (Ent : Entity_Id; Last_Assignment_Only : Boolean := False) is begin if Is_Assignable (Ent) then Set_Last_Assignment (Ent, Empty); end if; if Is_Object (Ent) then if not Last_Assignment_Only then Kill_Checks (Ent); Set_Current_Value (Ent, Empty); -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags -- for a constant. Once the constant is elaborated, its value is -- not changed, therefore the associated flags that describe the -- value should not be modified either. if Ekind (Ent) = E_Constant then null; -- Non-constant entities else if not Can_Never_Be_Null (Ent) then Set_Is_Known_Non_Null (Ent, False); end if; Set_Is_Known_Null (Ent, False); -- Reset the Is_Known_Valid flag unless the type is always -- valid. This does not apply to a loop parameter because its -- bounds are defined by the loop header and therefore always -- valid. if not Is_Known_Valid (Etype (Ent)) and then Ekind (Ent) /= E_Loop_Parameter then Set_Is_Known_Valid (Ent, False); end if; end if; end if; end if; end Kill_Current_Values; procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is S : Entity_Id; procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); -- Clear current value for entity E and all entities chained to E ------------------------------------------ -- Kill_Current_Values_For_Entity_Chain -- ------------------------------------------ procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is Ent : Entity_Id; begin Ent := E; while Present (Ent) loop Kill_Current_Values (Ent, Last_Assignment_Only); Next_Entity (Ent); end loop; end Kill_Current_Values_For_Entity_Chain; -- Start of processing for Kill_Current_Values begin -- Kill all saved checks, a special case of killing saved values if not Last_Assignment_Only then Kill_All_Checks; end if; -- Loop through relevant scopes, which includes the current scope and -- any parent scopes if the current scope is a block or a package. S := Current_Scope; Scope_Loop : loop -- Clear current values of all entities in current scope Kill_Current_Values_For_Entity_Chain (First_Entity (S)); -- If scope is a package, also clear current values of all private -- entities in the scope. if Is_Package_Or_Generic_Package (S) or else Is_Concurrent_Type (S) then Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); end if; -- If this is a not a subprogram, deal with parents if not Is_Subprogram (S) then S := Scope (S); exit Scope_Loop when S = Standard_Standard; else exit Scope_Loop; end if; end loop Scope_Loop; end Kill_Current_Values; -------------------------- -- Kill_Size_Check_Code -- -------------------------- procedure Kill_Size_Check_Code (E : Entity_Id) is begin if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) and then Present (Size_Check_Code (E)) then Remove (Size_Check_Code (E)); Set_Size_Check_Code (E, Empty); end if; end Kill_Size_Check_Code; -------------------- -- Known_Non_Null -- -------------------- function Known_Non_Null (N : Node_Id) return Boolean is Status : constant Null_Status_Kind := Null_Status (N); Id : Entity_Id; Op : Node_Kind; Val : Node_Id; begin -- The expression yields a non-null value ignoring simple flow analysis if Status = Is_Non_Null then return True; -- Otherwise check whether N is a reference to an entity that appears -- within a conditional construct. elsif Is_Entity_Name (N) and then Present (Entity (N)) then -- First check if we are in decisive conditional Get_Current_Value_Condition (N, Op, Val); if Known_Null (Val) then if Op = N_Op_Eq then return False; elsif Op = N_Op_Ne then return True; end if; end if; -- If OK to do replacement, test Is_Known_Non_Null flag Id := Entity (N); if OK_To_Do_Constant_Replacement (Id) then return Is_Known_Non_Null (Id); end if; end if; -- Otherwise it is not possible to determine whether N yields a non-null -- value. return False; end Known_Non_Null; ---------------- -- Known_Null -- ---------------- function Known_Null (N : Node_Id) return Boolean is Status : constant Null_Status_Kind := Null_Status (N); Id : Entity_Id; Op : Node_Kind; Val : Node_Id; begin -- The expression yields a null value ignoring simple flow analysis if Status = Is_Null then return True; -- Otherwise check whether N is a reference to an entity that appears -- within a conditional construct. elsif Is_Entity_Name (N) and then Present (Entity (N)) then -- First check if we are in decisive conditional Get_Current_Value_Condition (N, Op, Val); if Known_Null (Val) then if Op = N_Op_Eq then return True; elsif Op = N_Op_Ne then return False; end if; end if; -- If OK to do replacement, test Is_Known_Null flag Id := Entity (N); if OK_To_Do_Constant_Replacement (Id) then return Is_Known_Null (Id); end if; end if; -- Otherwise it is not possible to determine whether N yields a null -- value. return False; end Known_Null; -------------------------- -- Known_To_Be_Assigned -- -------------------------- function Known_To_Be_Assigned (N : Node_Id) return Boolean is P : constant Node_Id := Parent (N); begin case Nkind (P) is -- Test left side of assignment when N_Assignment_Statement => return N = Name (P); -- Function call arguments are never lvalues when N_Function_Call => return False; -- Positional parameter for procedure or accept call when N_Accept_Statement | N_Procedure_Call_Statement => declare Proc : Entity_Id; Form : Entity_Id; Act : Node_Id; begin Proc := Get_Subprogram_Entity (P); if No (Proc) then return False; end if; -- If we are not a list member, something is strange, so -- be conservative and return False. if not Is_List_Member (N) then return False; end if; -- We are going to find the right formal by stepping forward -- through the formals, as we step backwards in the actuals. Form := First_Formal (Proc); Act := N; loop -- If no formal, something is weird, so be conservative -- and return False. if No (Form) then return False; end if; Prev (Act); exit when No (Act); Next_Formal (Form); end loop; return Ekind (Form) /= E_In_Parameter; end; -- Named parameter for procedure or accept call when N_Parameter_Association => declare Proc : Entity_Id; Form : Entity_Id; begin Proc := Get_Subprogram_Entity (Parent (P)); if No (Proc) then return False; end if; -- Loop through formals to find the one that matches Form := First_Formal (Proc); loop -- If no matching formal, that's peculiar, some kind of -- previous error, so return False to be conservative. -- Actually this also happens in legal code in the case -- where P is a parameter association for an Extra_Formal??? if No (Form) then return False; end if; -- Else test for match if Chars (Form) = Chars (Selector_Name (P)) then return Ekind (Form) /= E_In_Parameter; end if; Next_Formal (Form); end loop; end; -- Test for appearing in a conversion that itself appears -- in an lvalue context, since this should be an lvalue. when N_Type_Conversion => return Known_To_Be_Assigned (P); -- All other references are definitely not known to be modifications when others => return False; end case; end Known_To_Be_Assigned; --------------------------- -- Last_Source_Statement -- --------------------------- function Last_Source_Statement (HSS : Node_Id) return Node_Id is N : Node_Id; begin N := Last (Statements (HSS)); while Present (N) loop exit when Comes_From_Source (N); Prev (N); end loop; return N; end Last_Source_Statement; ----------------------- -- Mark_Coextensions -- ----------------------- procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is Is_Dynamic : Boolean; -- Indicates whether the context causes nested coextensions to be -- dynamic or static function Mark_Allocator (N : Node_Id) return Traverse_Result; -- Recognize an allocator node and label it as a dynamic coextension -------------------- -- Mark_Allocator -- -------------------- function Mark_Allocator (N : Node_Id) return Traverse_Result is begin if Nkind (N) = N_Allocator then if Is_Dynamic then Set_Is_Static_Coextension (N, False); Set_Is_Dynamic_Coextension (N); -- If the allocator expression is potentially dynamic, it may -- be expanded out of order and require dynamic allocation -- anyway, so we treat the coextension itself as dynamic. -- Potential optimization ??? elsif Nkind (Expression (N)) = N_Qualified_Expression and then Nkind (Expression (Expression (N))) = N_Op_Concat then Set_Is_Static_Coextension (N, False); Set_Is_Dynamic_Coextension (N); else Set_Is_Dynamic_Coextension (N, False); Set_Is_Static_Coextension (N); end if; end if; return OK; end Mark_Allocator; procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); -- Start of processing for Mark_Coextensions begin -- An allocator that appears on the right-hand side of an assignment is -- treated as a potentially dynamic coextension when the right-hand side -- is an allocator or a qualified expression. -- Obj := new ...'(new Coextension ...); if Nkind (Context_Nod) = N_Assignment_Statement then Is_Dynamic := Nkind (Expression (Context_Nod)) in N_Allocator | N_Qualified_Expression; -- An allocator that appears within the expression of a simple return -- statement is treated as a potentially dynamic coextension when the -- expression is either aggregate, allocator, or qualified expression. -- return (new Coextension ...); -- return new ...'(new Coextension ...); elsif Nkind (Context_Nod) = N_Simple_Return_Statement then Is_Dynamic := Nkind (Expression (Context_Nod)) in N_Aggregate | N_Allocator | N_Qualified_Expression; -- An alloctor that appears within the initialization expression of an -- object declaration is considered a potentially dynamic coextension -- when the initialization expression is an allocator or a qualified -- expression. -- Obj : ... := new ...'(new Coextension ...); -- A similar case arises when the object declaration is part of an -- extended return statement. -- return Obj : ... := new ...'(new Coextension ...); -- return Obj : ... := (new Coextension ...); elsif Nkind (Context_Nod) = N_Object_Declaration then Is_Dynamic := Nkind (Root_Nod) in N_Allocator | N_Qualified_Expression or else Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; -- This routine should not be called with constructs that cannot contain -- coextensions. else raise Program_Error; end if; Mark_Allocators (Root_Nod); end Mark_Coextensions; --------------------------------- -- Mark_Elaboration_Attributes -- --------------------------------- procedure Mark_Elaboration_Attributes (N_Id : Node_Or_Entity_Id; Checks : Boolean := False; Level : Boolean := False; Modes : Boolean := False; Warnings : Boolean := False) is function Elaboration_Checks_OK (Target_Id : Entity_Id; Context_Id : Entity_Id) return Boolean; -- Determine whether elaboration checks are enabled for target Target_Id -- which resides within context Context_Id. procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id); -- Preserve relevant attributes of the context in arbitrary entity Id procedure Mark_Elaboration_Attributes_Node (N : Node_Id); -- Preserve relevant attributes of the context in arbitrary node N --------------------------- -- Elaboration_Checks_OK -- --------------------------- function Elaboration_Checks_OK (Target_Id : Entity_Id; Context_Id : Entity_Id) return Boolean is Encl_Scop : Entity_Id; begin -- Elaboration checks are suppressed for the target if Elaboration_Checks_Suppressed (Target_Id) then return False; end if; -- Otherwise elaboration checks are OK for the target, but may be -- suppressed for the context where the target is declared. Encl_Scop := Context_Id; while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop if Elaboration_Checks_Suppressed (Encl_Scop) then return False; end if; Encl_Scop := Scope (Encl_Scop); end loop; -- Neither the target nor its declarative context have elaboration -- checks suppressed. return True; end Elaboration_Checks_OK; ------------------------------------ -- Mark_Elaboration_Attributes_Id -- ------------------------------------ procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is begin -- Mark the status of elaboration checks in effect. Do not reset the -- status in case the entity is reanalyzed with checks suppressed. if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then Set_Is_Elaboration_Checks_OK_Id (Id, Elaboration_Checks_OK (Target_Id => Id, Context_Id => Scope (Id))); end if; -- Mark the status of elaboration warnings in effect. Do not reset -- the status in case the entity is reanalyzed with warnings off. if Warnings and then not Is_Elaboration_Warnings_OK_Id (Id) then Set_Is_Elaboration_Warnings_OK_Id (Id, Elab_Warnings); end if; end Mark_Elaboration_Attributes_Id; -------------------------------------- -- Mark_Elaboration_Attributes_Node -- -------------------------------------- procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is function Extract_Name (N : Node_Id) return Node_Id; -- Obtain the Name attribute of call or instantiation N ------------------ -- Extract_Name -- ------------------ function Extract_Name (N : Node_Id) return Node_Id is Nam : Node_Id; begin Nam := Name (N); -- A call to an entry family appears in indexed form if Nkind (Nam) = N_Indexed_Component then Nam := Prefix (Nam); end if; -- The name may also appear in qualified form if Nkind (Nam) = N_Selected_Component then Nam := Selector_Name (Nam); end if; return Nam; end Extract_Name; -- Local variables Context_Id : Entity_Id; Nam : Node_Id; -- Start of processing for Mark_Elaboration_Attributes_Node begin -- Mark the status of elaboration checks in effect. Do not reset the -- status in case the node is reanalyzed with checks suppressed. if Checks and then not Is_Elaboration_Checks_OK_Node (N) then -- Assignments, attribute references, and variable references do -- not have a "declarative" context. Context_Id := Empty; -- The status of elaboration checks for calls and instantiations -- depends on the most recent pragma Suppress/Unsuppress, as well -- as the suppression status of the context where the target is -- defined. -- package Pack is -- function Func ...; -- end Pack; -- with Pack; -- procedure Main is -- pragma Suppress (Elaboration_Checks, Pack); -- X : ... := Pack.Func; -- ... -- In the example above, the call to Func has elaboration checks -- enabled because there is no active general purpose suppression -- pragma, however the elaboration checks of Pack are explicitly -- suppressed. As a result the elaboration checks of the call must -- be disabled in order to preserve this dependency. if Nkind (N) in N_Entry_Call_Statement | N_Function_Call | N_Function_Instantiation | N_Package_Instantiation | N_Procedure_Call_Statement | N_Procedure_Instantiation then Nam := Extract_Name (N); if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then Context_Id := Scope (Entity (Nam)); end if; end if; Set_Is_Elaboration_Checks_OK_Node (N, Elaboration_Checks_OK (Target_Id => Empty, Context_Id => Context_Id)); end if; -- Mark the enclosing level of the node. Do not reset the status in -- case the node is relocated and reanalyzed. if Level and then not Is_Declaration_Level_Node (N) then Set_Is_Declaration_Level_Node (N, Find_Enclosing_Level (N) = Declaration_Level); end if; -- Mark the Ghost and SPARK mode in effect if Modes then if Ghost_Mode = Ignore then Set_Is_Ignored_Ghost_Node (N); end if; if SPARK_Mode = On then Set_Is_SPARK_Mode_On_Node (N); end if; end if; -- Mark the status of elaboration warnings in effect. Do not reset -- the status in case the node is reanalyzed with warnings off. if Warnings and then not Is_Elaboration_Warnings_OK_Node (N) then Set_Is_Elaboration_Warnings_OK_Node (N, Elab_Warnings); end if; end Mark_Elaboration_Attributes_Node; -- Start of processing for Mark_Elaboration_Attributes begin -- Do not capture any elaboration-related attributes when switch -gnatH -- (legacy elaboration checking mode enabled) is in effect because the -- attributes are useless to the legacy model. if Legacy_Elaboration_Checks then return; end if; if Nkind (N_Id) in N_Entity then Mark_Elaboration_Attributes_Id (N_Id); else Mark_Elaboration_Attributes_Node (N_Id); end if; end Mark_Elaboration_Attributes; ---------------------------------------- -- Mark_Save_Invocation_Graph_Of_Body -- ---------------------------------------- procedure Mark_Save_Invocation_Graph_Of_Body is Main : constant Node_Id := Cunit (Main_Unit); Main_Unit : constant Node_Id := Unit (Main); Aux_Id : Entity_Id; begin Set_Save_Invocation_Graph_Of_Body (Main); -- Assume that the main unit does not have a complimentary unit Aux_Id := Empty; -- Obtain the complimentary unit of the main unit if Nkind (Main_Unit) in N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration | N_Package_Declaration | N_Subprogram_Declaration then Aux_Id := Corresponding_Body (Main_Unit); elsif Nkind (Main_Unit) in N_Package_Body | N_Subprogram_Body | N_Subprogram_Renaming_Declaration then Aux_Id := Corresponding_Spec (Main_Unit); end if; if Present (Aux_Id) then Set_Save_Invocation_Graph_Of_Body (Parent (Unit_Declaration_Node (Aux_Id))); end if; end Mark_Save_Invocation_Graph_Of_Body; ---------------------------------- -- Matching_Static_Array_Bounds -- ---------------------------------- function Matching_Static_Array_Bounds (L_Typ : Node_Id; R_Typ : Node_Id) return Boolean is L_Ndims : constant Nat := Number_Dimensions (L_Typ); R_Ndims : constant Nat := Number_Dimensions (R_Typ); L_Index : Node_Id := Empty; -- init to ... R_Index : Node_Id := Empty; -- ...avoid warnings L_Low : Node_Id; L_High : Node_Id; L_Len : Uint; R_Low : Node_Id; R_High : Node_Id; R_Len : Uint; begin if L_Ndims /= R_Ndims then return False; end if; -- Unconstrained types do not have static bounds if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then return False; end if; -- First treat specially the first dimension, as the lower bound and -- length of string literals are not stored like those of arrays. if Ekind (L_Typ) = E_String_Literal_Subtype then L_Low := String_Literal_Low_Bound (L_Typ); L_Len := String_Literal_Length (L_Typ); else L_Index := First_Index (L_Typ); Get_Index_Bounds (L_Index, L_Low, L_High); if Is_OK_Static_Expression (L_Low) and then Is_OK_Static_Expression (L_High) then if Expr_Value (L_High) < Expr_Value (L_Low) then L_Len := Uint_0; else L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; end if; else return False; end if; end if; if Ekind (R_Typ) = E_String_Literal_Subtype then R_Low := String_Literal_Low_Bound (R_Typ); R_Len := String_Literal_Length (R_Typ); else R_Index := First_Index (R_Typ); Get_Index_Bounds (R_Index, R_Low, R_High); if Is_OK_Static_Expression (R_Low) and then Is_OK_Static_Expression (R_High) then if Expr_Value (R_High) < Expr_Value (R_Low) then R_Len := Uint_0; else R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; end if; else return False; end if; end if; if (Is_OK_Static_Expression (L_Low) and then Is_OK_Static_Expression (R_Low)) and then Expr_Value (L_Low) = Expr_Value (R_Low) and then L_Len = R_Len then null; else return False; end if; -- Then treat all other dimensions for Indx in 2 .. L_Ndims loop Next (L_Index); Next (R_Index); Get_Index_Bounds (L_Index, L_Low, L_High); Get_Index_Bounds (R_Index, R_Low, R_High); if (Is_OK_Static_Expression (L_Low) and then Is_OK_Static_Expression (L_High) and then Is_OK_Static_Expression (R_Low) and then Is_OK_Static_Expression (R_High)) and then (Expr_Value (L_Low) = Expr_Value (R_Low) and then Expr_Value (L_High) = Expr_Value (R_High)) then null; else return False; end if; end loop; -- If we fall through the loop, all indexes matched return True; end Matching_Static_Array_Bounds; ------------------- -- May_Be_Lvalue -- ------------------- function May_Be_Lvalue (N : Node_Id) return Boolean is P : constant Node_Id := Parent (N); begin case Nkind (P) is -- Test left side of assignment when N_Assignment_Statement => return N = Name (P); -- Test prefix of component or attribute. Note that the prefix of an -- explicit or implicit dereference cannot be an l-value. In the case -- of a 'Read attribute, the reference can be an actual in the -- argument list of the attribute. when N_Attribute_Reference => return (N = Prefix (P) and then Name_Implies_Lvalue_Prefix (Attribute_Name (P))) or else Attribute_Name (P) = Name_Read; -- For an expanded name, the name is an lvalue if the expanded name -- is an lvalue, but the prefix is never an lvalue, since it is just -- the scope where the name is found. when N_Expanded_Name => if N = Prefix (P) then return May_Be_Lvalue (P); else return False; end if; -- For a selected component A.B, A is certainly an lvalue if A.B is. -- B is a little interesting, if we have A.B := 3, there is some -- discussion as to whether B is an lvalue or not, we choose to say -- it is. Note however that A is not an lvalue if it is of an access -- type since this is an implicit dereference. when N_Selected_Component => if N = Prefix (P) and then Present (Etype (N)) and then Is_Access_Type (Etype (N)) then return False; else return May_Be_Lvalue (P); end if; -- For an indexed component or slice, the index or slice bounds is -- never an lvalue. The prefix is an lvalue if the indexed component -- or slice is an lvalue, except if it is an access type, where we -- have an implicit dereference. when N_Indexed_Component | N_Slice => if N /= Prefix (P) or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) then return False; else return May_Be_Lvalue (P); end if; -- Prefix of a reference is an lvalue if the reference is an lvalue when N_Reference => return May_Be_Lvalue (P); -- Prefix of explicit dereference is never an lvalue when N_Explicit_Dereference => return False; -- Positional parameter for subprogram, entry, or accept call. -- In older versions of Ada function call arguments are never -- lvalues. In Ada 2012 functions can have in-out parameters. when N_Accept_Statement | N_Entry_Call_Statement | N_Subprogram_Call => if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then return False; end if; -- The following mechanism is clumsy and fragile. A single flag -- set in Resolve_Actuals would be preferable ??? declare Proc : Entity_Id; Form : Entity_Id; Act : Node_Id; begin Proc := Get_Subprogram_Entity (P); if No (Proc) then return True; end if; -- If we are not a list member, something is strange, so be -- conservative and return True. if not Is_List_Member (N) then return True; end if; -- We are going to find the right formal by stepping forward -- through the formals, as we step backwards in the actuals. Form := First_Formal (Proc); Act := N; loop -- If no formal, something is weird, so be conservative and -- return True. if No (Form) then return True; end if; Prev (Act); exit when No (Act); Next_Formal (Form); end loop; return Ekind (Form) /= E_In_Parameter; end; -- Named parameter for procedure or accept call when N_Parameter_Association => declare Proc : Entity_Id; Form : Entity_Id; begin Proc := Get_Subprogram_Entity (Parent (P)); if No (Proc) then return True; end if; -- Loop through formals to find the one that matches Form := First_Formal (Proc); loop -- If no matching formal, that's peculiar, some kind of -- previous error, so return True to be conservative. -- Actually happens with legal code for an unresolved call -- where we may get the wrong homonym??? if No (Form) then return True; end if; -- Else test for match if Chars (Form) = Chars (Selector_Name (P)) then return Ekind (Form) /= E_In_Parameter; end if; Next_Formal (Form); end loop; end; -- Test for appearing in a conversion that itself appears in an -- lvalue context, since this should be an lvalue. when N_Type_Conversion => return May_Be_Lvalue (P); -- Test for appearance in object renaming declaration when N_Object_Renaming_Declaration => return True; -- All other references are definitely not lvalues when others => return False; end case; end May_Be_Lvalue; ----------------- -- Might_Raise -- ----------------- function Might_Raise (N : Node_Id) return Boolean is Result : Boolean := False; function Process (N : Node_Id) return Traverse_Result; -- Set Result to True if we find something that could raise an exception ------------- -- Process -- ------------- function Process (N : Node_Id) return Traverse_Result is begin if Nkind (N) in N_Procedure_Call_Statement | N_Function_Call | N_Raise_Statement | N_Raise_xxx_Error then Result := True; return Abandon; else return OK; end if; end Process; procedure Set_Result is new Traverse_Proc (Process); -- Start of processing for Might_Raise begin -- False if exceptions can't be propagated if No_Exception_Handlers_Set then return False; end if; -- If the checks handled by the back end are not disabled, we cannot -- ensure that no exception will be raised. if not Access_Checks_Suppressed (Empty) or else not Discriminant_Checks_Suppressed (Empty) or else not Range_Checks_Suppressed (Empty) or else not Index_Checks_Suppressed (Empty) or else Opt.Stack_Checking_Enabled then return True; end if; Set_Result (N); return Result; end Might_Raise; -------------------------------- -- Nearest_Enclosing_Instance -- -------------------------------- function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id is Inst : Entity_Id; begin Inst := Scope (E); while Present (Inst) and then Inst /= Standard_Standard loop if Is_Generic_Instance (Inst) then return Inst; end if; Inst := Scope (Inst); end loop; return Empty; end Nearest_Enclosing_Instance; ------------------------ -- Needs_Finalization -- ------------------------ function Needs_Finalization (Typ : Entity_Id) return Boolean is function Has_Some_Controlled_Component (Input_Typ : Entity_Id) return Boolean; -- Determine whether type Input_Typ has at least one controlled -- component. ----------------------------------- -- Has_Some_Controlled_Component -- ----------------------------------- function Has_Some_Controlled_Component (Input_Typ : Entity_Id) return Boolean is Comp : Entity_Id; begin -- When a type is already frozen and has at least one controlled -- component, or is manually decorated, it is sufficient to inspect -- flag Has_Controlled_Component. if Has_Controlled_Component (Input_Typ) then return True; -- Otherwise inspect the internals of the type elsif not Is_Frozen (Input_Typ) then if Is_Array_Type (Input_Typ) then return Needs_Finalization (Component_Type (Input_Typ)); elsif Is_Record_Type (Input_Typ) then Comp := First_Component (Input_Typ); while Present (Comp) loop if Needs_Finalization (Etype (Comp)) then return True; end if; Next_Component (Comp); end loop; end if; end if; return False; end Has_Some_Controlled_Component; -- Start of processing for Needs_Finalization begin -- Certain run-time configurations and targets do not provide support -- for controlled types. if Restriction_Active (No_Finalization) then return False; -- C++ types are not considered controlled. It is assumed that the non- -- Ada side will handle their clean up. elsif Convention (Typ) = Convention_CPP then return False; -- Class-wide types are treated as controlled because derivations from -- the root type may introduce controlled components. elsif Is_Class_Wide_Type (Typ) then return True; -- Concurrent types are controlled as long as their corresponding record -- is controlled. elsif Is_Concurrent_Type (Typ) and then Present (Corresponding_Record_Type (Typ)) and then Needs_Finalization (Corresponding_Record_Type (Typ)) then return True; -- Otherwise the type is controlled when it is either derived from type -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or -- contains at least one controlled component. else return Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ); end if; end Needs_Finalization; ---------------------- -- Needs_One_Actual -- ---------------------- function Needs_One_Actual (E : Entity_Id) return Boolean is Formal : Entity_Id; begin -- Ada 2005 or later, and formals present. The first formal must be -- of a type that supports prefix notation: a controlling argument, -- a class-wide type, or an access to such. if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) and then No (Default_Value (First_Formal (E))) and then (Is_Controlling_Formal (First_Formal (E)) or else Is_Class_Wide_Type (Etype (First_Formal (E))) or else Is_Anonymous_Access_Type (Etype (First_Formal (E)))) then Formal := Next_Formal (First_Formal (E)); while Present (Formal) loop if No (Default_Value (Formal)) then return False; end if; Next_Formal (Formal); end loop; return True; -- Ada 83/95 or no formals else return False; 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_Coextension_Cases : constant Boolean := True; -- Flag used to temporarily disable a "True" result for types with -- access discriminants and related coextension cases. -- Start of processing for Needs_Result_Accessibility_Level begin -- False if completion unavailable (how does this happen???) if not Present (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 elsif Ada_Version < Ada_2012 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; -- The following cases are related to coextensions and do not fully -- cover everything mentioned in RM 3.10.2 (12) ??? -- Temporarily disabled ??? elsif Disable_Coextension_Cases then return False; -- 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. elsif Is_Tagged_Type (Func_Typ) then return True; 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_Simple_Initialization -- --------------------------------- function Needs_Simple_Initialization (Typ : Entity_Id; Consider_IS : Boolean := True) return Boolean is Consider_IS_NS : constant Boolean := Normalize_Scalars or (Initialize_Scalars and Consider_IS); begin -- Never need initialization if it is suppressed if Initialization_Suppressed (Typ) then return False; end if; -- Check for private type, in which case test applies to the underlying -- type of the private type. if Is_Private_Type (Typ) then declare RT : constant Entity_Id := Underlying_Type (Typ); begin if Present (RT) then return Needs_Simple_Initialization (RT); else return False; end if; end; -- Scalar type with Default_Value aspect requires initialization elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then return True; -- Cases needing simple initialization are access types, and, if pragma -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar -- types. elsif Is_Access_Type (Typ) or else (Consider_IS_NS and then (Is_Scalar_Type (Typ))) then return True; -- If Initialize/Normalize_Scalars is in effect, string objects also -- need initialization, unless they are created in the course of -- expanding an aggregate (since in the latter case they will be -- filled with appropriate initializing values before they are used). elsif Consider_IS_NS and then Is_Standard_String_Type (Typ) and then (not Is_Itype (Typ) or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate) then return True; else return False; end if; end Needs_Simple_Initialization; ------------------------------------- -- Needs_Variable_Reference_Marker -- ------------------------------------- function Needs_Variable_Reference_Marker (N : Node_Id; Calls_OK : Boolean) return Boolean is function Within_Suitable_Context (Ref : Node_Id) return Boolean; -- Deteremine whether variable reference Ref appears within a suitable -- context that allows the creation of a marker. ----------------------------- -- Within_Suitable_Context -- ----------------------------- function Within_Suitable_Context (Ref : Node_Id) return Boolean is Par : Node_Id; begin Par := Ref; while Present (Par) loop -- The context is not suitable when the reference appears within -- the formal part of an instantiation which acts as compilation -- unit because there is no proper list for the insertion of the -- marker. if Nkind (Par) = N_Generic_Association and then Nkind (Parent (Par)) in N_Generic_Instantiation and then Nkind (Parent (Parent (Par))) = N_Compilation_Unit then return False; -- The context is not suitable when the reference appears within -- a pragma. If the pragma has run-time semantics, the reference -- will be reconsidered once the pragma is expanded. elsif Nkind (Par) = N_Pragma then return False; -- The context is not suitable when the reference appears within a -- subprogram call, and the caller requests this behavior. elsif not Calls_OK and then Nkind (Par) in N_Entry_Call_Statement | N_Function_Call | N_Procedure_Call_Statement then return False; -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then exit; end if; Par := Parent (Par); end loop; return True; end Within_Suitable_Context; -- Local variables Prag : Node_Id; Var_Id : Entity_Id; -- Start of processing for Needs_Variable_Reference_Marker begin -- No marker needs to be created when switch -gnatH (legacy elaboration -- checking mode enabled) is in effect because the legacy ABE mechanism -- does not use markers. if Legacy_Elaboration_Checks then return False; -- No marker needs to be created when the reference is preanalyzed -- because the marker will be inserted in the wrong place. elsif Preanalysis_Active then return False; -- Only references warrant a marker elsif Nkind (N) not in N_Expanded_Name | N_Identifier then return False; -- Only source references warrant a marker elsif not Comes_From_Source (N) then return False; -- No marker needs to be created when the reference is erroneous, left -- in a bad state, or does not denote a variable. elsif not (Present (Entity (N)) and then Ekind (Entity (N)) = E_Variable and then Entity (N) /= Any_Id) then return False; end if; Var_Id := Entity (N); Prag := SPARK_Pragma (Var_Id); -- Both the variable and reference must appear in SPARK_Mode On regions -- because this elaboration scenario falls under the SPARK rules. if not (Comes_From_Source (Var_Id) and then Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On and then Is_SPARK_Mode_On_Node (N)) then return False; -- No marker needs to be created when the reference does not appear -- within a suitable context (see body for details). -- Performance note: parent traversal elsif not Within_Suitable_Context (N) then return False; end if; -- At this point it is known that the variable reference will play a -- role in ABE diagnostics and requires a marker. return True; end Needs_Variable_Reference_Marker; ------------------------ -- New_Copy_List_Tree -- ------------------------ function New_Copy_List_Tree (List : List_Id) return List_Id is NL : List_Id; E : Node_Id; begin if List = No_List then return No_List; else NL := New_List; E := First (List); while Present (E) loop Append (New_Copy_Tree (E), NL); Next (E); end loop; return NL; end if; end New_Copy_List_Tree; ---------------------------- -- New_Copy_Separate_List -- ---------------------------- function New_Copy_Separate_List (List : List_Id) return List_Id is begin if List = No_List then return No_List; else declare List_Copy : constant List_Id := New_List; N : Node_Id := First (List); begin while Present (N) loop Append (New_Copy_Separate_Tree (N), List_Copy); Next (N); end loop; return List_Copy; end; end if; end New_Copy_Separate_List; ---------------------------- -- New_Copy_Separate_Tree -- ---------------------------- function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id is function Search_Decl (N : Node_Id) return Traverse_Result; -- Subtree visitor which collects declarations procedure Search_Declarations is new Traverse_Proc (Search_Decl); -- Subtree visitor instantiation ----------------- -- Search_Decl -- ----------------- Decls : Elist_Id; function Search_Decl (N : Node_Id) return Traverse_Result is begin if Nkind (N) in N_Declaration then if No (Decls) then Decls := New_Elmt_List; end if; Append_Elmt (N, Decls); end if; return OK; end Search_Decl; -- Local variables Source_Copy : constant Node_Id := New_Copy_Tree (Source); -- Start of processing for New_Copy_Separate_Tree begin Decls := No_Elist; Search_Declarations (Source_Copy); -- Associate a new Entity with all the subtree declarations (keeping -- their original name). if Present (Decls) then declare Elmt : Elmt_Id; Decl : Node_Id; New_E : Entity_Id; begin Elmt := First_Elmt (Decls); while Present (Elmt) loop Decl := Node (Elmt); New_E := Make_Defining_Identifier (Sloc (Decl), New_Internal_Name ('P')); if Nkind (Decl) = N_Expression_Function then Decl := Specification (Decl); end if; if Nkind (Decl) in N_Function_Instantiation | N_Function_Specification | N_Generic_Function_Renaming_Declaration | N_Generic_Package_Renaming_Declaration | N_Generic_Procedure_Renaming_Declaration | N_Package_Body | N_Package_Instantiation | N_Package_Renaming_Declaration | N_Package_Specification | N_Procedure_Instantiation | N_Procedure_Specification then Set_Chars (New_E, Chars (Defining_Unit_Name (Decl))); Set_Defining_Unit_Name (Decl, New_E); else Set_Chars (New_E, Chars (Defining_Identifier (Decl))); Set_Defining_Identifier (Decl, New_E); end if; Next_Elmt (Elmt); end loop; end; end if; return Source_Copy; end New_Copy_Separate_Tree; ------------------- -- New_Copy_Tree -- ------------------- -- The following tables play a key role in replicating entities and Itypes. -- They are intentionally declared at the library level rather than within -- New_Copy_Tree to avoid elaborating them on each call. This performance -- optimization saves up to 2% of the entire compilation time spent in the -- front end. Care should be taken to reset the tables on each new call to -- New_Copy_Tree. NCT_Table_Max : constant := 511; subtype NCT_Table_Index is Nat range 0 .. NCT_Table_Max - 1; function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index; -- Obtain the hash value of node or entity Key -------------------- -- NCT_Table_Hash -- -------------------- function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index is begin return NCT_Table_Index (Key mod NCT_Table_Max); end NCT_Table_Hash; ---------------------- -- NCT_New_Entities -- ---------------------- -- The following table maps old entities and Itypes to their corresponding -- new entities and Itypes. -- Aaa -> Xxx package NCT_New_Entities is new Simple_HTable ( Header_Num => NCT_Table_Index, Element => Entity_Id, No_Element => Empty, Key => Entity_Id, Hash => NCT_Table_Hash, Equal => "="); ------------------------ -- NCT_Pending_Itypes -- ------------------------ -- The following table maps old Associated_Node_For_Itype nodes to a set of -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three -- have the same Associated_Node_For_Itype Ppp, and their corresponding new -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping: -- Ppp -> (Xxx, Yyy, Zzz) -- The set is expressed as an Elist package NCT_Pending_Itypes is new Simple_HTable ( Header_Num => NCT_Table_Index, Element => Elist_Id, No_Element => No_Elist, Key => Node_Id, Hash => NCT_Table_Hash, Equal => "="); NCT_Tables_In_Use : Boolean := False; -- This flag keeps track of whether the two tables NCT_New_Entities and -- NCT_Pending_Itypes are in use. The flag is part of an optimization -- where certain operations are not performed if the tables are not in -- use. This saves up to 8% of the entire compilation time spent in the -- front end. ------------------- -- New_Copy_Tree -- ------------------- function New_Copy_Tree (Source : Node_Id; Map : Elist_Id := No_Elist; New_Sloc : Source_Ptr := No_Location; New_Scope : Entity_Id := Empty; Scopes_In_EWA_OK : Boolean := False) return Node_Id is -- This routine performs low-level tree manipulations and needs access -- to the internals of the tree. use Atree.Unchecked_Access; use Atree_Private_Part; EWA_Level : Nat := 0; -- This counter keeps track of how many N_Expression_With_Actions nodes -- are encountered during a depth-first traversal of the subtree. These -- nodes may define new entities in their Actions lists and thus require -- special processing. EWA_Inner_Scope_Level : Nat := 0; -- This counter keeps track of how many scoping constructs appear within -- an N_Expression_With_Actions node. procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id); pragma Inline (Add_New_Entity); -- Add an entry in the NCT_New_Entities table which maps key Old_Id to -- value New_Id. Old_Id is an entity which appears within the Actions -- list of an N_Expression_With_Actions node, or within an entity map. -- New_Id is the corresponding new entity generated during Phase 1. procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id); pragma Inline (Add_Pending_Itype); -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to -- value Itype. Assoc_Nod is the associated node of an itype. Itype is -- an itype. procedure Build_NCT_Tables (Entity_Map : Elist_Id); pragma Inline (Build_NCT_Tables); -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the -- information supplied in entity map Entity_Map. The format of the -- entity map must be as follows: -- -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN function Copy_Any_Node_With_Replacement (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; pragma Inline (Copy_Any_Node_With_Replacement); -- Replicate entity or node N by invoking one of the following routines: -- -- Copy_Node_With_Replacement -- Corresponding_Entity function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id; -- Replicate the elements of entity list List function Copy_Field_With_Replacement (Field : Union_Id; Old_Par : Node_Id := Empty; New_Par : Node_Id := Empty; Semantic : Boolean := False) return Union_Id; -- Replicate field Field by invoking one of the following routines: -- -- Copy_Elist_With_Replacement -- Copy_List_With_Replacement -- Copy_Node_With_Replacement -- Corresponding_Entity -- -- If the field is not an entity list, entity, itype, syntactic list, -- or node, then the field is returned unchanged. The routine always -- replicates entities, itypes, and valid syntactic fields. Old_Par is -- the expected parent of a syntactic field. New_Par is the new parent -- associated with a replicated syntactic field. Flag Semantic should -- be set when the input is a semantic field. function Copy_List_With_Replacement (List : List_Id) return List_Id; -- Replicate the elements of syntactic list List function Copy_Node_With_Replacement (N : Node_Id) return Node_Id; -- Replicate node N function Corresponding_Entity (Id : Entity_Id) return Entity_Id; pragma Inline (Corresponding_Entity); -- Return the corresponding new entity of Id generated during Phase 1. -- If there is no such entity, return Id. function In_Entity_Map (Id : Entity_Id; Entity_Map : Elist_Id) return Boolean; pragma Inline (In_Entity_Map); -- Determine whether entity Id is one of the old ids specified in entity -- map Entity_Map. The format of the entity map must be as follows: -- -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN procedure Update_CFS_Sloc (N : Node_Or_Entity_Id); pragma Inline (Update_CFS_Sloc); -- Update the Comes_From_Source and Sloc attributes of node or entity N procedure Update_First_Real_Statement (Old_HSS : Node_Id; New_HSS : Node_Id); pragma Inline (Update_First_Real_Statement); -- Update semantic attribute First_Real_Statement of handled sequence of -- statements New_HSS based on handled sequence of statements Old_HSS. procedure Update_Named_Associations (Old_Call : Node_Id; New_Call : Node_Id); pragma Inline (Update_Named_Associations); -- Update semantic chain First/Next_Named_Association of call New_call -- based on call Old_Call. procedure Update_New_Entities (Entity_Map : Elist_Id); pragma Inline (Update_New_Entities); -- Update the semantic attributes of all new entities generated during -- Phase 1 that do not appear in entity map Entity_Map. The format of -- the entity map must be as follows: -- -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN procedure Update_Pending_Itypes (Old_Assoc : Node_Id; New_Assoc : Node_Id); pragma Inline (Update_Pending_Itypes); -- Update semantic attribute Associated_Node_For_Itype to refer to node -- New_Assoc for all itypes whose associated node is Old_Assoc. procedure Update_Semantic_Fields (Id : Entity_Id); pragma Inline (Update_Semantic_Fields); -- Subsidiary to Update_New_Entities. Update semantic fields of entity -- or itype Id. procedure Visit_Any_Node (N : Node_Or_Entity_Id); pragma Inline (Visit_Any_Node); -- Visit entity of node N by invoking one of the following routines: -- -- Visit_Entity -- Visit_Itype -- Visit_Node procedure Visit_Elist (List : Elist_Id); -- Visit the elements of entity list List procedure Visit_Entity (Id : Entity_Id); -- Visit entity Id. This action may create a new entity of Id and save -- it in table NCT_New_Entities. procedure Visit_Field (Field : Union_Id; Par_Nod : Node_Id := Empty; Semantic : Boolean := False); -- Visit field Field by invoking one of the following routines: -- -- Visit_Elist -- Visit_Entity -- Visit_Itype -- Visit_List -- Visit_Node -- -- If the field is not an entity list, entity, itype, syntactic list, -- or node, then the field is not visited. The routine always visits -- valid syntactic fields. Par_Nod is the expected parent of the -- syntactic field. Flag Semantic should be set when the input is a -- semantic field. procedure Visit_Itype (Itype : Entity_Id); -- Visit itype Itype. This action may create a new entity for Itype and -- save it in table NCT_New_Entities. In addition, the routine may map -- the associated node of Itype to the new itype in NCT_Pending_Itypes. procedure Visit_List (List : List_Id); -- Visit the elements of syntactic list List procedure Visit_Node (N : Node_Id); -- Visit node N procedure Visit_Semantic_Fields (Id : Entity_Id); pragma Inline (Visit_Semantic_Fields); -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic -- fields of entity or itype Id. -------------------- -- Add_New_Entity -- -------------------- procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id) is begin pragma Assert (Present (Old_Id)); pragma Assert (Present (New_Id)); pragma Assert (Nkind (Old_Id) in N_Entity); pragma Assert (Nkind (New_Id) in N_Entity); NCT_Tables_In_Use := True; -- Sanity check the NCT_New_Entities table. No previous mapping with -- key Old_Id should exist. pragma Assert (No (NCT_New_Entities.Get (Old_Id))); -- Establish the mapping -- Old_Id -> New_Id NCT_New_Entities.Set (Old_Id, New_Id); end Add_New_Entity; ----------------------- -- Add_Pending_Itype -- ----------------------- procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id) is Itypes : Elist_Id; begin pragma Assert (Present (Assoc_Nod)); pragma Assert (Present (Itype)); pragma Assert (Nkind (Itype) in N_Entity); pragma Assert (Is_Itype (Itype)); NCT_Tables_In_Use := True; -- It is not possible to sanity check the NCT_Pendint_Itypes table -- directly because a single node may act as the associated node for -- multiple itypes. Itypes := NCT_Pending_Itypes.Get (Assoc_Nod); if No (Itypes) then Itypes := New_Elmt_List; NCT_Pending_Itypes.Set (Assoc_Nod, Itypes); end if; -- Establish the mapping -- Assoc_Nod -> (Itype, ...) -- Avoid inserting the same itype multiple times. This involves a -- linear search, however the set of itypes with the same associated -- node is very small. Append_Unique_Elmt (Itype, Itypes); end Add_Pending_Itype; ---------------------- -- Build_NCT_Tables -- ---------------------- procedure Build_NCT_Tables (Entity_Map : Elist_Id) is Elmt : Elmt_Id; Old_Id : Entity_Id; New_Id : Entity_Id; begin -- Nothing to do when there is no entity map if No (Entity_Map) then return; end if; Elmt := First_Elmt (Entity_Map); while Present (Elmt) loop -- Extract the (Old_Id, New_Id) pair from the entity map Old_Id := Node (Elmt); Next_Elmt (Elmt); New_Id := Node (Elmt); Next_Elmt (Elmt); -- Establish the following mapping within table NCT_New_Entities -- Old_Id -> New_Id Add_New_Entity (Old_Id, New_Id); -- Establish the following mapping within table NCT_Pending_Itypes -- when the new entity is an itype. -- Assoc_Nod -> (New_Id, ...) -- IMPORTANT: the associated node is that of the old itype because -- the node will be replicated in Phase 2. if Is_Itype (Old_Id) then Add_Pending_Itype (Assoc_Nod => Associated_Node_For_Itype (Old_Id), Itype => New_Id); end if; end loop; end Build_NCT_Tables; ------------------------------------ -- Copy_Any_Node_With_Replacement -- ------------------------------------ function Copy_Any_Node_With_Replacement (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is begin if Nkind (N) in N_Entity then return Corresponding_Entity (N); else return Copy_Node_With_Replacement (N); end if; end Copy_Any_Node_With_Replacement; --------------------------------- -- Copy_Elist_With_Replacement -- --------------------------------- function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id is Elmt : Elmt_Id; Result : Elist_Id; begin -- Copy the contents of the old list. Note that the list itself may -- be empty, in which case the routine returns a new empty list. This -- avoids sharing lists between subtrees. The element of an entity -- list could be an entity or a node, hence the invocation of routine -- Copy_Any_Node_With_Replacement. if Present (List) then Result := New_Elmt_List; Elmt := First_Elmt (List); while Present (Elmt) loop Append_Elmt (Copy_Any_Node_With_Replacement (Node (Elmt)), Result); Next_Elmt (Elmt); end loop; -- Otherwise the list does not exist else Result := No_Elist; end if; return Result; end Copy_Elist_With_Replacement; --------------------------------- -- Copy_Field_With_Replacement -- --------------------------------- function Copy_Field_With_Replacement (Field : Union_Id; Old_Par : Node_Id := Empty; New_Par : Node_Id := Empty; Semantic : Boolean := False) return Union_Id is function Has_More_Ids (N : Node_Id) return Boolean; -- Return True when N has attribute More_Ids set to True function Is_Syntactic_Node return Boolean; -- Return True when Field is a syntactic node ------------------ -- Has_More_Ids -- ------------------ function Has_More_Ids (N : Node_Id) return Boolean is begin if Nkind (N) in N_Component_Declaration | N_Discriminant_Specification | N_Exception_Declaration | N_Formal_Object_Declaration | N_Number_Declaration | N_Object_Declaration | N_Parameter_Specification | N_Use_Package_Clause | N_Use_Type_Clause then return More_Ids (N); else return False; end if; end Has_More_Ids; ----------------------- -- Is_Syntactic_Node -- ----------------------- function Is_Syntactic_Node return Boolean is Old_N : constant Node_Id := Node_Id (Field); begin if Parent (Old_N) = Old_Par then return True; elsif not Has_More_Ids (Old_Par) then return False; -- Perform the check using the last last id in the syntactic chain else declare N : Node_Id := Old_Par; begin while Present (N) and then More_Ids (N) loop Next (N); end loop; pragma Assert (Prev_Ids (N)); return Parent (Old_N) = N; end; end if; end Is_Syntactic_Node; begin -- The field is empty if Field = Union_Id (Empty) then return Field; -- The field is an entity/itype/node elsif Field in Node_Range then declare Old_N : constant Node_Id := Node_Id (Field); Syntactic : constant Boolean := Is_Syntactic_Node; New_N : Node_Id; begin -- The field is an entity/itype if Nkind (Old_N) in N_Entity then -- An entity/itype is always replicated New_N := Corresponding_Entity (Old_N); -- Update the parent pointer when the entity is a syntactic -- field. Note that itypes do not have parent pointers. if Syntactic and then New_N /= Old_N then Set_Parent (New_N, New_Par); end if; -- The field is a node else -- A node is replicated when it is either a syntactic field -- or when the caller treats it as a semantic attribute. if Syntactic or else Semantic then New_N := Copy_Node_With_Replacement (Old_N); -- Update the parent pointer when the node is a syntactic -- field. if Syntactic and then New_N /= Old_N then Set_Parent (New_N, New_Par); end if; -- Otherwise the node is returned unchanged else New_N := Old_N; end if; end if; return Union_Id (New_N); end; -- The field is an entity list elsif Field in Elist_Range then return Union_Id (Copy_Elist_With_Replacement (Elist_Id (Field))); -- The field is a syntactic list elsif Field in List_Range then declare Old_List : constant List_Id := List_Id (Field); Syntactic : constant Boolean := Parent (Old_List) = Old_Par; New_List : List_Id; begin -- A list is replicated when it is either a syntactic field or -- when the caller treats it as a semantic attribute. if Syntactic or else Semantic then New_List := Copy_List_With_Replacement (Old_List); -- Update the parent pointer when the list is a syntactic -- field. if Syntactic and then New_List /= Old_List then Set_Parent (New_List, New_Par); end if; -- Otherwise the list is returned unchanged else New_List := Old_List; end if; return Union_Id (New_List); end; -- Otherwise the field denotes an attribute that does not need to be -- replicated (Chars, literals, etc). else return Field; end if; end Copy_Field_With_Replacement; -------------------------------- -- Copy_List_With_Replacement -- -------------------------------- function Copy_List_With_Replacement (List : List_Id) return List_Id is Elmt : Node_Id; Result : List_Id; begin -- Copy the contents of the old list. Note that the list itself may -- be empty, in which case the routine returns a new empty list. This -- avoids sharing lists between subtrees. The element of a syntactic -- list is always a node, never an entity or itype, hence the call to -- routine Copy_Node_With_Replacement. if Present (List) then Result := New_List; Elmt := First (List); while Present (Elmt) loop Append (Copy_Node_With_Replacement (Elmt), Result); Next (Elmt); end loop; -- Otherwise the list does not exist else Result := No_List; end if; return Result; end Copy_List_With_Replacement; -------------------------------- -- Copy_Node_With_Replacement -- -------------------------------- function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is Result : Node_Id; begin -- Assume that the node must be returned unchanged Result := N; if N > Empty_Or_Error then pragma Assert (Nkind (N) not in N_Entity); Result := New_Copy (N); Set_Field1 (Result, Copy_Field_With_Replacement (Field => Field1 (Result), Old_Par => N, New_Par => Result)); Set_Field2 (Result, Copy_Field_With_Replacement (Field => Field2 (Result), Old_Par => N, New_Par => Result)); Set_Field3 (Result, Copy_Field_With_Replacement (Field => Field3 (Result), Old_Par => N, New_Par => Result)); Set_Field4 (Result, Copy_Field_With_Replacement (Field => Field4 (Result), Old_Par => N, New_Par => Result)); Set_Field5 (Result, Copy_Field_With_Replacement (Field => Field5 (Result), Old_Par => N, New_Par => Result)); -- Update the Comes_From_Source and Sloc attributes of the node -- in case the caller has supplied new values. Update_CFS_Sloc (Result); -- Update the Associated_Node_For_Itype attribute of all itypes -- created during Phase 1 whose associated node is N. As a result -- the Associated_Node_For_Itype refers to the replicated node. -- No action needs to be taken when the Associated_Node_For_Itype -- refers to an entity because this was already handled during -- Phase 1, in Visit_Itype. Update_Pending_Itypes (Old_Assoc => N, New_Assoc => Result); -- Update the First/Next_Named_Association chain for a replicated -- call. if Nkind (N) in N_Entry_Call_Statement | N_Function_Call | N_Procedure_Call_Statement then Update_Named_Associations (Old_Call => N, New_Call => Result); -- Update the Renamed_Object attribute of a replicated object -- declaration. elsif Nkind (N) = N_Object_Renaming_Declaration then Set_Renamed_Object (Defining_Entity (Result), Name (Result)); -- Update the First_Real_Statement attribute of a replicated -- handled sequence of statements. elsif Nkind (N) = N_Handled_Sequence_Of_Statements then Update_First_Real_Statement (Old_HSS => N, New_HSS => Result); -- Update the Chars attribute of identifiers elsif Nkind (N) = N_Identifier then -- The Entity field of identifiers that denote aspects is used -- to store arbitrary expressions (and hence we must check that -- they reference an actual entity before copying their Chars -- value). if Present (Entity (Result)) and then Nkind (Entity (Result)) in N_Entity then Set_Chars (Result, Chars (Entity (Result))); end if; end if; if Has_Aspects (N) then Set_Aspect_Specifications (Result, Copy_List_With_Replacement (Aspect_Specifications (N))); end if; end if; return Result; end Copy_Node_With_Replacement; -------------------------- -- Corresponding_Entity -- -------------------------- function Corresponding_Entity (Id : Entity_Id) return Entity_Id is New_Id : Entity_Id; Result : Entity_Id; begin -- Assume that the entity must be returned unchanged Result := Id; if Id > Empty_Or_Error then pragma Assert (Nkind (Id) in N_Entity); -- Determine whether the entity has a corresponding new entity -- generated during Phase 1 and if it does, use it. if NCT_Tables_In_Use then New_Id := NCT_New_Entities.Get (Id); if Present (New_Id) then Result := New_Id; end if; end if; end if; return Result; end Corresponding_Entity; ------------------- -- In_Entity_Map -- ------------------- function In_Entity_Map (Id : Entity_Id; Entity_Map : Elist_Id) return Boolean is Elmt : Elmt_Id; Old_Id : Entity_Id; begin -- The entity map contains pairs (Old_Id, New_Id). The advancement -- step always skips the New_Id portion of the pair. if Present (Entity_Map) then Elmt := First_Elmt (Entity_Map); while Present (Elmt) loop Old_Id := Node (Elmt); if Old_Id = Id then return True; end if; Next_Elmt (Elmt); Next_Elmt (Elmt); end loop; end if; return False; end In_Entity_Map; --------------------- -- Update_CFS_Sloc -- --------------------- procedure Update_CFS_Sloc (N : Node_Or_Entity_Id) is begin -- A new source location defaults the Comes_From_Source attribute if New_Sloc /= No_Location then Set_Comes_From_Source (N, Default_Node.Comes_From_Source); Set_Sloc (N, New_Sloc); end if; end Update_CFS_Sloc; --------------------------------- -- Update_First_Real_Statement -- --------------------------------- procedure Update_First_Real_Statement (Old_HSS : Node_Id; New_HSS : Node_Id) is Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS); New_Stmt : Node_Id; Old_Stmt : Node_Id; begin -- Recreate the First_Real_Statement attribute of a handled sequence -- of statements by traversing the statement lists of both sequences -- in parallel. if Present (Old_First_Stmt) then New_Stmt := First (Statements (New_HSS)); Old_Stmt := First (Statements (Old_HSS)); while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop Next (New_Stmt); Next (Old_Stmt); end loop; pragma Assert (Present (New_Stmt)); pragma Assert (Present (Old_Stmt)); Set_First_Real_Statement (New_HSS, New_Stmt); end if; end Update_First_Real_Statement; ------------------------------- -- Update_Named_Associations -- ------------------------------- procedure Update_Named_Associations (Old_Call : Node_Id; New_Call : Node_Id) is New_Act : Node_Id; New_Next : Node_Id; Old_Act : Node_Id; Old_Next : Node_Id; begin if No (First_Named_Actual (Old_Call)) then return; end if; -- Recreate the First/Next_Named_Actual chain of a call by traversing -- the chains of both the old and new calls in parallel. New_Act := First (Parameter_Associations (New_Call)); Old_Act := First (Parameter_Associations (Old_Call)); while Present (Old_Act) loop if Nkind (Old_Act) = N_Parameter_Association and then Explicit_Actual_Parameter (Old_Act) = First_Named_Actual (Old_Call) then Set_First_Named_Actual (New_Call, Explicit_Actual_Parameter (New_Act)); end if; if Nkind (Old_Act) = N_Parameter_Association and then Present (Next_Named_Actual (Old_Act)) then -- Scan the actual parameter list to find the next suitable -- named actual. Note that the list may be out of order. New_Next := First (Parameter_Associations (New_Call)); Old_Next := First (Parameter_Associations (Old_Call)); while Nkind (Old_Next) /= N_Parameter_Association or else Explicit_Actual_Parameter (Old_Next) /= Next_Named_Actual (Old_Act) loop Next (New_Next); Next (Old_Next); end loop; Set_Next_Named_Actual (New_Act, Explicit_Actual_Parameter (New_Next)); end if; Next (New_Act); Next (Old_Act); end loop; end Update_Named_Associations; ------------------------- -- Update_New_Entities -- ------------------------- procedure Update_New_Entities (Entity_Map : Elist_Id) is New_Id : Entity_Id := Empty; Old_Id : Entity_Id := Empty; begin if NCT_Tables_In_Use then NCT_New_Entities.Get_First (Old_Id, New_Id); -- Update the semantic fields of all new entities created during -- Phase 1 which were not supplied via an entity map. -- ??? Is there a better way of distinguishing those? while Present (Old_Id) and then Present (New_Id) loop if not (Present (Entity_Map) and then In_Entity_Map (Old_Id, Entity_Map)) then Update_Semantic_Fields (New_Id); end if; NCT_New_Entities.Get_Next (Old_Id, New_Id); end loop; end if; end Update_New_Entities; --------------------------- -- Update_Pending_Itypes -- --------------------------- procedure Update_Pending_Itypes (Old_Assoc : Node_Id; New_Assoc : Node_Id) is Item : Elmt_Id; Itypes : Elist_Id; begin if NCT_Tables_In_Use then Itypes := NCT_Pending_Itypes.Get (Old_Assoc); -- Update the Associated_Node_For_Itype attribute for all itypes -- which originally refer to Old_Assoc to designate New_Assoc. if Present (Itypes) then Item := First_Elmt (Itypes); while Present (Item) loop Set_Associated_Node_For_Itype (Node (Item), New_Assoc); Next_Elmt (Item); end loop; end if; end if; end Update_Pending_Itypes; ---------------------------- -- Update_Semantic_Fields -- ---------------------------- procedure Update_Semantic_Fields (Id : Entity_Id) is begin -- Discriminant_Constraint if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then Set_Discriminant_Constraint (Id, Elist_Id ( Copy_Field_With_Replacement (Field => Union_Id (Discriminant_Constraint (Id)), Semantic => True))); end if; -- Etype Set_Etype (Id, Node_Id ( Copy_Field_With_Replacement (Field => Union_Id (Etype (Id)), Semantic => True))); -- First_Index -- Packed_Array_Impl_Type if Is_Array_Type (Id) then if Present (First_Index (Id)) then Set_First_Index (Id, First (List_Id ( Copy_Field_With_Replacement (Field => Union_Id (List_Containing (First_Index (Id))), Semantic => True)))); end if; if Is_Packed (Id) then Set_Packed_Array_Impl_Type (Id, Node_Id ( Copy_Field_With_Replacement (Field => Union_Id (Packed_Array_Impl_Type (Id)), Semantic => True))); end if; end if; -- Prev_Entity Set_Prev_Entity (Id, Node_Id ( Copy_Field_With_Replacement (Field => Union_Id (Prev_Entity (Id)), Semantic => True))); -- Next_Entity Set_Next_Entity (Id, Node_Id ( Copy_Field_With_Replacement (Field => Union_Id (Next_Entity (Id)), Semantic => True))); -- Scalar_Range if Is_Discrete_Type (Id) then Set_Scalar_Range (Id, Node_Id ( Copy_Field_With_Replacement (Field => Union_Id (Scalar_Range (Id)), Semantic => True))); end if; -- Scope -- Update the scope when the caller specified an explicit one if Present (New_Scope) then Set_Scope (Id, New_Scope); else Set_Scope (Id, Node_Id ( Copy_Field_With_Replacement (Field => Union_Id (Scope (Id)), Semantic => True))); end if; end Update_Semantic_Fields; -------------------- -- Visit_Any_Node -- -------------------- procedure Visit_Any_Node (N : Node_Or_Entity_Id) is begin if Nkind (N) in N_Entity then if Is_Itype (N) then Visit_Itype (N); else Visit_Entity (N); end if; else Visit_Node (N); end if; end Visit_Any_Node; ----------------- -- Visit_Elist -- ----------------- procedure Visit_Elist (List : Elist_Id) is Elmt : Elmt_Id; begin -- The element of an entity list could be an entity, itype, or a -- node, hence the call to Visit_Any_Node. if Present (List) then Elmt := First_Elmt (List); while Present (Elmt) loop Visit_Any_Node (Node (Elmt)); Next_Elmt (Elmt); end loop; end if; end Visit_Elist; ------------------ -- Visit_Entity -- ------------------ procedure Visit_Entity (Id : Entity_Id) is New_Id : Entity_Id; begin pragma Assert (Nkind (Id) in N_Entity); pragma Assert (not Is_Itype (Id)); -- Nothing to do when the entity is not defined in the Actions list -- of an N_Expression_With_Actions node. if EWA_Level = 0 then return; -- Nothing to do when the entity is defined in a scoping construct -- within an N_Expression_With_Actions node, unless the caller has -- requested their replication. -- ??? should this restriction be eliminated? elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then return; -- Nothing to do when the entity does not denote a construct that -- may appear within an N_Expression_With_Actions node. Relaxing -- this restriction leads to a performance penalty. -- ??? this list is flaky, and may hide dormant bugs -- Should functions be included??? -- Loop parameters appear within quantified expressions and contain -- an entity declaration that must be replaced when the expander is -- active if the expression has been preanalyzed or analyzed. elsif Ekind (Id) not in E_Block | E_Constant | E_Label | E_Loop_Parameter | E_Procedure | E_Variable and then not Is_Type (Id) then return; elsif Ekind (Id) = E_Loop_Parameter and then No (Etype (Condition (Parent (Parent (Id))))) then return; -- Nothing to do when the entity was already visited elsif NCT_Tables_In_Use and then Present (NCT_New_Entities.Get (Id)) then return; -- Nothing to do when the declaration node of the entity is not in -- the subtree being replicated. elsif not In_Subtree (N => Declaration_Node (Id), Root => Source) then return; end if; -- Create a new entity by directly copying the old entity. This -- action causes all attributes of the old entity to be inherited. New_Id := New_Copy (Id); -- Create a new name for the new entity because the back end needs -- distinct names for debugging purposes. Set_Chars (New_Id, New_Internal_Name ('T')); -- Update the Comes_From_Source and Sloc attributes of the entity in -- case the caller has supplied new values. Update_CFS_Sloc (New_Id); -- Establish the following mapping within table NCT_New_Entities: -- Id -> New_Id Add_New_Entity (Id, New_Id); -- Deal with the semantic fields of entities. The fields are visited -- because they may mention entities which reside within the subtree -- being copied. Visit_Semantic_Fields (Id); end Visit_Entity; ----------------- -- Visit_Field -- ----------------- procedure Visit_Field (Field : Union_Id; Par_Nod : Node_Id := Empty; Semantic : Boolean := False) is begin -- The field is empty if Field = Union_Id (Empty) then return; -- The field is an entity/itype/node elsif Field in Node_Range then declare N : constant Node_Id := Node_Id (Field); begin -- The field is an entity/itype if Nkind (N) in N_Entity then -- Itypes are always visited if Is_Itype (N) then Visit_Itype (N); -- An entity is visited when it is either a syntactic field -- or when the caller treats it as a semantic attribute. elsif Parent (N) = Par_Nod or else Semantic then Visit_Entity (N); end if; -- The field is a node else -- A node is visited when it is either a syntactic field or -- when the caller treats it as a semantic attribute. if Parent (N) = Par_Nod or else Semantic then Visit_Node (N); end if; end if; end; -- The field is an entity list elsif Field in Elist_Range then Visit_Elist (Elist_Id (Field)); -- The field is a syntax list elsif Field in List_Range then declare List : constant List_Id := List_Id (Field); begin -- A syntax list is visited when it is either a syntactic field -- or when the caller treats it as a semantic attribute. if Parent (List) = Par_Nod or else Semantic then Visit_List (List); end if; end; -- Otherwise the field denotes information which does not need to be -- visited (chars, literals, etc.). else null; end if; end Visit_Field; ----------------- -- Visit_Itype -- ----------------- procedure Visit_Itype (Itype : Entity_Id) is New_Assoc : Node_Id; New_Itype : Entity_Id; Old_Assoc : Node_Id; begin pragma Assert (Nkind (Itype) in N_Entity); pragma Assert (Is_Itype (Itype)); -- Itypes that describe the designated type of access to subprograms -- have the structure of subprogram declarations, with signatures, -- etc. Either we duplicate the signatures completely, or choose to -- share such itypes, which is fine because their elaboration will -- have no side effects. if Ekind (Itype) = E_Subprogram_Type then return; -- Nothing to do if the itype was already visited elsif NCT_Tables_In_Use and then Present (NCT_New_Entities.Get (Itype)) then return; -- Nothing to do if the associated node of the itype is not within -- the subtree being replicated. elsif not In_Subtree (N => Associated_Node_For_Itype (Itype), Root => Source) then return; end if; -- Create a new itype by directly copying the old itype. This action -- causes all attributes of the old itype to be inherited. New_Itype := New_Copy (Itype); -- Create a new name for the new itype because the back end requires -- distinct names for debugging purposes. Set_Chars (New_Itype, New_Internal_Name ('T')); -- Update the Comes_From_Source and Sloc attributes of the itype in -- case the caller has supplied new values. Update_CFS_Sloc (New_Itype); -- Establish the following mapping within table NCT_New_Entities: -- Itype -> New_Itype Add_New_Entity (Itype, New_Itype); -- The new itype must be unfrozen because the resulting subtree may -- be inserted anywhere and cause an earlier or later freezing. if Present (Freeze_Node (New_Itype)) then Set_Freeze_Node (New_Itype, Empty); Set_Is_Frozen (New_Itype, False); end if; -- If a record subtype is simply copied, the entity list will be -- shared. Thus cloned_Subtype must be set to indicate the sharing. -- ??? What does this do? if Ekind (Itype) in E_Class_Wide_Subtype | E_Record_Subtype then Set_Cloned_Subtype (New_Itype, Itype); end if; -- The associated node may denote an entity, in which case it may -- already have a new corresponding entity created during a prior -- call to Visit_Entity or Visit_Itype for the same subtree. -- Given -- Old_Assoc ---------> New_Assoc -- Created by Visit_Itype -- Itype -------------> New_Itype -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated -- In the example above, Old_Assoc is an arbitrary entity that was -- already visited for the same subtree and has a corresponding new -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue -- of copying entities, however it must be updated to New_Assoc. Old_Assoc := Associated_Node_For_Itype (Itype); if Nkind (Old_Assoc) in N_Entity then if NCT_Tables_In_Use then New_Assoc := NCT_New_Entities.Get (Old_Assoc); if Present (New_Assoc) then Set_Associated_Node_For_Itype (New_Itype, New_Assoc); end if; end if; -- Otherwise the associated node denotes a node. Postpone the update -- until Phase 2 when the node is replicated. Establish the following -- mapping within table NCT_Pending_Itypes: -- Old_Assoc -> (New_Type, ...) else Add_Pending_Itype (Old_Assoc, New_Itype); end if; -- Deal with the semantic fields of itypes. The fields are visited -- because they may mention entities that reside within the subtree -- being copied. Visit_Semantic_Fields (Itype); end Visit_Itype; ---------------- -- Visit_List -- ---------------- procedure Visit_List (List : List_Id) is Elmt : Node_Id; begin -- Note that the element of a syntactic list is always a node, never -- an entity or itype, hence the call to Visit_Node. if Present (List) then Elmt := First (List); while Present (Elmt) loop Visit_Node (Elmt); Next (Elmt); end loop; end if; end Visit_List; ---------------- -- Visit_Node -- ---------------- procedure Visit_Node (N : Node_Or_Entity_Id) is begin pragma Assert (Nkind (N) not in N_Entity); -- If the node is a quantified expression and expander is active, -- it contains an implicit declaration that may require a new entity -- when the condition has already been (pre)analyzed. if Nkind (N) = N_Expression_With_Actions or else (Nkind (N) = N_Quantified_Expression and then Expander_Active) then EWA_Level := EWA_Level + 1; elsif EWA_Level > 0 and then Nkind (N) in N_Block_Statement | N_Subprogram_Body | N_Subprogram_Declaration then EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; end if; Visit_Field (Field => Field1 (N), Par_Nod => N); Visit_Field (Field => Field2 (N), Par_Nod => N); Visit_Field (Field => Field3 (N), Par_Nod => N); Visit_Field (Field => Field4 (N), Par_Nod => N); Visit_Field (Field => Field5 (N), Par_Nod => N); if EWA_Level > 0 and then Nkind (N) in N_Block_Statement | N_Subprogram_Body | N_Subprogram_Declaration then EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1; elsif Nkind (N) = N_Expression_With_Actions then EWA_Level := EWA_Level - 1; end if; end Visit_Node; --------------------------- -- Visit_Semantic_Fields -- --------------------------- procedure Visit_Semantic_Fields (Id : Entity_Id) is begin pragma Assert (Nkind (Id) in N_Entity); -- Discriminant_Constraint if Is_Type (Id) and then Has_Discriminants (Base_Type (Id)) then Visit_Field (Field => Union_Id (Discriminant_Constraint (Id)), Semantic => True); end if; -- Etype Visit_Field (Field => Union_Id (Etype (Id)), Semantic => True); -- First_Index -- Packed_Array_Impl_Type if Is_Array_Type (Id) then if Present (First_Index (Id)) then Visit_Field (Field => Union_Id (List_Containing (First_Index (Id))), Semantic => True); end if; if Is_Packed (Id) then Visit_Field (Field => Union_Id (Packed_Array_Impl_Type (Id)), Semantic => True); end if; end if; -- Scalar_Range if Is_Discrete_Type (Id) then Visit_Field (Field => Union_Id (Scalar_Range (Id)), Semantic => True); end if; end Visit_Semantic_Fields; -- Start of processing for New_Copy_Tree begin -- Routine New_Copy_Tree performs a deep copy of a subtree by creating -- shallow copies for each node within, and then updating the child and -- parent pointers accordingly. This process is straightforward, however -- the routine must deal with the following complications: -- * Entities defined within N_Expression_With_Actions nodes must be -- replicated rather than shared to avoid introducing two identical -- symbols within the same scope. Note that no other expression can -- currently define entities. -- do -- Source_Low : ...; -- Source_High : ...; -- -- -- in ... end; -- New_Copy_Tree handles this case by first creating new entities -- and then updating all existing references to point to these new -- entities. -- do -- New_Low : ...; -- New_High : ...; -- -- -- in ... end; -- * Itypes defined within the subtree must be replicated to avoid any -- dependencies on invalid or inaccessible data. -- subtype Source_Itype is ... range Source_Low .. Source_High; -- New_Copy_Tree handles this case by first creating a new itype in -- the same fashion as entities, and then updating various relevant -- constraints. -- subtype New_Itype is ... range New_Low .. New_High; -- * The Associated_Node_For_Itype field of itypes must be updated to -- reference the proper replicated entity or node. -- * Semantic fields of entities such as Etype and Scope must be -- updated to reference the proper replicated entities. -- * Semantic fields of nodes such as First_Real_Statement must be -- updated to reference the proper replicated nodes. -- Finally, quantified expressions contain an implicit delaration for -- the bound variable. Given that quantified expressions appearing -- in contracts are copied to create pragmas and eventually checking -- procedures, a new bound variable must be created for each copy, to -- prevent multiple declarations of the same symbol. -- To meet all these demands, routine New_Copy_Tree is split into two -- phases. -- Phase 1 traverses the tree in order to locate entities and itypes -- defined within the subtree. New entities are generated and saved in -- table NCT_New_Entities. The semantic fields of all new entities and -- itypes are then updated accordingly. -- Phase 2 traverses the tree in order to replicate each node. Various -- semantic fields of nodes and entities are updated accordingly. -- Preparatory phase. Clear the contents of tables NCT_New_Entities and -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some -- data inside. if NCT_Tables_In_Use then NCT_Tables_In_Use := False; NCT_New_Entities.Reset; NCT_Pending_Itypes.Reset; end if; -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data -- supplied by a linear entity map. The tables offer faster access to -- the same data. Build_NCT_Tables (Map); -- Execute Phase 1. Traverse the subtree and generate new entities for -- the following cases: -- * An entity defined within an N_Expression_With_Actions node -- * An itype referenced within the subtree where the associated node -- is also in the subtree. -- All new entities are accessible via table NCT_New_Entities, which -- contains mappings of the form: -- Old_Entity -> New_Entity -- Old_Itype -> New_Itype -- In addition, the associated nodes of all new itypes are mapped in -- table NCT_Pending_Itypes: -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN) Visit_Any_Node (Source); -- Update the semantic attributes of all new entities generated during -- Phase 1 before starting Phase 2. The updates could be performed in -- routine Corresponding_Entity, however this may cause the same entity -- to be updated multiple times, effectively generating useless nodes. -- Keeping the updates separates from Phase 2 ensures that only one set -- of attributes is generated for an entity at any one time. Update_New_Entities (Map); -- Execute Phase 2. Replicate the source subtree one node at a time. -- The following transformations take place: -- * References to entities and itypes are updated to refer to the -- new entities and itypes generated during Phase 1. -- * All Associated_Node_For_Itype attributes of itypes are updated -- to refer to the new replicated Associated_Node_For_Itype. return Copy_Node_With_Replacement (Source); end New_Copy_Tree; ------------------------- -- New_External_Entity -- ------------------------- function New_External_Entity (Kind : Entity_Kind; Scope_Id : Entity_Id; Sloc_Value : Source_Ptr; Related_Id : Entity_Id; Suffix : Character; Suffix_Index : Int := 0; Prefix : Character := ' ') return Entity_Id is N : constant Entity_Id := Make_Defining_Identifier (Sloc_Value, New_External_Name (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); begin Set_Ekind (N, Kind); Set_Is_Internal (N, True); Append_Entity (N, Scope_Id); Set_Public_Status (N); if Kind in Type_Kind then Init_Size_Align (N); end if; return N; end New_External_Entity; ------------------------- -- New_Internal_Entity -- ------------------------- function New_Internal_Entity (Kind : Entity_Kind; Scope_Id : Entity_Id; Sloc_Value : Source_Ptr; Id_Char : Character) return Entity_Id is N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); begin Set_Ekind (N, Kind); Set_Is_Internal (N, True); Append_Entity (N, Scope_Id); if Kind in Type_Kind then Init_Size_Align (N); end if; return N; end New_Internal_Entity; ----------------- -- Next_Actual -- ----------------- function Next_Actual (Actual_Id : Node_Id) return Node_Id is Par : constant Node_Id := Parent (Actual_Id); N : Node_Id; begin -- If we are pointing at a positional parameter, it is a member of a -- node list (the list of parameters), and the next parameter is the -- next node on the list, unless we hit a parameter association, then -- we shift to using the chain whose head is the First_Named_Actual in -- the parent, and then is threaded using the Next_Named_Actual of the -- Parameter_Association. All this fiddling is because the original node -- list is in the textual call order, and what we need is the -- declaration order. if Is_List_Member (Actual_Id) then N := Next (Actual_Id); if Nkind (N) = N_Parameter_Association then -- In case of a build-in-place call, the call will no longer be a -- call; it will have been rewritten. if Nkind (Par) in N_Entry_Call_Statement | N_Function_Call | N_Procedure_Call_Statement then return First_Named_Actual (Par); -- In case of a call rewritten in GNATprove mode while "inlining -- for proof" go to the original call. elsif Nkind (Par) = N_Null_Statement then pragma Assert (GNATprove_Mode and then Nkind (Original_Node (Par)) in N_Subprogram_Call); return First_Named_Actual (Original_Node (Par)); else return Empty; end if; else return N; end if; else return Next_Named_Actual (Parent (Actual_Id)); end if; end Next_Actual; procedure Next_Actual (Actual_Id : in out Node_Id) is begin Actual_Id := Next_Actual (Actual_Id); end Next_Actual; ----------------- -- Next_Global -- ----------------- function Next_Global (Node : Node_Id) return Node_Id is begin -- The global item may either be in a list, or by itself, in which case -- there is no next global item with the same mode. if Is_List_Member (Node) then return Next (Node); else return Empty; end if; end Next_Global; procedure Next_Global (Node : in out Node_Id) is begin Node := Next_Global (Node); end Next_Global; ---------------------------------- -- New_Requires_Transient_Scope -- ---------------------------------- function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean; -- This is called for untagged records and protected types, with -- nondefaulted discriminants. Returns True if the size of function -- results is known at the call site, False otherwise. Returns False -- if there is a variant part that depends on the discriminants of -- this type, or if there is an array constrained by the discriminants -- of this type. ???Currently, this is overly conservative (the array -- could be nested inside some other record that is constrained by -- nondiscriminants). That is, the recursive calls are too conservative. function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; -- Returns True if Typ is a nonlimited record with defaulted -- discriminants whose max size makes it unsuitable for allocating on -- the primary stack. ------------------------------ -- Caller_Known_Size_Record -- ------------------------------ function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is pragma Assert (Typ = Underlying_Type (Typ)); begin if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then return False; end if; declare Comp : Entity_Id; begin Comp := First_Component (Typ); while Present (Comp) loop -- Only look at E_Component entities. No need to look at -- E_Discriminant entities, and we must ignore internal -- subtypes generated for constrained components. declare Comp_Type : constant Entity_Id := Underlying_Type (Etype (Comp)); begin if Is_Record_Type (Comp_Type) or else Is_Protected_Type (Comp_Type) then if not Caller_Known_Size_Record (Comp_Type) then return False; end if; elsif Is_Array_Type (Comp_Type) then if Size_Depends_On_Discriminant (Comp_Type) then return False; end if; end if; end; Next_Component (Comp); end loop; end; return True; end Caller_Known_Size_Record; ------------------------------ -- Large_Max_Size_Mutable -- ------------------------------ function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is pragma Assert (Typ = Underlying_Type (Typ)); function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; -- Returns true if the discrete type T has a large range ---------------------------- -- Is_Large_Discrete_Type -- ---------------------------- function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is Threshold : constant Int := 16; -- Arbitrary threshold above which we consider it "large". We want -- a fairly large threshold, because these large types really -- shouldn't have default discriminants in the first place, in -- most cases. begin return UI_To_Int (RM_Size (T)) > Threshold; end Is_Large_Discrete_Type; -- Start of processing for Large_Max_Size_Mutable begin if Is_Record_Type (Typ) and then not Is_Limited_View (Typ) and then Has_Defaulted_Discriminants (Typ) then -- Loop through the components, looking for an array whose upper -- bound(s) depends on discriminants, where both the subtype of -- the discriminant and the index subtype are too large. declare Comp : Entity_Id; begin Comp := First_Component (Typ); while Present (Comp) loop declare Comp_Type : constant Entity_Id := Underlying_Type (Etype (Comp)); Hi : Node_Id; Indx : Node_Id; Ityp : Entity_Id; begin if Is_Array_Type (Comp_Type) then Indx := First_Index (Comp_Type); while Present (Indx) loop Ityp := Etype (Indx); Hi := Type_High_Bound (Ityp); if Nkind (Hi) = N_Identifier and then Ekind (Entity (Hi)) = E_Discriminant and then Is_Large_Discrete_Type (Ityp) and then Is_Large_Discrete_Type (Etype (Entity (Hi))) then return True; end if; Next_Index (Indx); end loop; end if; end; Next_Component (Comp); end loop; end; end if; return False; end Large_Max_Size_Mutable; -- Local declarations Typ : constant Entity_Id := Underlying_Type (Id); -- Start of processing for New_Requires_Transient_Scope begin -- This is a private type which is not completed yet. This can only -- happen in a default expression (of a formal parameter or of a -- record component). Do not expand transient scope in this case. if No (Typ) then return False; -- Do not expand transient scope for non-existent procedure return or -- string literal types. elsif Typ = Standard_Void_Type or else Ekind (Typ) = E_String_Literal_Subtype then return False; -- If Typ is a generic formal incomplete type, then we want to look at -- the actual type. elsif Ekind (Typ) = E_Record_Subtype and then Present (Cloned_Subtype (Typ)) then return New_Requires_Transient_Scope (Cloned_Subtype (Typ)); -- Functions returning specific tagged types may dispatch on result, so -- their returned value is allocated on the secondary stack, even in the -- definite case. We must treat nondispatching functions the same way, -- because access-to-function types can point at both, so the calling -- conventions must be compatible. Is_Tagged_Type includes controlled -- types and class-wide types. Controlled type temporaries need -- finalization. -- ???It's not clear why we need to return noncontrolled types with -- controlled components on the secondary stack. elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then return True; -- Untagged definite subtypes are known size. This includes all -- elementary [sub]types. Tasks are known size even if they have -- discriminants. So we return False here, with one exception: -- For a type like: -- type T (Last : Natural := 0) is -- X : String (1 .. Last); -- end record; -- we return True. That's because for "P(F(...));", where F returns T, -- we don't know the size of the result at the call site, so if we -- allocated it on the primary stack, we would have to allocate the -- maximum size, which is way too big. elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then return Large_Max_Size_Mutable (Typ); -- Indefinite (discriminated) untagged record or protected type elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then return not Caller_Known_Size_Record (Typ); -- Unconstrained array else pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ)); return True; end if; end New_Requires_Transient_Scope; ------------------------ -- No_Caching_Enabled -- ------------------------ function No_Caching_Enabled (Id : Entity_Id) return Boolean is pragma Assert (Ekind (Id) = E_Variable); Prag : constant Node_Id := Get_Pragma (Id, Pragma_No_Caching); Arg1 : Node_Id; begin if Present (Prag) then Arg1 := First (Pragma_Argument_Associations (Prag)); -- The pragma has an optional Boolean expression, the related -- property is enabled only when the expression evaluates to True. if Present (Arg1) then return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); -- Otherwise the lack of expression enables the property by -- default. else return True; end if; -- The property was never set in the first place else return False; end if; end No_Caching_Enabled; -------------------------- -- No_Heap_Finalization -- -------------------------- function No_Heap_Finalization (Typ : Entity_Id) return Boolean is begin if Ekind (Typ) in E_Access_Type | E_General_Access_Type and then Is_Library_Level_Entity (Typ) then -- A global No_Heap_Finalization pragma applies to all library-level -- named access-to-object types. if Present (No_Heap_Finalization_Pragma) then return True; -- The library-level named access-to-object type itself is subject to -- pragma No_Heap_Finalization. elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then return True; end if; end if; return False; end No_Heap_Finalization; ----------------------- -- Normalize_Actuals -- ----------------------- -- Chain actuals according to formals of subprogram. If there are no named -- associations, the chain is simply the list of Parameter Associations, -- since the order is the same as the declaration order. If there are named -- associations, then the First_Named_Actual field in the N_Function_Call -- or N_Procedure_Call_Statement node points to the Parameter_Association -- node for the parameter that comes first in declaration order. The -- remaining named parameters are then chained in declaration order using -- Next_Named_Actual. -- This routine also verifies that the number of actuals is compatible with -- the number and default values of formals, but performs no type checking -- (type checking is done by the caller). -- If the matching succeeds, Success is set to True and the caller proceeds -- with type-checking. If the match is unsuccessful, then Success is set to -- False, and the caller attempts a different interpretation, if there is -- one. -- If the flag Report is on, the call is not overloaded, and a failure to -- match can be reported here, rather than in the caller. procedure Normalize_Actuals (N : Node_Id; S : Entity_Id; Report : Boolean; Success : out Boolean) is Actuals : constant List_Id := Parameter_Associations (N); Actual : Node_Id := Empty; Formal : Entity_Id; Last : Node_Id := Empty; First_Named : Node_Id := Empty; Found : Boolean; Formals_To_Match : Integer := 0; Actuals_To_Match : Integer := 0; procedure Chain (A : Node_Id); -- Add named actual at the proper place in the list, using the -- Next_Named_Actual link. function Reporting return Boolean; -- Determines if an error is to be reported. To report an error, we -- need Report to be True, and also we do not report errors caused -- by calls to init procs that occur within other init procs. Such -- errors must always be cascaded errors, since if all the types are -- declared correctly, the compiler will certainly build decent calls. ----------- -- Chain -- ----------- procedure Chain (A : Node_Id) is begin if No (Last) then -- Call node points to first actual in list Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); else Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); end if; Last := A; Set_Next_Named_Actual (Last, Empty); end Chain; --------------- -- Reporting -- --------------- function Reporting return Boolean is begin if not Report then return False; elsif not Within_Init_Proc then return True; elsif Is_Init_Proc (Entity (Name (N))) then return False; else return True; end if; end Reporting; -- Start of processing for Normalize_Actuals begin if Is_Access_Type (S) then -- The name in the call is a function call that returns an access -- to subprogram. The designated type has the list of formals. Formal := First_Formal (Designated_Type (S)); else Formal := First_Formal (S); end if; while Present (Formal) loop Formals_To_Match := Formals_To_Match + 1; Next_Formal (Formal); end loop; -- Find if there is a named association, and verify that no positional -- associations appear after named ones. if Present (Actuals) then Actual := First (Actuals); end if; while Present (Actual) and then Nkind (Actual) /= N_Parameter_Association loop Actuals_To_Match := Actuals_To_Match + 1; Next (Actual); end loop; if No (Actual) and Actuals_To_Match = Formals_To_Match then -- Most common case: positional notation, no defaults Success := True; return; elsif Actuals_To_Match > Formals_To_Match then -- Too many actuals: will not work if Reporting then if Is_Entity_Name (Name (N)) then Error_Msg_N ("too many arguments in call to&", Name (N)); else Error_Msg_N ("too many arguments in call", N); end if; end if; Success := False; return; end if; First_Named := Actual; while Present (Actual) loop if Nkind (Actual) /= N_Parameter_Association then Error_Msg_N ("positional parameters not allowed after named ones", Actual); Success := False; return; else Actuals_To_Match := Actuals_To_Match + 1; end if; Next (Actual); end loop; if Present (Actuals) then Actual := First (Actuals); end if; Formal := First_Formal (S); while Present (Formal) loop -- Match the formals in order. If the corresponding actual is -- positional, nothing to do. Else scan the list of named actuals -- to find the one with the right name. if Present (Actual) and then Nkind (Actual) /= N_Parameter_Association then Next (Actual); Actuals_To_Match := Actuals_To_Match - 1; Formals_To_Match := Formals_To_Match - 1; else -- For named parameters, search the list of actuals to find -- one that matches the next formal name. Actual := First_Named; Found := False; while Present (Actual) loop if Chars (Selector_Name (Actual)) = Chars (Formal) then Found := True; Chain (Actual); Actuals_To_Match := Actuals_To_Match - 1; Formals_To_Match := Formals_To_Match - 1; exit; end if; Next (Actual); end loop; if not Found then if Ekind (Formal) /= E_In_Parameter or else No (Default_Value (Formal)) then if Reporting then if (Comes_From_Source (S) or else Sloc (S) = Standard_Location) and then Is_Overloadable (S) then if No (Actuals) and then Nkind (Parent (N)) in N_Procedure_Call_Statement | N_Function_Call | N_Parameter_Association and then Ekind (S) /= E_Function then Set_Etype (N, Etype (S)); else Error_Msg_Name_1 := Chars (S); Error_Msg_Sloc := Sloc (S); Error_Msg_NE ("missing argument for parameter & " & "in call to % declared #", N, Formal); end if; elsif Is_Overloadable (S) then Error_Msg_Name_1 := Chars (S); -- Point to type derivation that generated the -- operation. Error_Msg_Sloc := Sloc (Parent (S)); Error_Msg_NE ("missing argument for parameter & " & "in call to % (inherited) #", N, Formal); else Error_Msg_NE ("missing argument for parameter &", N, Formal); end if; end if; Success := False; return; else Formals_To_Match := Formals_To_Match - 1; end if; end if; end if; Next_Formal (Formal); end loop; if Formals_To_Match = 0 and then Actuals_To_Match = 0 then Success := True; return; else if Reporting then -- Find some superfluous named actual that did not get -- attached to the list of associations. Actual := First (Actuals); while Present (Actual) loop if Nkind (Actual) = N_Parameter_Association and then Actual /= Last and then No (Next_Named_Actual (Actual)) then -- A validity check may introduce a copy of a call that -- includes an extra actual (for example for an unrelated -- accessibility check). Check that the extra actual matches -- some extra formal, which must exist already because -- subprogram must be frozen at this point. if Present (Extra_Formals (S)) and then not Comes_From_Source (Actual) and then Nkind (Actual) = N_Parameter_Association and then Chars (Extra_Formals (S)) = Chars (Selector_Name (Actual)) then null; else Error_Msg_N ("unmatched actual & in call", Selector_Name (Actual)); exit; end if; end if; Next (Actual); end loop; end if; Success := False; return; end if; end Normalize_Actuals; -------------------------------- -- Note_Possible_Modification -- -------------------------------- procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is Modification_Comes_From_Source : constant Boolean := Comes_From_Source (Parent (N)); Ent : Entity_Id; Exp : Node_Id; begin -- Loop to find referenced entity, if there is one Exp := N; loop Ent := Empty; if Is_Entity_Name (Exp) then Ent := Entity (Exp); -- If the entity is missing, it is an undeclared identifier, -- and there is nothing to annotate. if No (Ent) then return; end if; elsif Nkind (Exp) = N_Explicit_Dereference then declare P : constant Node_Id := Prefix (Exp); begin -- In formal verification mode, keep track of all reads and -- writes through explicit dereferences. if GNATprove_Mode then SPARK_Specific.Generate_Dereference (N, 'm'); end if; if Nkind (P) = N_Selected_Component and then Present (Entry_Formal (Entity (Selector_Name (P)))) then -- Case of a reference to an entry formal Ent := Entry_Formal (Entity (Selector_Name (P))); elsif Nkind (P) = N_Identifier and then Nkind (Parent (Entity (P))) = N_Object_Declaration and then Present (Expression (Parent (Entity (P)))) and then Nkind (Expression (Parent (Entity (P)))) = N_Reference then -- Case of a reference to a value on which side effects have -- been removed. Exp := Prefix (Expression (Parent (Entity (P)))); goto Continue; else return; end if; end; elsif Nkind (Exp) in N_Type_Conversion | N_Unchecked_Type_Conversion then Exp := Expression (Exp); goto Continue; elsif Nkind (Exp) in N_Slice | N_Indexed_Component | N_Selected_Component then -- Special check, if the prefix is an access type, then return -- since we are modifying the thing pointed to, not the prefix. -- When we are expanding, most usually the prefix is replaced -- by an explicit dereference, and this test is not needed, but -- in some cases (notably -gnatc mode and generics) when we do -- not do full expansion, we need this special test. if Is_Access_Type (Etype (Prefix (Exp))) then return; -- Otherwise go to prefix and keep going else Exp := Prefix (Exp); goto Continue; end if; -- All other cases, not a modification else return; end if; -- Now look for entity being referenced if Present (Ent) then if Is_Object (Ent) then if Comes_From_Source (Exp) or else Modification_Comes_From_Source then -- Give warning if pragma unmodified is given and we are -- sure this is a modification. if Has_Pragma_Unmodified (Ent) and then Sure then -- Note that the entity may be present only as a result -- of pragma Unused. if Has_Pragma_Unused (Ent) then Error_Msg_NE ("??pragma Unused given for &!", N, Ent); else Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent); end if; end if; Set_Never_Set_In_Source (Ent, False); end if; Set_Is_True_Constant (Ent, False); Set_Current_Value (Ent, Empty); Set_Is_Known_Null (Ent, False); if not Can_Never_Be_Null (Ent) then Set_Is_Known_Non_Null (Ent, False); end if; -- Follow renaming chain if Ekind (Ent) in E_Variable | E_Constant and then Present (Renamed_Object (Ent)) then Exp := Renamed_Object (Ent); -- If the entity is the loop variable in an iteration over -- a container, retrieve container expression to indicate -- possible modification. if Present (Related_Expression (Ent)) and then Nkind (Parent (Related_Expression (Ent))) = N_Iterator_Specification then Exp := Original_Node (Related_Expression (Ent)); end if; goto Continue; -- The expression may be the renaming of a subcomponent of an -- array or container. The assignment to the subcomponent is -- a modification of the container. elsif Comes_From_Source (Original_Node (Exp)) and then Nkind (Original_Node (Exp)) in N_Selected_Component | N_Indexed_Component then Exp := Prefix (Original_Node (Exp)); goto Continue; end if; -- Generate a reference only if the assignment comes from -- source. This excludes, for example, calls to a dispatching -- assignment operation when the left-hand side is tagged. In -- GNATprove mode, we need those references also on generated -- code, as these are used to compute the local effects of -- subprograms. if Modification_Comes_From_Source or GNATprove_Mode then Generate_Reference (Ent, Exp, 'm'); -- If the target of the assignment is the bound variable -- in an iterator, indicate that the corresponding array -- or container is also modified. if Ada_Version >= Ada_2012 and then Nkind (Parent (Ent)) = N_Iterator_Specification then declare Domain : constant Node_Id := Name (Parent (Ent)); begin -- TBD : in the full version of the construct, the -- domain of iteration can be given by an expression. if Is_Entity_Name (Domain) then Generate_Reference (Entity (Domain), Exp, 'm'); Set_Is_True_Constant (Entity (Domain), False); Set_Never_Set_In_Source (Entity (Domain), False); end if; end; end if; end if; end if; Kill_Checks (Ent); -- If we are sure this is a modification from source, and we know -- this modifies a constant, then give an appropriate warning. if Sure and then Modification_Comes_From_Source and then Overlays_Constant (Ent) and then Address_Clause_Overlay_Warnings then declare Addr : constant Node_Id := Address_Clause (Ent); O_Ent : Entity_Id; Off : Boolean; begin Find_Overlaid_Entity (Addr, O_Ent, Off); Error_Msg_Sloc := Sloc (Addr); Error_Msg_NE ("??constant& may be modified via address clause#", N, O_Ent); end; end if; return; end if; <> null; end loop; end Note_Possible_Modification; ----------------- -- Null_Status -- ----------------- function Null_Status (N : Node_Id) return Null_Status_Kind is function Is_Null_Excluding_Def (Def : Node_Id) return Boolean; -- Determine whether definition Def carries a null exclusion function Null_Status_Of_Entity (Id : Entity_Id) return Null_Status_Kind; -- Determine the null status of arbitrary entity Id function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind; -- Determine the null status of type Typ --------------------------- -- Is_Null_Excluding_Def -- --------------------------- function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is begin return Nkind (Def) in N_Access_Definition | N_Access_Function_Definition | N_Access_Procedure_Definition | N_Access_To_Object_Definition | N_Component_Definition | N_Derived_Type_Definition and then Null_Exclusion_Present (Def); end Is_Null_Excluding_Def; --------------------------- -- Null_Status_Of_Entity -- --------------------------- function Null_Status_Of_Entity (Id : Entity_Id) return Null_Status_Kind is Decl : constant Node_Id := Declaration_Node (Id); Def : Node_Id; begin -- The value of an imported or exported entity may be set externally -- regardless of a null exclusion. As a result, the value cannot be -- determined statically. if Is_Imported (Id) or else Is_Exported (Id) then return Unknown; elsif Nkind (Decl) in N_Component_Declaration | N_Discriminant_Specification | N_Formal_Object_Declaration | N_Object_Declaration | N_Object_Renaming_Declaration | N_Parameter_Specification then -- A component declaration yields a non-null value when either -- its component definition or access definition carries a null -- exclusion. if Nkind (Decl) = N_Component_Declaration then Def := Component_Definition (Decl); if Is_Null_Excluding_Def (Def) then return Is_Non_Null; end if; Def := Access_Definition (Def); if Present (Def) and then Is_Null_Excluding_Def (Def) then return Is_Non_Null; end if; -- A formal object declaration yields a non-null value if its -- access definition carries a null exclusion. If the object is -- default initialized, then the value depends on the expression. elsif Nkind (Decl) = N_Formal_Object_Declaration then Def := Access_Definition (Decl); if Present (Def) and then Is_Null_Excluding_Def (Def) then return Is_Non_Null; end if; -- A constant may yield a null or non-null value depending on its -- initialization expression. elsif Ekind (Id) = E_Constant then return Null_Status (Constant_Value (Id)); -- The construct yields a non-null value when it has a null -- exclusion. elsif Null_Exclusion_Present (Decl) then return Is_Non_Null; -- An object renaming declaration yields a non-null value if its -- access definition carries a null exclusion. Otherwise the value -- depends on the renamed name. elsif Nkind (Decl) = N_Object_Renaming_Declaration then Def := Access_Definition (Decl); if Present (Def) and then Is_Null_Excluding_Def (Def) then return Is_Non_Null; else return Null_Status (Name (Decl)); end if; end if; end if; -- At this point the declaration of the entity does not carry a null -- exclusion and lacks an initialization expression. Check the status -- of its type. return Null_Status_Of_Type (Etype (Id)); end Null_Status_Of_Entity; ------------------------- -- Null_Status_Of_Type -- ------------------------- function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind is Curr : Entity_Id; Decl : Node_Id; begin -- Traverse the type chain looking for types with null exclusion Curr := Typ; while Present (Curr) and then Etype (Curr) /= Curr loop Decl := Parent (Curr); -- Guard against itypes which do not always have declarations. A -- type yields a non-null value if it carries a null exclusion. if Present (Decl) then if Nkind (Decl) = N_Full_Type_Declaration and then Is_Null_Excluding_Def (Type_Definition (Decl)) then return Is_Non_Null; elsif Nkind (Decl) = N_Subtype_Declaration and then Null_Exclusion_Present (Decl) then return Is_Non_Null; end if; end if; Curr := Etype (Curr); end loop; -- The type chain does not contain any null excluding types return Unknown; end Null_Status_Of_Type; -- Start of processing for Null_Status begin -- Prevent cascaded errors or infinite loops when trying to determine -- the null status of an erroneous construct. if Error_Posted (N) then return Unknown; -- An allocator always creates a non-null value elsif Nkind (N) = N_Allocator then return Is_Non_Null; -- Taking the 'Access of something yields a non-null value elsif Nkind (N) = N_Attribute_Reference and then Attribute_Name (N) in Name_Access | Name_Unchecked_Access | Name_Unrestricted_Access then return Is_Non_Null; -- "null" yields null elsif Nkind (N) = N_Null then return Is_Null; -- Check the status of the operand of a type conversion elsif Nkind (N) = N_Type_Conversion then return Null_Status (Expression (N)); -- The input denotes a reference to an entity. Determine whether the -- entity or its type yields a null or non-null value. elsif Is_Entity_Name (N) and then Present (Entity (N)) then return Null_Status_Of_Entity (Entity (N)); end if; -- Otherwise it is not possible to determine the null status of the -- subexpression at compile time without resorting to simple flow -- analysis. return Unknown; end Null_Status; -------------------------------------- -- Null_To_Null_Address_Convert_OK -- -------------------------------------- function Null_To_Null_Address_Convert_OK (N : Node_Id; Typ : Entity_Id := Empty) return Boolean is begin if not Relaxed_RM_Semantics then return False; end if; if Nkind (N) = N_Null then return Present (Typ) and then Is_Descendant_Of_Address (Typ); elsif Nkind (N) in N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne then declare L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); begin -- We check the Etype of the complementary operand since the -- N_Null node is not decorated at this stage. return ((Nkind (L) = N_Null and then Is_Descendant_Of_Address (Etype (R))) or else (Nkind (R) = N_Null and then Is_Descendant_Of_Address (Etype (L)))); end; end if; return False; end Null_To_Null_Address_Convert_OK; --------------------------------- -- Number_Of_Elements_In_Array -- --------------------------------- function Number_Of_Elements_In_Array (T : Entity_Id) return Int is Indx : Node_Id; Typ : Entity_Id; Low : Node_Id; High : Node_Id; Num : Int := 1; begin pragma Assert (Is_Array_Type (T)); Indx := First_Index (T); while Present (Indx) loop Typ := Underlying_Type (Etype (Indx)); -- Never look at junk bounds of a generic type if Is_Generic_Type (Typ) then return 0; end if; -- Check the array bounds are known at compile time and return zero -- if they are not. Low := Type_Low_Bound (Typ); High := Type_High_Bound (Typ); if not Compile_Time_Known_Value (Low) then return 0; elsif not Compile_Time_Known_Value (High) then return 0; else Num := Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1)); end if; Next_Index (Indx); end loop; return Num; end Number_Of_Elements_In_Array; ---------------------------------- -- Old_Requires_Transient_Scope -- ---------------------------------- function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is Typ : constant Entity_Id := Underlying_Type (Id); begin -- This is a private type which is not completed yet. This can only -- happen in a default expression (of a formal parameter or of a -- record component). Do not expand transient scope in this case. if No (Typ) then return False; -- Do not expand transient scope for non-existent procedure return elsif Typ = Standard_Void_Type then return False; -- Elementary types do not require a transient scope elsif Is_Elementary_Type (Typ) then return False; -- Generally, indefinite subtypes require a transient scope, since the -- back end cannot generate temporaries, since this is not a valid type -- for declaring an object. It might be possible to relax this in the -- future, e.g. by declaring the maximum possible space for the type. elsif not Is_Definite_Subtype (Typ) then return True; -- Functions returning tagged types may dispatch on result so their -- returned value is allocated on the secondary stack. Controlled -- type temporaries need finalization. elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then return True; -- Record type elsif Is_Record_Type (Typ) then declare Comp : Entity_Id; begin Comp := First_Entity (Typ); while Present (Comp) loop if Ekind (Comp) = E_Component then -- ???It's not clear we need a full recursive call to -- Old_Requires_Transient_Scope here. Note that the -- following can't happen. pragma Assert (Is_Definite_Subtype (Etype (Comp))); pragma Assert (not Has_Controlled_Component (Etype (Comp))); if Old_Requires_Transient_Scope (Etype (Comp)) then return True; end if; end if; Next_Entity (Comp); end loop; end; return False; -- String literal types never require transient scope elsif Ekind (Typ) = E_String_Literal_Subtype then return False; -- Array type. Note that we already know that this is a constrained -- array, since unconstrained arrays will fail the indefinite test. elsif Is_Array_Type (Typ) then -- If component type requires a transient scope, the array does too if Old_Requires_Transient_Scope (Component_Type (Typ)) then return True; -- Otherwise, we only need a transient scope if the size depends on -- the value of one or more discriminants. else return Size_Depends_On_Discriminant (Typ); end if; -- All other cases do not require a transient scope else pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ)); return False; end if; end Old_Requires_Transient_Scope; --------------------------------- -- Original_Aspect_Pragma_Name -- --------------------------------- function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is Item : Node_Id; Item_Nam : Name_Id; begin pragma Assert (Nkind (N) in N_Aspect_Specification | N_Pragma); Item := N; -- The pragma was generated to emulate an aspect, use the original -- aspect specification. if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then Item := Corresponding_Aspect (Item); end if; -- Retrieve the name of the aspect/pragma. As assertion pragmas from -- a generic instantiation might have been rewritten into pragma Check, -- we look at the original node for Item. Note also that Pre, Pre_Class, -- Post and Post_Class rewrite their pragma identifier to preserve the -- original name, so we look at the original node for the identifier. -- ??? this is kludgey if Nkind (Item) = N_Pragma then Item_Nam := Chars (Original_Node (Pragma_Identifier (Original_Node (Item)))); else pragma Assert (Nkind (Item) = N_Aspect_Specification); Item_Nam := Chars (Identifier (Item)); end if; -- Deal with 'Class by converting the name to its _XXX form if Class_Present (Item) then if Item_Nam = Name_Invariant then Item_Nam := Name_uInvariant; elsif Item_Nam = Name_Post then Item_Nam := Name_uPost; elsif Item_Nam = Name_Pre then Item_Nam := Name_uPre; elsif Item_Nam in Name_Type_Invariant | Name_Type_Invariant_Class then Item_Nam := Name_uType_Invariant; -- Nothing to do for other cases (e.g. a Check that derived from -- Pre_Class and has the flag set). Also we do nothing if the name -- is already in special _xxx form. end if; end if; return Item_Nam; end Original_Aspect_Pragma_Name; -------------------------------------- -- Original_Corresponding_Operation -- -------------------------------------- function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id is Typ : constant Entity_Id := Find_Dispatching_Type (S); begin -- If S is an inherited primitive S2 the original corresponding -- operation of S is the original corresponding operation of S2 if Present (Alias (S)) and then Find_Dispatching_Type (Alias (S)) /= Typ then return Original_Corresponding_Operation (Alias (S)); -- If S overrides an inherited subprogram S2 the original corresponding -- operation of S is the original corresponding operation of S2 elsif Present (Overridden_Operation (S)) then return Original_Corresponding_Operation (Overridden_Operation (S)); -- otherwise it is S itself else return S; end if; end Original_Corresponding_Operation; ------------------- -- Output_Entity -- ------------------- procedure Output_Entity (Id : Entity_Id) is Scop : Entity_Id; begin Scop := Scope (Id); -- The entity may lack a scope when it is in the process of being -- analyzed. Use the current scope as an approximation. if No (Scop) then Scop := Current_Scope; end if; Output_Name (Chars (Id), Scop); end Output_Entity; ----------------- -- Output_Name -- ----------------- procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is begin Write_Str (Get_Name_String (Get_Qualified_Name (Nam => Nam, Suffix => No_Name, Scop => Scop))); Write_Eol; end Output_Name; ------------------ -- Param_Entity -- ------------------ -- This would be trivial, simply a test for an identifier that was a -- reference to a formal, if it were not for the fact that a previous call -- to Expand_Entry_Parameter will have modified the reference to the -- identifier. A formal of a protected entity is rewritten as -- typ!(recobj).rec.all'Constrained -- where rec is a selector whose Entry_Formal link points to the formal -- If the type of the entry parameter has a representation clause, then an -- extra temp is involved (see below). -- For a formal of a task entity, the formal is rewritten as a local -- renaming. -- In addition, a formal that is marked volatile because it is aliased -- through an address clause is rewritten as dereference as well. function Param_Entity (N : Node_Id) return Entity_Id is Renamed_Obj : Node_Id; begin -- Simple reference case if Nkind (N) in N_Identifier | N_Expanded_Name then if Is_Formal (Entity (N)) then return Entity (N); -- Handle renamings of formal parameters and formals of tasks that -- are rewritten as renamings. elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); if Is_Entity_Name (Renamed_Obj) and then Is_Formal (Entity (Renamed_Obj)) then return Entity (Renamed_Obj); elsif Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement then return Entity (N); end if; end if; else if Nkind (N) = N_Explicit_Dereference then declare P : Node_Id := Prefix (N); S : Node_Id; E : Entity_Id; Decl : Node_Id; begin -- If the type of an entry parameter has a representation -- clause, then the prefix is not a selected component, but -- instead a reference to a temp pointing at the selected -- component. In this case, set P to be the initial value of -- that temp. if Nkind (P) = N_Identifier then E := Entity (P); if Ekind (E) = E_Constant then Decl := Parent (E); if Nkind (Decl) = N_Object_Declaration then P := Expression (Decl); end if; end if; end if; if Nkind (P) = N_Selected_Component then S := Selector_Name (P); if Present (Entry_Formal (Entity (S))) then return Entry_Formal (Entity (S)); end if; elsif Nkind (Original_Node (N)) = N_Identifier then return Param_Entity (Original_Node (N)); end if; end; end if; end if; return (Empty); end Param_Entity; ---------------------- -- Policy_In_Effect -- ---------------------- function Policy_In_Effect (Policy : Name_Id) return Name_Id is function Policy_In_List (List : Node_Id) return Name_Id; -- Determine the mode of a policy in a N_Pragma list -------------------- -- Policy_In_List -- -------------------- function Policy_In_List (List : Node_Id) return Name_Id is Arg1 : Node_Id; Arg2 : Node_Id; Prag : Node_Id; begin Prag := List; while Present (Prag) loop Arg1 := First (Pragma_Argument_Associations (Prag)); Arg2 := Next (Arg1); Arg1 := Get_Pragma_Arg (Arg1); Arg2 := Get_Pragma_Arg (Arg2); -- The current Check_Policy pragma matches the requested policy or -- appears in the single argument form (Assertion, policy_id). if Chars (Arg1) in Name_Assertion | Policy then return Chars (Arg2); end if; Prag := Next_Pragma (Prag); end loop; return No_Name; end Policy_In_List; -- Local variables Kind : Name_Id; -- Start of processing for Policy_In_Effect begin if not Is_Valid_Assertion_Kind (Policy) then raise Program_Error; end if; -- Inspect all policy pragmas that appear within scopes (if any) Kind := Policy_In_List (Check_Policy_List); -- Inspect all configuration policy pragmas (if any) if Kind = No_Name then Kind := Policy_In_List (Check_Policy_List_Config); end if; -- The context lacks policy pragmas, determine the mode based on whether -- assertions are enabled at the configuration level. This ensures that -- the policy is preserved when analyzing generics. if Kind = No_Name then if Assertions_Enabled_Config then Kind := Name_Check; else Kind := Name_Ignore; end if; end if; -- In CodePeer mode and GNATprove mode, we need to consider all -- assertions, unless they are disabled. Force Name_Check on -- ignored assertions. if Kind in Name_Ignore | Name_Off and then (CodePeer_Mode or GNATprove_Mode) then Kind := Name_Check; end if; return Kind; end Policy_In_Effect; ------------------------------- -- Preanalyze_Without_Errors -- ------------------------------- procedure Preanalyze_Without_Errors (N : Node_Id) is Status : constant Boolean := Get_Ignore_Errors; begin Set_Ignore_Errors (True); Preanalyze (N); Set_Ignore_Errors (Status); end Preanalyze_Without_Errors; ----------------------- -- Predicate_Enabled -- ----------------------- function Predicate_Enabled (Typ : Entity_Id) return Boolean is begin return Present (Predicate_Function (Typ)) and then not Predicates_Ignored (Typ) and then not Predicate_Checks_Suppressed (Empty); end Predicate_Enabled; ---------------------------------- -- Predicate_Tests_On_Arguments -- ---------------------------------- function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is begin -- Always test predicates on indirect call if Ekind (Subp) = E_Subprogram_Type then return True; -- Do not test predicates on call to generated default Finalize, since -- we are not interested in whether something we are finalizing (and -- typically destroying) satisfies its predicates. elsif Chars (Subp) = Name_Finalize and then not Comes_From_Source (Subp) then return False; -- Do not test predicates on any internally generated routines elsif Is_Internal_Name (Chars (Subp)) then return False; -- Do not test predicates on call to Init_Proc, since if needed the -- predicate test will occur at some other point. elsif Is_Init_Proc (Subp) then return False; -- Do not test predicates on call to predicate function, since this -- would cause infinite recursion. elsif Ekind (Subp) = E_Function and then (Is_Predicate_Function (Subp) or else Is_Predicate_Function_M (Subp)) then return False; -- For now, no other exceptions else return True; end if; end Predicate_Tests_On_Arguments; ----------------------- -- Private_Component -- ----------------------- function Private_Component (Type_Id : Entity_Id) return Entity_Id is Ancestor : constant Entity_Id := Base_Type (Type_Id); function Trace_Components (T : Entity_Id; Check : Boolean) return Entity_Id; -- Recursive function that does the work, and checks against circular -- definition for each subcomponent type. ---------------------- -- Trace_Components -- ---------------------- function Trace_Components (T : Entity_Id; Check : Boolean) return Entity_Id is Btype : constant Entity_Id := Base_Type (T); Component : Entity_Id; P : Entity_Id; Candidate : Entity_Id := Empty; begin if Check and then Btype = Ancestor then Error_Msg_N ("circular type definition", Type_Id); return Any_Type; end if; if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then if Present (Full_View (Btype)) and then Is_Record_Type (Full_View (Btype)) and then not Is_Frozen (Btype) then -- To indicate that the ancestor depends on a private type, the -- current Btype is sufficient. However, to check for circular -- definition we must recurse on the full view. Candidate := Trace_Components (Full_View (Btype), True); if Candidate = Any_Type then return Any_Type; else return Btype; end if; else return Btype; end if; elsif Is_Array_Type (Btype) then return Trace_Components (Component_Type (Btype), True); elsif Is_Record_Type (Btype) then Component := First_Entity (Btype); while Present (Component) and then Comes_From_Source (Component) loop -- Skip anonymous types generated by constrained components if not Is_Type (Component) then P := Trace_Components (Etype (Component), True); if Present (P) then if P = Any_Type then return P; else Candidate := P; end if; end if; end if; Next_Entity (Component); end loop; return Candidate; else return Empty; end if; end Trace_Components; -- Start of processing for Private_Component begin return Trace_Components (Type_Id, False); end Private_Component; --------------------------- -- Primitive_Names_Match -- --------------------------- function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is function Non_Internal_Name (E : Entity_Id) return Name_Id; -- Given an internal name, returns the corresponding non-internal name ------------------------ -- Non_Internal_Name -- ------------------------ function Non_Internal_Name (E : Entity_Id) return Name_Id is begin Get_Name_String (Chars (E)); Name_Len := Name_Len - 1; return Name_Find; end Non_Internal_Name; -- Start of processing for Primitive_Names_Match begin pragma Assert (Present (E1) and then Present (E2)); return Chars (E1) = Chars (E2) or else (not Is_Internal_Name (Chars (E1)) and then Is_Internal_Name (Chars (E2)) and then Non_Internal_Name (E2) = Chars (E1)) or else (not Is_Internal_Name (Chars (E2)) and then Is_Internal_Name (Chars (E1)) and then Non_Internal_Name (E1) = Chars (E2)) or else (Is_Predefined_Dispatching_Operation (E1) and then Is_Predefined_Dispatching_Operation (E2) and then Same_TSS (E1, E2)) or else (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); end Primitive_Names_Match; ----------------------- -- Process_End_Label -- ----------------------- procedure Process_End_Label (N : Node_Id; Typ : Character; Ent : Entity_Id) is Loc : Source_Ptr; Nam : Node_Id; Scop : Entity_Id; Label_Ref : Boolean; -- Set True if reference to end label itself is required Endl : Node_Id; -- Gets set to the operator symbol or identifier that references the -- entity Ent. For the child unit case, this is the identifier from the -- designator. For other cases, this is simply Endl. procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); -- N is an identifier node that appears as a parent unit reference in -- the case where Ent is a child unit. This procedure generates an -- appropriate cross-reference entry. E is the corresponding entity. ------------------------- -- Generate_Parent_Ref -- ------------------------- procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is begin -- If names do not match, something weird, skip reference if Chars (E) = Chars (N) then -- Generate the reference. We do NOT consider this as a reference -- for unreferenced symbol purposes. Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); if Style_Check then Style.Check_Identifier (N, E); end if; end if; end Generate_Parent_Ref; -- Start of processing for Process_End_Label begin -- If no node, ignore. This happens in some error situations, and -- also for some internally generated structures where no end label -- references are required in any case. if No (N) then return; end if; -- Nothing to do if no End_Label, happens for internally generated -- constructs where we don't want an end label reference anyway. Also -- nothing to do if Endl is a string literal, which means there was -- some prior error (bad operator symbol) Endl := End_Label (N); if No (Endl) or else Nkind (Endl) = N_String_Literal then return; end if; -- Reference node is not in extended main source unit if not In_Extended_Main_Source_Unit (N) then -- Generally we do not collect references except for the extended -- main source unit. The one exception is the 'e' entry for a -- package spec, where it is useful for a client to have the -- ending information to define scopes. if Typ /= 'e' then return; else Label_Ref := False; -- For this case, we can ignore any parent references, but we -- need the package name itself for the 'e' entry. if Nkind (Endl) = N_Designator then Endl := Identifier (Endl); end if; end if; -- Reference is in extended main source unit else Label_Ref := True; -- For designator, generate references for the parent entries if Nkind (Endl) = N_Designator then -- Generate references for the prefix if the END line comes from -- source (otherwise we do not need these references) We climb the -- scope stack to find the expected entities. if Comes_From_Source (Endl) then Nam := Name (Endl); Scop := Current_Scope; while Nkind (Nam) = N_Selected_Component loop Scop := Scope (Scop); exit when No (Scop); Generate_Parent_Ref (Selector_Name (Nam), Scop); Nam := Prefix (Nam); end loop; if Present (Scop) then Generate_Parent_Ref (Nam, Scope (Scop)); end if; end if; Endl := Identifier (Endl); end if; end if; -- If the end label is not for the given entity, then either we have -- some previous error, or this is a generic instantiation for which -- we do not need to make a cross-reference in this case anyway. In -- either case we simply ignore the call. if Chars (Ent) /= Chars (Endl) then return; end if; -- If label was really there, then generate a normal reference and then -- adjust the location in the end label to point past the name (which -- should almost always be the semicolon). Loc := Sloc (Endl); if Comes_From_Source (Endl) then -- If a label reference is required, then do the style check and -- generate an l-type cross-reference entry for the label if Label_Ref then if Style_Check then Style.Check_Identifier (Endl, Ent); end if; Generate_Reference (Ent, Endl, 'l', Set_Ref => False); end if; -- Set the location to point past the label (normally this will -- mean the semicolon immediately following the label). This is -- done for the sake of the 'e' or 't' entry generated below. Get_Decoded_Name_String (Chars (Endl)); Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); end if; -- Now generate the e/t reference Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); -- Restore Sloc, in case modified above, since we have an identifier -- and the normal Sloc should be left set in the tree. Set_Sloc (Endl, Loc); end Process_End_Label; -------------------------------- -- Propagate_Concurrent_Flags -- -------------------------------- procedure Propagate_Concurrent_Flags (Typ : Entity_Id; Comp_Typ : Entity_Id) is begin if Has_Task (Comp_Typ) then Set_Has_Task (Typ); end if; if Has_Protected (Comp_Typ) then Set_Has_Protected (Typ); end if; if Has_Timing_Event (Comp_Typ) then Set_Has_Timing_Event (Typ); end if; end Propagate_Concurrent_Flags; ------------------------------ -- Propagate_DIC_Attributes -- ------------------------------ procedure Propagate_DIC_Attributes (Typ : Entity_Id; From_Typ : Entity_Id) is DIC_Proc : Entity_Id; begin if Present (Typ) and then Present (From_Typ) then pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); -- Nothing to do if both the source and the destination denote the -- same type. if From_Typ = Typ then return; -- Nothing to do when the destination denotes an incomplete type -- because the DIC is associated with the current instance of a -- private type, thus it can never apply to an incomplete type. elsif Is_Incomplete_Type (Typ) then return; end if; DIC_Proc := DIC_Procedure (From_Typ); -- The setting of the attributes is intentionally conservative. This -- prevents accidental clobbering of enabled attributes. if Has_Inherited_DIC (From_Typ) then Set_Has_Inherited_DIC (Typ); end if; if Has_Own_DIC (From_Typ) then Set_Has_Own_DIC (Typ); end if; if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then Set_DIC_Procedure (Typ, DIC_Proc); end if; end if; end Propagate_DIC_Attributes; ------------------------------------ -- Propagate_Invariant_Attributes -- ------------------------------------ procedure Propagate_Invariant_Attributes (Typ : Entity_Id; From_Typ : Entity_Id) is Full_IP : Entity_Id; Part_IP : Entity_Id; begin if Present (Typ) and then Present (From_Typ) then pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); -- Nothing to do if both the source and the destination denote the -- same type. if From_Typ = Typ then return; end if; Full_IP := Invariant_Procedure (From_Typ); Part_IP := Partial_Invariant_Procedure (From_Typ); -- The setting of the attributes is intentionally conservative. This -- prevents accidental clobbering of enabled attributes. if Has_Inheritable_Invariants (From_Typ) then Set_Has_Inheritable_Invariants (Typ); end if; if Has_Inherited_Invariants (From_Typ) then Set_Has_Inherited_Invariants (Typ); end if; if Has_Own_Invariants (From_Typ) then Set_Has_Own_Invariants (Typ); end if; if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then Set_Invariant_Procedure (Typ, Full_IP); end if; if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ)) then Set_Partial_Invariant_Procedure (Typ, Part_IP); end if; end if; end Propagate_Invariant_Attributes; ------------------------------------ -- Propagate_Predicate_Attributes -- ------------------------------------ procedure Propagate_Predicate_Attributes (Typ : Entity_Id; From_Typ : Entity_Id) is Pred_Func : Entity_Id; Pred_Func_M : Entity_Id; begin if Present (Typ) and then Present (From_Typ) then pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); -- Nothing to do if both the source and the destination denote the -- same type. if From_Typ = Typ then return; end if; Pred_Func := Predicate_Function (From_Typ); Pred_Func_M := Predicate_Function_M (From_Typ); -- The setting of the attributes is intentionally conservative. This -- prevents accidental clobbering of enabled attributes. if Has_Predicates (From_Typ) then Set_Has_Predicates (Typ); end if; if Present (Pred_Func) and then No (Predicate_Function (Typ)) then Set_Predicate_Function (Typ, Pred_Func); end if; if Present (Pred_Func_M) and then No (Predicate_Function_M (Typ)) then Set_Predicate_Function_M (Typ, Pred_Func_M); end if; end if; end Propagate_Predicate_Attributes; --------------------------------------- -- Record_Possible_Part_Of_Reference -- --------------------------------------- procedure Record_Possible_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is Encap : constant Entity_Id := Encapsulating_State (Var_Id); Refs : Elist_Id; begin -- The variable is a constituent of a single protected/task type. Such -- a variable acts as a component of the type and must appear within a -- specific region (SPARK RM 9(3)). Instead of recording the reference, -- verify its legality now. if Present (Encap) and then Is_Single_Concurrent_Object (Encap) then Check_Part_Of_Reference (Var_Id, Ref); -- The variable is subject to pragma Part_Of and may eventually become a -- constituent of a single protected/task type. Record the reference to -- verify its placement when the contract of the variable is analyzed. elsif Present (Get_Pragma (Var_Id, Pragma_Part_Of)) then Refs := Part_Of_References (Var_Id); if No (Refs) then Refs := New_Elmt_List; Set_Part_Of_References (Var_Id, Refs); end if; Append_Elmt (Ref, Refs); end if; end Record_Possible_Part_Of_Reference; ---------------- -- Referenced -- ---------------- function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is Seen : Boolean := False; function Is_Reference (N : Node_Id) return Traverse_Result; -- Determine whether node N denotes a reference to Id. If this is the -- case, set global flag Seen to True and stop the traversal. ------------------ -- Is_Reference -- ------------------ function Is_Reference (N : Node_Id) return Traverse_Result is begin if Is_Entity_Name (N) and then Present (Entity (N)) and then Entity (N) = Id then Seen := True; return Abandon; else return OK; end if; end Is_Reference; procedure Inspect_Expression is new Traverse_Proc (Is_Reference); -- Start of processing for Referenced begin Inspect_Expression (Expr); return Seen; end Referenced; ------------------------------------ -- References_Generic_Formal_Type -- ------------------------------------ function References_Generic_Formal_Type (N : Node_Id) return Boolean is function Process (N : Node_Id) return Traverse_Result; -- Process one node in search for generic formal type ------------- -- Process -- ------------- function Process (N : Node_Id) return Traverse_Result is begin if Nkind (N) in N_Has_Entity then declare E : constant Entity_Id := Entity (N); begin if Present (E) then if Is_Generic_Type (E) then return Abandon; elsif Present (Etype (E)) and then Is_Generic_Type (Etype (E)) then return Abandon; end if; end if; end; end if; return Atree.OK; end Process; function Traverse is new Traverse_Func (Process); -- Traverse tree to look for generic type begin if Inside_A_Generic then return Traverse (N) = Abandon; else return False; end if; end References_Generic_Formal_Type; ------------------------------- -- Remove_Entity_And_Homonym -- ------------------------------- procedure Remove_Entity_And_Homonym (Id : Entity_Id) is begin Remove_Entity (Id); Remove_Homonym (Id); end Remove_Entity_And_Homonym; -------------------- -- Remove_Homonym -- -------------------- procedure Remove_Homonym (Id : Entity_Id) is Hom : Entity_Id; Prev : Entity_Id := Empty; begin if Id = Current_Entity (Id) then if Present (Homonym (Id)) then Set_Current_Entity (Homonym (Id)); else Set_Name_Entity_Id (Chars (Id), Empty); end if; else Hom := Current_Entity (Id); while Present (Hom) and then Hom /= Id loop Prev := Hom; Hom := Homonym (Hom); end loop; -- If Id is not on the homonym chain, nothing to do if Present (Hom) then Set_Homonym (Prev, Homonym (Id)); end if; end if; end Remove_Homonym; ------------------------------ -- Remove_Overloaded_Entity -- ------------------------------ procedure Remove_Overloaded_Entity (Id : Entity_Id) is procedure Remove_Primitive_Of (Typ : Entity_Id); -- Remove primitive subprogram Id from the list of primitives that -- belong to type Typ. ------------------------- -- Remove_Primitive_Of -- ------------------------- procedure Remove_Primitive_Of (Typ : Entity_Id) is Prims : Elist_Id; begin if Is_Tagged_Type (Typ) then Prims := Direct_Primitive_Operations (Typ); if Present (Prims) then Remove (Prims, Id); end if; end if; end Remove_Primitive_Of; -- Local variables Formal : Entity_Id; -- Start of processing for Remove_Overloaded_Entity begin Remove_Entity_And_Homonym (Id); -- The entity denotes a primitive subprogram. Remove it from the list of -- primitives of the associated controlling type. if Ekind (Id) in E_Function | E_Procedure and then Is_Primitive (Id) then Formal := First_Formal (Id); while Present (Formal) loop if Is_Controlling_Formal (Formal) then Remove_Primitive_Of (Etype (Formal)); exit; end if; Next_Formal (Formal); end loop; if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then Remove_Primitive_Of (Etype (Id)); end if; end if; end Remove_Overloaded_Entity; --------------------- -- Rep_To_Pos_Flag -- --------------------- function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is begin return New_Occurrence_Of (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); end Rep_To_Pos_Flag; -------------------- -- Require_Entity -- -------------------- procedure Require_Entity (N : Node_Id) is begin if Is_Entity_Name (N) and then No (Entity (N)) then if Total_Errors_Detected /= 0 then Set_Entity (N, Any_Id); else raise Program_Error; end if; end if; end Require_Entity; ------------------------------ -- Requires_Transient_Scope -- ------------------------------ -- A transient scope is required when variable-sized temporaries are -- allocated on the secondary stack, or when finalization actions must be -- generated before the next instruction. function Requires_Transient_Scope (Id : Entity_Id) return Boolean is Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id); procedure Ensure_Minimum_Decoration (Typ : Entity_Id); -- If Typ is not frozen then add to Typ the minimum decoration required -- by Requires_Transient_Scope to reliably provide its functionality; -- otherwise no action is performed. ------------------------------- -- Ensure_Minimum_Decoration -- ------------------------------- procedure Ensure_Minimum_Decoration (Typ : Entity_Id) is begin -- Do not set Has_Controlled_Component on a class-wide equivalent -- type. See Make_CW_Equivalent_Type. if Present (Typ) and then not Is_Frozen (Typ) and then (Is_Record_Type (Typ) or else Is_Concurrent_Type (Typ) or else Is_Incomplete_Or_Private_Type (Typ)) and then not Is_Class_Wide_Equivalent_Type (Typ) then declare Comp : Entity_Id; begin Comp := First_Component (Typ); while Present (Comp) loop if Has_Controlled_Component (Etype (Comp)) or else (Chars (Comp) /= Name_uParent and then Is_Controlled (Etype (Comp))) or else (Is_Protected_Type (Etype (Comp)) and then Present (Corresponding_Record_Type (Etype (Comp))) and then Has_Controlled_Component (Corresponding_Record_Type (Etype (Comp)))) then Set_Has_Controlled_Component (Typ); exit; end if; Next_Component (Comp); end loop; end; end if; end Ensure_Minimum_Decoration; -- Start of processing for Requires_Transient_Scope begin if Debug_Flag_QQ then return Old_Result; end if; Ensure_Minimum_Decoration (Id); declare New_Result : constant Boolean := New_Requires_Transient_Scope (Id); begin -- Assert that we're not putting things on the secondary stack if we -- didn't before; we are trying to AVOID secondary stack when -- possible. if not Old_Result then pragma Assert (not New_Result); null; end if; if New_Result /= Old_Result then Results_Differ (Id, Old_Result, New_Result); end if; return New_Result; end; end Requires_Transient_Scope; -------------------- -- Results_Differ -- -------------------- procedure Results_Differ (Id : Entity_Id; Old_Val : Boolean; New_Val : Boolean) is begin if False then -- False to disable; True for debugging Treepr.Print_Tree_Node (Id); if Old_Val = New_Val then raise Program_Error; end if; end if; end Results_Differ; -------------------------- -- Reset_Analyzed_Flags -- -------------------------- procedure Reset_Analyzed_Flags (N : Node_Id) is function Clear_Analyzed (N : Node_Id) return Traverse_Result; -- Function used to reset Analyzed flags in tree. Note that we do -- not reset Analyzed flags in entities, since there is no need to -- reanalyze entities, and indeed, it is wrong to do so, since it -- can result in generating auxiliary stuff more than once. -------------------- -- Clear_Analyzed -- -------------------- function Clear_Analyzed (N : Node_Id) return Traverse_Result is begin if Nkind (N) not in N_Entity then Set_Analyzed (N, False); end if; return OK; end Clear_Analyzed; procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); -- Start of processing for Reset_Analyzed_Flags begin Reset_Analyzed (N); end Reset_Analyzed_Flags; ------------------------ -- Restore_SPARK_Mode -- ------------------------ procedure Restore_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id) is begin SPARK_Mode := Mode; SPARK_Mode_Pragma := Prag; end Restore_SPARK_Mode; -------------------------------- -- Returns_Unconstrained_Type -- -------------------------------- function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is begin return Ekind (Subp) = E_Function and then not Is_Scalar_Type (Etype (Subp)) and then not Is_Access_Type (Etype (Subp)) and then not Is_Constrained (Etype (Subp)); end Returns_Unconstrained_Type; ---------------------------- -- Root_Type_Of_Full_View -- ---------------------------- function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is Rtyp : constant Entity_Id := Root_Type (T); begin -- The root type of the full view may itself be a private type. Keep -- looking for the ultimate derivation parent. if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then return Root_Type_Of_Full_View (Full_View (Rtyp)); else return Rtyp; end if; end Root_Type_Of_Full_View; --------------------------- -- Safe_To_Capture_Value -- --------------------------- function Safe_To_Capture_Value (N : Node_Id; Ent : Entity_Id; Cond : Boolean := False) return Boolean is begin -- The only entities for which we track constant values are variables -- which are not renamings, constants and formal parameters, so check -- if we have this case. -- Note: it may seem odd to track constant values for constants, but in -- fact this routine is used for other purposes than simply capturing -- the value. In particular, the setting of Known[_Non]_Null and -- Is_Known_Valid. if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) or else Ekind (Ent) = E_Constant or else Is_Formal (Ent) then null; -- For conditionals, we also allow loop parameters elsif Cond and then Ekind (Ent) = E_Loop_Parameter then null; -- For all other cases, not just unsafe, but impossible to capture -- Current_Value, since the above are the only entities which have -- Current_Value fields. else return False; end if; -- Skip if volatile or aliased, since funny things might be going on in -- these cases which we cannot necessarily track. Also skip any variable -- for which an address clause is given, or whose address is taken. Also -- never capture value of library level variables (an attempt to do so -- can occur in the case of package elaboration code). if Treat_As_Volatile (Ent) or else Is_Aliased (Ent) or else Present (Address_Clause (Ent)) or else Address_Taken (Ent) or else (Is_Library_Level_Entity (Ent) and then Ekind (Ent) = E_Variable) then return False; end if; -- OK, all above conditions are met. We also require that the scope of -- the reference be the same as the scope of the entity, not counting -- packages and blocks and loops. declare E_Scope : constant Entity_Id := Scope (Ent); R_Scope : Entity_Id; begin R_Scope := Current_Scope; while R_Scope /= Standard_Standard loop exit when R_Scope = E_Scope; if Ekind (R_Scope) not in E_Package | E_Block | E_Loop then return False; else R_Scope := Scope (R_Scope); end if; end loop; end; -- We also require that the reference does not appear in a context -- where it is not sure to be executed (i.e. a conditional context -- or an exception handler). We skip this if Cond is True, since the -- capturing of values from conditional tests handles this ok. if Cond then return True; end if; declare Desc : Node_Id; P : Node_Id; begin Desc := N; -- Seems dubious that case expressions are not handled here ??? P := Parent (N); while Present (P) loop if Nkind (P) = N_If_Statement or else Nkind (P) = N_Case_Statement or else (Nkind (P) in N_Short_Circuit and then Desc = Right_Opnd (P)) or else (Nkind (P) = N_If_Expression and then Desc /= First (Expressions (P))) or else Nkind (P) = N_Exception_Handler or else Nkind (P) = N_Selective_Accept or else Nkind (P) = N_Conditional_Entry_Call or else Nkind (P) = N_Timed_Entry_Call or else Nkind (P) = N_Asynchronous_Select then return False; else Desc := P; P := Parent (P); -- A special Ada 2012 case: the original node may be part -- of the else_actions of a conditional expression, in which -- case it might not have been expanded yet, and appears in -- a non-syntactic list of actions. In that case it is clearly -- not safe to save a value. if No (P) and then Is_List_Member (Desc) and then No (Parent (List_Containing (Desc))) then return False; end if; end if; end loop; end; -- OK, looks safe to set value return True; end Safe_To_Capture_Value; --------------- -- Same_Name -- --------------- function Same_Name (N1, N2 : Node_Id) return Boolean is K1 : constant Node_Kind := Nkind (N1); K2 : constant Node_Kind := Nkind (N2); begin if (K1 = N_Identifier or else K1 = N_Defining_Identifier) and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) then return Chars (N1) = Chars (N2); elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) then return Same_Name (Selector_Name (N1), Selector_Name (N2)) and then Same_Name (Prefix (N1), Prefix (N2)); else return False; end if; end Same_Name; ----------------- -- Same_Object -- ----------------- function Same_Object (Node1, Node2 : Node_Id) return Boolean is N1 : constant Node_Id := Original_Node (Node1); N2 : constant Node_Id := Original_Node (Node2); -- We do the tests on original nodes, since we are most interested -- in the original source, not any expansion that got in the way. K1 : constant Node_Kind := Nkind (N1); K2 : constant Node_Kind := Nkind (N2); begin -- First case, both are entities with same entity if K1 in N_Has_Entity and then K2 in N_Has_Entity then declare EN1 : constant Entity_Id := Entity (N1); EN2 : constant Entity_Id := Entity (N2); begin if Present (EN1) and then Present (EN2) and then (Ekind (EN1) in E_Variable | E_Constant or else Is_Formal (EN1)) and then EN1 = EN2 then return True; end if; end; end if; -- Second case, selected component with same selector, same record if K1 = N_Selected_Component and then K2 = N_Selected_Component and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) then return Same_Object (Prefix (N1), Prefix (N2)); -- Third case, indexed component with same subscripts, same array elsif K1 = N_Indexed_Component and then K2 = N_Indexed_Component and then Same_Object (Prefix (N1), Prefix (N2)) then declare E1, E2 : Node_Id; begin E1 := First (Expressions (N1)); E2 := First (Expressions (N2)); while Present (E1) loop if not Same_Value (E1, E2) then return False; else Next (E1); Next (E2); end if; end loop; return True; end; -- Fourth case, slice of same array with same bounds elsif K1 = N_Slice and then K2 = N_Slice and then Nkind (Discrete_Range (N1)) = N_Range and then Nkind (Discrete_Range (N2)) = N_Range and then Same_Value (Low_Bound (Discrete_Range (N1)), Low_Bound (Discrete_Range (N2))) and then Same_Value (High_Bound (Discrete_Range (N1)), High_Bound (Discrete_Range (N2))) then return Same_Name (Prefix (N1), Prefix (N2)); -- All other cases, not clearly the same object else return False; end if; end Same_Object; --------------------------------- -- Same_Or_Aliased_Subprograms -- --------------------------------- function Same_Or_Aliased_Subprograms (S : Entity_Id; E : Entity_Id) return Boolean is Subp_Alias : constant Entity_Id := Alias (S); begin return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); end Same_Or_Aliased_Subprograms; --------------- -- Same_Type -- --------------- function Same_Type (T1, T2 : Entity_Id) return Boolean is begin if T1 = T2 then return True; elsif not Is_Constrained (T1) and then not Is_Constrained (T2) and then Base_Type (T1) = Base_Type (T2) then return True; -- For now don't bother with case of identical constraints, to be -- fiddled with later on perhaps (this is only used for optimization -- purposes, so it is not critical to do a best possible job) else return False; end if; end Same_Type; ---------------- -- Same_Value -- ---------------- function Same_Value (Node1, Node2 : Node_Id) return Boolean is begin if Compile_Time_Known_Value (Node1) and then Compile_Time_Known_Value (Node2) then -- Handle properly compile-time expressions that are not -- scalar. if Is_String_Type (Etype (Node1)) then return Expr_Value_S (Node1) = Expr_Value_S (Node2); else return Expr_Value (Node1) = Expr_Value (Node2); end if; elsif Same_Object (Node1, Node2) then return True; else return False; end if; end Same_Value; -------------------- -- Set_SPARK_Mode -- -------------------- procedure Set_SPARK_Mode (Context : Entity_Id) is begin -- Do not consider illegal or partially decorated constructs if Ekind (Context) = E_Void or else Error_Posted (Context) then null; elsif Present (SPARK_Pragma (Context)) then Install_SPARK_Mode (Mode => Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Context)), Prag => SPARK_Pragma (Context)); end if; end Set_SPARK_Mode; ------------------------- -- Scalar_Part_Present -- ------------------------- function Scalar_Part_Present (Typ : Entity_Id) return Boolean is Val_Typ : constant Entity_Id := Validated_View (Typ); Field : Entity_Id; begin if Is_Scalar_Type (Val_Typ) then return True; elsif Is_Array_Type (Val_Typ) then return Scalar_Part_Present (Component_Type (Val_Typ)); elsif Is_Record_Type (Val_Typ) then Field := First_Component_Or_Discriminant (Val_Typ); while Present (Field) loop if Scalar_Part_Present (Etype (Field)) then return True; end if; Next_Component_Or_Discriminant (Field); end loop; end if; return False; end Scalar_Part_Present; ------------------------ -- Scope_Is_Transient -- ------------------------ function Scope_Is_Transient return Boolean is begin return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; end Scope_Is_Transient; ------------------ -- Scope_Within -- ------------------ function Scope_Within (Inner : Entity_Id; Outer : Entity_Id) return Boolean is Curr : Entity_Id; begin Curr := Inner; while Present (Curr) and then Curr /= Standard_Standard loop Curr := Scope (Curr); if Curr = Outer then return True; -- A selective accept body appears within a task type, but the -- enclosing subprogram is the procedure of the task body. elsif Ekind (Implementation_Base_Type (Curr)) = E_Task_Type and then Outer = Task_Body_Procedure (Implementation_Base_Type (Curr)) then return True; -- Ditto for the body of a protected operation elsif Is_Subprogram (Curr) and then Outer = Protected_Body_Subprogram (Curr) then return True; -- Outside of its scope, a synchronized type may just be private elsif Is_Private_Type (Curr) and then Present (Full_View (Curr)) and then Is_Concurrent_Type (Full_View (Curr)) then return Scope_Within (Full_View (Curr), Outer); end if; end loop; return False; end Scope_Within; -------------------------- -- Scope_Within_Or_Same -- -------------------------- function Scope_Within_Or_Same (Inner : Entity_Id; Outer : Entity_Id) return Boolean is Curr : Entity_Id := Inner; begin -- Similar to the above, but check for scope identity first while Present (Curr) and then Curr /= Standard_Standard loop if Curr = Outer then return True; elsif Ekind (Implementation_Base_Type (Curr)) = E_Task_Type and then Outer = Task_Body_Procedure (Implementation_Base_Type (Curr)) then return True; elsif Is_Subprogram (Curr) and then Outer = Protected_Body_Subprogram (Curr) then return True; elsif Is_Private_Type (Curr) and then Present (Full_View (Curr)) then if Full_View (Curr) = Outer then return True; else return Scope_Within (Full_View (Curr), Outer); end if; end if; Curr := Scope (Curr); end loop; return False; end Scope_Within_Or_Same; -------------------- -- Set_Convention -- -------------------- procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is begin Basic_Set_Convention (E, Val); if Is_Type (E) and then Is_Access_Subprogram_Type (Base_Type (E)) and then Has_Foreign_Convention (E) then Set_Can_Use_Internal_Rep (E, False); end if; -- If E is an object, including a component, and the type of E is an -- anonymous access type with no convention set, then also set the -- convention of the anonymous access type. We do not do this for -- anonymous protected types, since protected types always have the -- default convention. if Present (Etype (E)) and then (Is_Object (E) -- Allow E_Void (happens for pragma Convention appearing -- in the middle of a record applying to a component) or else Ekind (E) = E_Void) then declare Typ : constant Entity_Id := Etype (E); begin if Ekind (Typ) in E_Anonymous_Access_Type | E_Anonymous_Access_Subprogram_Type and then not Has_Convention_Pragma (Typ) then Basic_Set_Convention (Typ, Val); Set_Has_Convention_Pragma (Typ); -- And for the access subprogram type, deal similarly with the -- designated E_Subprogram_Type, which is always internal. if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then declare Dtype : constant Entity_Id := Designated_Type (Typ); begin if Ekind (Dtype) = E_Subprogram_Type and then not Has_Convention_Pragma (Dtype) then Basic_Set_Convention (Dtype, Val); Set_Has_Convention_Pragma (Dtype); end if; end; end if; end if; end; end if; end Set_Convention; ------------------------ -- Set_Current_Entity -- ------------------------ -- The given entity is to be set as the currently visible definition of its -- associated name (i.e. the Node_Id associated with its name). All we have -- to do is to get the name from the identifier, and then set the -- associated Node_Id to point to the given entity. procedure Set_Current_Entity (E : Entity_Id) is begin Set_Name_Entity_Id (Chars (E), E); end Set_Current_Entity; --------------------------- -- Set_Debug_Info_Needed -- --------------------------- procedure Set_Debug_Info_Needed (T : Entity_Id) is procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); pragma Inline (Set_Debug_Info_Needed_If_Not_Set); -- Used to set debug info in a related node if not set already -------------------------------------- -- Set_Debug_Info_Needed_If_Not_Set -- -------------------------------------- procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is begin if Present (E) and then not Needs_Debug_Info (E) then Set_Debug_Info_Needed (E); -- For a private type, indicate that the full view also needs -- debug information. if Is_Type (E) and then Is_Private_Type (E) and then Present (Full_View (E)) then Set_Debug_Info_Needed (Full_View (E)); end if; end if; end Set_Debug_Info_Needed_If_Not_Set; -- Start of processing for Set_Debug_Info_Needed begin -- Nothing to do if there is no available entity if No (T) then return; -- Nothing to do for an entity with suppressed debug information elsif Debug_Info_Off (T) then return; -- Nothing to do for an ignored Ghost entity because the entity will be -- eliminated from the tree. elsif Is_Ignored_Ghost_Entity (T) then return; -- Nothing to do if entity comes from a predefined file. Library files -- are compiled without debug information, but inlined bodies of these -- routines may appear in user code, and debug information on them ends -- up complicating debugging the user code. elsif In_Inlined_Body and then In_Predefined_Unit (T) then Set_Needs_Debug_Info (T, False); end if; -- Set flag in entity itself. Note that we will go through the following -- circuitry even if the flag is already set on T. That's intentional, -- it makes sure that the flag will be set in subsidiary entities. Set_Needs_Debug_Info (T); -- Set flag on subsidiary entities if not set already if Is_Object (T) then Set_Debug_Info_Needed_If_Not_Set (Etype (T)); elsif Is_Type (T) then Set_Debug_Info_Needed_If_Not_Set (Etype (T)); if Is_Record_Type (T) then declare Ent : Entity_Id := First_Entity (T); begin while Present (Ent) loop Set_Debug_Info_Needed_If_Not_Set (Ent); Next_Entity (Ent); end loop; end; -- For a class wide subtype, we also need debug information -- for the equivalent type. if Ekind (T) = E_Class_Wide_Subtype then Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); end if; elsif Is_Array_Type (T) then Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); declare Indx : Node_Id := First_Index (T); begin while Present (Indx) loop Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); Next_Index (Indx); end loop; end; -- For a packed array type, we also need debug information for -- the type used to represent the packed array. Conversely, we -- also need it for the former if we need it for the latter. if Is_Packed (T) then Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T)); end if; if Is_Packed_Array_Impl_Type (T) then Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); end if; elsif Is_Access_Type (T) then Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); elsif Is_Private_Type (T) then declare FV : constant Entity_Id := Full_View (T); begin Set_Debug_Info_Needed_If_Not_Set (FV); -- If the full view is itself a derived private type, we need -- debug information on its underlying type. if Present (FV) and then Is_Private_Type (FV) and then Present (Underlying_Full_View (FV)) then Set_Needs_Debug_Info (Underlying_Full_View (FV)); end if; end; elsif Is_Protected_Type (T) then Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); elsif Is_Scalar_Type (T) then -- If the subrange bounds are materialized by dedicated constant -- objects, also include them in the debug info to make sure the -- debugger can properly use them. if Present (Scalar_Range (T)) and then Nkind (Scalar_Range (T)) = N_Range then declare Low_Bnd : constant Node_Id := Type_Low_Bound (T); High_Bnd : constant Node_Id := Type_High_Bound (T); begin if Is_Entity_Name (Low_Bnd) then Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd)); end if; if Is_Entity_Name (High_Bnd) then Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd)); end if; end; end if; end if; end if; end Set_Debug_Info_Needed; -------------------------------- -- Set_Debug_Info_Defining_Id -- -------------------------------- procedure Set_Debug_Info_Defining_Id (N : Node_Id) is begin if Comes_From_Source (Defining_Identifier (N)) then Set_Debug_Info_Needed (Defining_Identifier (N)); end if; end Set_Debug_Info_Defining_Id; ---------------------------- -- Set_Entity_With_Checks -- ---------------------------- procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is Val_Actual : Entity_Id; Nod : Node_Id; Post_Node : Node_Id; begin -- Unconditionally set the entity Set_Entity (N, Val); -- The node to post on is the selector in the case of an expanded name, -- and otherwise the node itself. if Nkind (N) = N_Expanded_Name then Post_Node := Selector_Name (N); else Post_Node := N; end if; -- Check for violation of No_Fixed_IO if Restriction_Check_Required (No_Fixed_IO) and then ((RTU_Loaded (Ada_Text_IO) and then (Is_RTE (Val, RE_Decimal_IO) or else Is_RTE (Val, RE_Fixed_IO))) or else (RTU_Loaded (Ada_Wide_Text_IO) and then (Is_RTE (Val, RO_WT_Decimal_IO) or else Is_RTE (Val, RO_WT_Fixed_IO))) or else (RTU_Loaded (Ada_Wide_Wide_Text_IO) and then (Is_RTE (Val, RO_WW_Decimal_IO) or else Is_RTE (Val, RO_WW_Fixed_IO)))) -- A special extra check, don't complain about a reference from within -- the Ada.Interrupts package itself! and then not In_Same_Extended_Unit (N, Val) then Check_Restriction (No_Fixed_IO, Post_Node); end if; -- Remaining checks are only done on source nodes. Note that we test -- for violation of No_Fixed_IO even on non-source nodes, because the -- cases for checking violations of this restriction are instantiations -- where the reference in the instance has Comes_From_Source False. if not Comes_From_Source (N) then return; end if; -- Check for violation of No_Abort_Statements, which is triggered by -- call to Ada.Task_Identification.Abort_Task. if Restriction_Check_Required (No_Abort_Statements) and then (Is_RTE (Val, RE_Abort_Task)) -- A special extra check, don't complain about a reference from within -- the Ada.Task_Identification package itself! and then not In_Same_Extended_Unit (N, Val) then Check_Restriction (No_Abort_Statements, Post_Node); end if; if Val = Standard_Long_Long_Integer then Check_Restriction (No_Long_Long_Integers, Post_Node); end if; -- Check for violation of No_Dynamic_Attachment if Restriction_Check_Required (No_Dynamic_Attachment) and then RTU_Loaded (Ada_Interrupts) and then (Is_RTE (Val, RE_Is_Reserved) or else Is_RTE (Val, RE_Is_Attached) or else Is_RTE (Val, RE_Current_Handler) or else Is_RTE (Val, RE_Attach_Handler) or else Is_RTE (Val, RE_Exchange_Handler) or else Is_RTE (Val, RE_Detach_Handler) or else Is_RTE (Val, RE_Reference)) -- A special extra check, don't complain about a reference from within -- the Ada.Interrupts package itself! and then not In_Same_Extended_Unit (N, Val) then Check_Restriction (No_Dynamic_Attachment, Post_Node); end if; -- Check for No_Implementation_Identifiers if Restriction_Check_Required (No_Implementation_Identifiers) then -- We have an implementation defined entity if it is marked as -- implementation defined, or is defined in a package marked as -- implementation defined. However, library packages themselves -- are excluded (we don't want to flag Interfaces itself, just -- the entities within it). if (Is_Implementation_Defined (Val) or else (Present (Scope (Val)) and then Is_Implementation_Defined (Scope (Val)))) and then not (Is_Package_Or_Generic_Package (Val) and then Is_Library_Level_Entity (Val)) then Check_Restriction (No_Implementation_Identifiers, Post_Node); end if; end if; -- Do the style check if Style_Check and then not Suppress_Style_Checks (Val) and then not In_Instance then if Nkind (N) = N_Identifier then Nod := N; elsif Nkind (N) = N_Expanded_Name then Nod := Selector_Name (N); else return; end if; -- A special situation arises for derived operations, where we want -- to do the check against the parent (since the Sloc of the derived -- operation points to the derived type declaration itself). Val_Actual := Val; while not Comes_From_Source (Val_Actual) and then Nkind (Val_Actual) in N_Entity and then (Ekind (Val_Actual) = E_Enumeration_Literal or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual)) and then Present (Alias (Val_Actual)) loop Val_Actual := Alias (Val_Actual); end loop; -- Renaming declarations for generic actuals do not come from source, -- and have a different name from that of the entity they rename, so -- there is no style check to perform here. if Chars (Nod) = Chars (Val_Actual) then Style.Check_Identifier (Nod, Val_Actual); end if; end if; Set_Entity (N, Val); end Set_Entity_With_Checks; ------------------------------ -- Set_Invalid_Scalar_Value -- ------------------------------ procedure Set_Invalid_Scalar_Value (Scal_Typ : Float_Scalar_Id; Value : Ureal) is Slot : Ureal renames Invalid_Floats (Scal_Typ); begin -- Detect an attempt to set a different value for the same scalar type pragma Assert (Slot = No_Ureal); Slot := Value; end Set_Invalid_Scalar_Value; ------------------------------ -- Set_Invalid_Scalar_Value -- ------------------------------ procedure Set_Invalid_Scalar_Value (Scal_Typ : Integer_Scalar_Id; Value : Uint) is Slot : Uint renames Invalid_Integers (Scal_Typ); begin -- Detect an attempt to set a different value for the same scalar type pragma Assert (Slot = No_Uint); Slot := Value; end Set_Invalid_Scalar_Value; ------------------------ -- Set_Name_Entity_Id -- ------------------------ procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is begin Set_Name_Table_Int (Id, Int (Val)); end Set_Name_Entity_Id; --------------------- -- Set_Next_Actual -- --------------------- procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is begin if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); end if; end Set_Next_Actual; ---------------------------------- -- Set_Optimize_Alignment_Flags -- ---------------------------------- procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is begin if Optimize_Alignment = 'S' then Set_Optimize_Alignment_Space (E); elsif Optimize_Alignment = 'T' then Set_Optimize_Alignment_Time (E); end if; end Set_Optimize_Alignment_Flags; ----------------------- -- Set_Public_Status -- ----------------------- procedure Set_Public_Status (Id : Entity_Id) is S : constant Entity_Id := Current_Scope; function Within_HSS_Or_If (E : Entity_Id) return Boolean; -- Determines if E is defined within handled statement sequence or -- an if statement, returns True if so, False otherwise. ---------------------- -- Within_HSS_Or_If -- ---------------------- function Within_HSS_Or_If (E : Entity_Id) return Boolean is N : Node_Id; begin N := Declaration_Node (E); loop N := Parent (N); if No (N) then return False; elsif Nkind (N) in N_Handled_Sequence_Of_Statements | N_If_Statement then return True; end if; end loop; end Within_HSS_Or_If; -- Start of processing for Set_Public_Status begin -- Everything in the scope of Standard is public if S = Standard_Standard then Set_Is_Public (Id); -- Entity is definitely not public if enclosing scope is not public elsif not Is_Public (S) then return; -- An object or function declaration that occurs in a handled sequence -- of statements or within an if statement is the declaration for a -- temporary object or local subprogram generated by the expander. It -- never needs to be made public and furthermore, making it public can -- cause back end problems. elsif Nkind (Parent (Id)) in N_Object_Declaration | N_Function_Specification and then Within_HSS_Or_If (Id) then return; -- Entities in public packages or records are public elsif Ekind (S) = E_Package or Is_Record_Type (S) then Set_Is_Public (Id); -- The bounds of an entry family declaration can generate object -- declarations that are visible to the back-end, e.g. in the -- the declaration of a composite type that contains tasks. elsif Is_Concurrent_Type (S) and then not Has_Completion (S) and then Nkind (Parent (Id)) = N_Object_Declaration then Set_Is_Public (Id); end if; end Set_Public_Status; ----------------------------- -- Set_Referenced_Modified -- ----------------------------- procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is Pref : Node_Id; begin -- Deal with indexed or selected component where prefix is modified if Nkind (N) in N_Indexed_Component | N_Selected_Component then Pref := Prefix (N); -- If prefix is access type, then it is the designated object that is -- being modified, which means we have no entity to set the flag on. if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then return; -- Otherwise chase the prefix else Set_Referenced_Modified (Pref, Out_Param); end if; -- Otherwise see if we have an entity name (only other case to process) elsif Is_Entity_Name (N) and then Present (Entity (N)) then Set_Referenced_As_LHS (Entity (N), not Out_Param); Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); end if; end Set_Referenced_Modified; ------------------ -- Set_Rep_Info -- ------------------ procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is begin Set_Is_Atomic (T1, Is_Atomic (T2)); Set_Is_Independent (T1, Is_Independent (T2)); Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2)); if Is_Base_Type (T1) then Set_Is_Volatile (T1, Is_Volatile (T2)); end if; end Set_Rep_Info; ---------------------------- -- Set_Scope_Is_Transient -- ---------------------------- procedure Set_Scope_Is_Transient (V : Boolean := True) is begin Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; end Set_Scope_Is_Transient; ------------------- -- Set_Size_Info -- ------------------- procedure Set_Size_Info (T1, T2 : Entity_Id) is begin -- We copy Esize, but not RM_Size, since in general RM_Size is -- subtype specific and does not get inherited by all subtypes. Set_Esize (T1, Esize (T2)); Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); if Is_Discrete_Or_Fixed_Point_Type (T1) and then Is_Discrete_Or_Fixed_Point_Type (T2) then Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); end if; Set_Alignment (T1, Alignment (T2)); end Set_Size_Info; ------------------------------ -- Should_Ignore_Pragma_Par -- ------------------------------ function Should_Ignore_Pragma_Par (Prag_Name : Name_Id) return Boolean is pragma Assert (Compiler_State = Parsing); -- This one can't work during semantic analysis, because we don't have a -- correct Current_Source_File. Result : constant Boolean := Get_Name_Table_Boolean3 (Prag_Name) and then not Is_Internal_File_Name (File_Name (Current_Source_File)); begin return Result; end Should_Ignore_Pragma_Par; ------------------------------ -- Should_Ignore_Pragma_Sem -- ------------------------------ function Should_Ignore_Pragma_Sem (N : Node_Id) return Boolean is pragma Assert (Compiler_State = Analyzing); Prag_Name : constant Name_Id := Pragma_Name (N); Result : constant Boolean := Get_Name_Table_Boolean3 (Prag_Name) and then not In_Internal_Unit (N); begin return Result; end Should_Ignore_Pragma_Sem; -------------------- -- Static_Boolean -- -------------------- function Static_Boolean (N : Node_Id) return Uint is begin Analyze_And_Resolve (N, Standard_Boolean); if N = Error or else Error_Posted (N) or else Etype (N) = Any_Type then return No_Uint; end if; if Is_OK_Static_Expression (N) then if not Raises_Constraint_Error (N) then return Expr_Value (N); else return No_Uint; end if; elsif Etype (N) = Any_Type then return No_Uint; else Flag_Non_Static_Expr ("static boolean expression required here", N); return No_Uint; end if; end Static_Boolean; -------------------- -- Static_Integer -- -------------------- function Static_Integer (N : Node_Id) return Uint is begin Analyze_And_Resolve (N, Any_Integer); if N = Error or else Error_Posted (N) or else Etype (N) = Any_Type then return No_Uint; end if; if Is_OK_Static_Expression (N) then if not Raises_Constraint_Error (N) then return Expr_Value (N); else return No_Uint; end if; elsif Etype (N) = Any_Type then return No_Uint; else Flag_Non_Static_Expr ("static integer expression required here", N); return No_Uint; end if; end Static_Integer; ------------------------------- -- Statically_Denotes_Entity -- ------------------------------- function Statically_Denotes_Entity (N : Node_Id) return Boolean is E : Entity_Id; begin if not Is_Entity_Name (N) then return False; else E := Entity (N); end if; return Nkind (Parent (E)) /= N_Object_Renaming_Declaration or else Is_Prival (E) or else Statically_Denotes_Entity (Renamed_Object (E)); end Statically_Denotes_Entity; ------------------------------- -- Statically_Denotes_Object -- ------------------------------- function Statically_Denotes_Object (N : Node_Id) return Boolean is begin return Statically_Denotes_Entity (N) and then Is_Object_Reference (N); end Statically_Denotes_Object; -------------------------- -- Statically_Different -- -------------------------- function Statically_Different (E1, E2 : Node_Id) return Boolean is R1 : constant Node_Id := Get_Referenced_Object (E1); R2 : constant Node_Id := Get_Referenced_Object (E2); begin return Is_Entity_Name (R1) and then Is_Entity_Name (R2) and then Entity (R1) /= Entity (R2) and then not Is_Formal (Entity (R1)) and then not Is_Formal (Entity (R2)); end Statically_Different; ----------------------------- -- Statically_Names_Object -- ----------------------------- function Statically_Names_Object (N : Node_Id) return Boolean is begin if Statically_Denotes_Object (N) then return True; elsif Is_Entity_Name (N) then declare E : constant Entity_Id := Entity (N); begin return Nkind (Parent (E)) = N_Object_Renaming_Declaration and then Statically_Names_Object (Renamed_Object (E)); end; end if; case Nkind (N) is when N_Indexed_Component => if Is_Access_Type (Etype (Prefix (N))) then -- treat implicit dereference same as explicit return False; end if; if not Is_Constrained (Etype (Prefix (N))) then return False; end if; declare Indx : Node_Id := First_Index (Etype (Prefix (N))); Expr : Node_Id := First (Expressions (N)); Index_Subtype : Node_Id; begin loop Index_Subtype := Etype (Indx); if not Is_Static_Subtype (Index_Subtype) then return False; end if; if not Is_OK_Static_Expression (Expr) then return False; end if; declare Index_Value : constant Uint := Expr_Value (Expr); Low_Value : constant Uint := Expr_Value (Type_Low_Bound (Index_Subtype)); High_Value : constant Uint := Expr_Value (Type_High_Bound (Index_Subtype)); begin if (Index_Value < Low_Value) or (Index_Value > High_Value) then return False; end if; end; Next_Index (Indx); Expr := Next (Expr); pragma Assert ((Present (Indx) = Present (Expr)) or else (Serious_Errors_Detected > 0)); exit when not (Present (Indx) and Present (Expr)); end loop; end; when N_Selected_Component => if Is_Access_Type (Etype (Prefix (N))) then -- treat implicit dereference same as explicit return False; end if; if Ekind (Entity (Selector_Name (N))) not in E_Component | E_Discriminant then return False; end if; declare Comp : constant Entity_Id := Original_Record_Component (Entity (Selector_Name (N))); begin -- AI12-0373 confirms that we should not call -- Has_Discriminant_Dependent_Constraint here which would be -- too strong. if Is_Declared_Within_Variant (Comp) then return False; end if; end; when others => -- includes N_Slice, N_Explicit_Dereference return False; end case; pragma Assert (Present (Prefix (N))); return Statically_Names_Object (Prefix (N)); end Statically_Names_Object; --------------------------------- -- String_From_Numeric_Literal -- --------------------------------- function String_From_Numeric_Literal (N : Node_Id) return String_Id is Loc : constant Source_Ptr := Sloc (N); Sbuffer : constant Source_Buffer_Ptr := Source_Text (Get_Source_File_Index (Loc)); Src_Ptr : Source_Ptr := Loc; C : Character := Sbuffer (Src_Ptr); -- Current source program character function Belongs_To_Numeric_Literal (C : Character) return Boolean; -- Return True if C belongs to the numeric literal -------------------------------- -- Belongs_To_Numeric_Literal -- -------------------------------- function Belongs_To_Numeric_Literal (C : Character) return Boolean is begin case C is when '0' .. '9' | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' => return True; -- Make sure '+' or '-' is part of an exponent when '+' | '-' => declare Prev_C : constant Character := Sbuffer (Src_Ptr - 1); begin return Prev_C = 'e' or else Prev_C = 'E'; end; -- Other characters cannot belong to a numeric literal when others => return False; end case; end Belongs_To_Numeric_Literal; -- Start of processing for String_From_Numeric_Literal begin Start_String; while Belongs_To_Numeric_Literal (C) loop Store_String_Char (C); Src_Ptr := Src_Ptr + 1; C := Sbuffer (Src_Ptr); end loop; return End_String; end String_From_Numeric_Literal; -------------------------------------- -- Subject_To_Loop_Entry_Attributes -- -------------------------------------- function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is Stmt : Node_Id; begin Stmt := N; -- The expansion mechanism transform a loop subject to at least one -- 'Loop_Entry attribute into a conditional block. Infinite loops lack -- the conditional part. if Nkind (Stmt) in N_Block_Statement | N_If_Statement and then Nkind (Original_Node (N)) = N_Loop_Statement then Stmt := Original_Node (N); end if; return Nkind (Stmt) = N_Loop_Statement and then Present (Identifier (Stmt)) and then Present (Entity (Identifier (Stmt))) 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 -- --------------------- function Subprogram_Name (N : Node_Id) return String is Buf : Bounded_String; Ent : Node_Id := N; Nod : Node_Id; begin while Present (Ent) loop case Nkind (Ent) is when N_Subprogram_Body => Ent := Defining_Unit_Name (Specification (Ent)); exit; when N_Subprogram_Declaration => Nod := Corresponding_Body (Ent); if Present (Nod) then Ent := Nod; else Ent := Defining_Unit_Name (Specification (Ent)); end if; exit; when N_Subprogram_Instantiation | N_Package_Body | N_Package_Specification => Ent := Defining_Unit_Name (Ent); exit; when N_Protected_Type_Declaration => Ent := Corresponding_Body (Ent); exit; when N_Protected_Body | N_Task_Body => Ent := Defining_Identifier (Ent); exit; when others => null; end case; Ent := Parent (Ent); end loop; if No (Ent) then return "unknown subprogram:unknown file:0:0"; end if; -- If the subprogram is a child unit, use its simple name to start the -- construction of the fully qualified name. if Nkind (Ent) = N_Defining_Program_Unit_Name then Ent := Defining_Identifier (Ent); end if; Append_Entity_Name (Buf, Ent); -- Append homonym number if needed if Nkind (N) in N_Entity and then Has_Homonym (N) then declare H : Entity_Id := Homonym (N); Nr : Nat := 1; begin while Present (H) loop if Scope (H) = Scope (N) then Nr := Nr + 1; end if; H := Homonym (H); end loop; if Nr > 1 then Append (Buf, '#'); Append (Buf, Nr); end if; end; end if; -- Append source location of Ent to Buf so that the string will -- look like "subp:file:line:col". declare Loc : constant Source_Ptr := Sloc (Ent); begin Append (Buf, ':'); Append (Buf, Reference_Name (Get_Source_File_Index (Loc))); Append (Buf, ':'); Append (Buf, Nat (Get_Logical_Line_Number (Loc))); Append (Buf, ':'); Append (Buf, Nat (Get_Column_Number (Loc))); end; return +Buf; end Subprogram_Name; ------------------------------- -- Support_Atomic_Primitives -- ------------------------------- function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is Size : Int; begin -- Verify the alignment of Typ is known if not Known_Alignment (Typ) then return False; end if; if Known_Static_Esize (Typ) then Size := UI_To_Int (Esize (Typ)); -- If the Esize (Object_Size) is unknown at compile time, look at the -- RM_Size (Value_Size) which may have been set by an explicit rep item. elsif Known_Static_RM_Size (Typ) then Size := UI_To_Int (RM_Size (Typ)); -- Otherwise, the size is considered to be unknown. else return False; end if; -- Check that the size of the component is 8, 16, 32, or 64 bits and -- that Typ is properly aligned. case Size is when 8 | 16 | 32 | 64 => return Size = UI_To_Int (Alignment (Typ)) * 8; when others => return False; end case; end Support_Atomic_Primitives; ----------------- -- Trace_Scope -- ----------------- procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is begin if Debug_Flag_W then for J in 0 .. Scope_Stack.Last loop Write_Str (" "); end loop; Write_Str (Msg); Write_Name (Chars (E)); Write_Str (" from "); Write_Location (Sloc (N)); Write_Eol; end if; end Trace_Scope; ----------------------- -- Transfer_Entities -- ----------------------- procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is procedure Set_Public_Status_Of (Id : Entity_Id); -- Set the Is_Public attribute of arbitrary entity Id by calling routine -- Set_Public_Status. If successful and Id denotes a record type, set -- the Is_Public attribute of its fields. -------------------------- -- Set_Public_Status_Of -- -------------------------- procedure Set_Public_Status_Of (Id : Entity_Id) is Field : Entity_Id; begin if not Is_Public (Id) then Set_Public_Status (Id); -- When the input entity is a public record type, ensure that all -- its internal fields are also exposed to the linker. The fields -- of a class-wide type are never made public. if Is_Public (Id) and then Is_Record_Type (Id) and then not Is_Class_Wide_Type (Id) then Field := First_Entity (Id); while Present (Field) loop Set_Is_Public (Field); Next_Entity (Field); end loop; end if; end if; end Set_Public_Status_Of; -- Local variables Full_Id : Entity_Id; Id : Entity_Id; -- Start of processing for Transfer_Entities begin Id := First_Entity (From); if Present (Id) then -- Merge the entity chain of the source scope with that of the -- destination scope. if Present (Last_Entity (To)) then Link_Entities (Last_Entity (To), Id); else Set_First_Entity (To, Id); end if; Set_Last_Entity (To, Last_Entity (From)); -- Inspect the entities of the source scope and update their Scope -- attribute. while Present (Id) loop Set_Scope (Id, To); Set_Public_Status_Of (Id); -- Handle an internally generated full view for a private type if Is_Private_Type (Id) and then Present (Full_View (Id)) and then Is_Itype (Full_View (Id)) then Full_Id := Full_View (Id); Set_Scope (Full_Id, To); Set_Public_Status_Of (Full_Id); end if; Next_Entity (Id); end loop; Set_First_Entity (From, Empty); Set_Last_Entity (From, Empty); end if; end Transfer_Entities; ------------------------ -- Traverse_More_Func -- ------------------------ function Traverse_More_Func (Node : Node_Id) return Traverse_Final_Result is Processing_Itype : Boolean := False; -- Set to True while traversing the nodes under an Itype, to prevent -- looping on Itype handling during that traversal. function Process_More (N : Node_Id) return Traverse_Result; -- Wrapper over the Process callback to handle parts of the AST that -- are not normally traversed as syntactic children. function Traverse_Rec (N : Node_Id) return Traverse_Final_Result; -- Main recursive traversal implemented as an instantiation of -- Traverse_Func over a modified Process callback. ------------------ -- Process_More -- ------------------ function Process_More (N : Node_Id) return Traverse_Result is procedure Traverse_More (N : Node_Id; Res : in out Traverse_Result); procedure Traverse_More (L : List_Id; Res : in out Traverse_Result); -- Traverse a node or list and update the traversal result to value -- Abandon when needed. ------------------- -- Traverse_More -- ------------------- procedure Traverse_More (N : Node_Id; Res : in out Traverse_Result) is begin -- Do not process any more nodes if Abandon was reached if Res = Abandon then return; end if; if Traverse_Rec (N) = Abandon then Res := Abandon; end if; end Traverse_More; procedure Traverse_More (L : List_Id; Res : in out Traverse_Result) is N : Node_Id := First (L); begin -- Do not process any more nodes if Abandon was reached if Res = Abandon then return; end if; while Present (N) loop Traverse_More (N, Res); Next (N); end loop; end Traverse_More; -- Local variables Node : Node_Id; Result : Traverse_Result; -- Start of processing for Process_More begin -- Initial callback to Process. Return immediately on Skip/Abandon. -- Otherwise update the value of Node for further processing of -- non-syntactic children. Result := Process (N); case Result is when OK => Node := N; when OK_Orig => Node := Original_Node (N); when Skip => return Skip; when Abandon => return Abandon; end case; -- Process the relevant semantic children which are a logical part of -- the AST under this node before returning for the processing of -- syntactic children. -- Start with all non-syntactic lists of action nodes case Nkind (Node) is when N_Component_Association => Traverse_More (Loop_Actions (Node), Result); when N_Elsif_Part => Traverse_More (Condition_Actions (Node), Result); when N_Short_Circuit => Traverse_More (Actions (Node), Result); when N_Case_Expression_Alternative => Traverse_More (Actions (Node), Result); when N_Iterated_Component_Association => Traverse_More (Loop_Actions (Node), Result); when N_Iteration_Scheme => Traverse_More (Condition_Actions (Node), Result); when N_If_Expression => Traverse_More (Then_Actions (Node), Result); Traverse_More (Else_Actions (Node), Result); -- Various nodes have a field Actions as a syntactic node, -- so it will be traversed in the regular syntactic traversal. when N_Compilation_Unit_Aux | N_Compound_Statement | N_Expression_With_Actions | N_Freeze_Entity => null; when others => null; end case; -- If Process_Itypes is True, process unattached nodes which come -- from Itypes. This only concerns currently ranges of scalar -- (possibly as index) types. This traversal is protected against -- looping with Processing_Itype. if Process_Itypes and then not Processing_Itype and then Nkind (Node) in N_Has_Etype and then Present (Etype (Node)) and then Is_Itype (Etype (Node)) then declare Typ : constant Entity_Id := Etype (Node); begin Processing_Itype := True; case Ekind (Typ) is when Scalar_Kind => Traverse_More (Scalar_Range (Typ), Result); when Array_Kind => declare Index : Node_Id := First_Index (Typ); Rng : Node_Id; begin while Present (Index) loop if Nkind (Index) in N_Has_Entity then Rng := Scalar_Range (Entity (Index)); else Rng := Index; end if; Traverse_More (Rng, Result); Next_Index (Index); end loop; end; when others => null; end case; Processing_Itype := False; end; end if; return Result; end Process_More; -- Define Traverse_Rec as a renaming of the instantiation, as an -- instantiation cannot complete a previous spec. function Traverse_Recursive is new Traverse_Func (Process_More); function Traverse_Rec (N : Node_Id) return Traverse_Final_Result renames Traverse_Recursive; -- Start of processing for Traverse_More_Func begin return Traverse_Rec (Node); end Traverse_More_Func; ------------------------ -- Traverse_More_Proc -- ------------------------ procedure Traverse_More_Proc (Node : Node_Id) is function Traverse is new Traverse_More_Func (Process, Process_Itypes); Discard : Traverse_Final_Result; pragma Warnings (Off, Discard); begin Discard := Traverse (Node); end Traverse_More_Proc; ----------------------- -- Type_Access_Level -- ----------------------- function Type_Access_Level (Typ : Entity_Id) return Uint is Btyp : Entity_Id; begin Btyp := Base_Type (Typ); -- 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 -- 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. if 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)); 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 -- ------------------------------------ function Type_Without_Stream_Operation (T : Entity_Id; Op : TSS_Name_Type := TSS_Null) return Entity_Id is BT : constant Entity_Id := Base_Type (T); Op_Missing : Boolean; begin if not Restriction_Active (No_Default_Stream_Attributes) then return Empty; end if; if Is_Elementary_Type (T) then if Op = TSS_Null then Op_Missing := No (TSS (BT, TSS_Stream_Read)) or else No (TSS (BT, TSS_Stream_Write)); else Op_Missing := No (TSS (BT, Op)); end if; if Op_Missing then return T; else return Empty; end if; elsif Is_Array_Type (T) then return Type_Without_Stream_Operation (Component_Type (T), Op); elsif Is_Record_Type (T) then declare Comp : Entity_Id; C_Typ : Entity_Id; begin Comp := First_Component (T); while Present (Comp) loop C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); if Present (C_Typ) then return C_Typ; end if; Next_Component (Comp); end loop; return Empty; end; elsif Is_Private_Type (T) and then Present (Full_View (T)) then return Type_Without_Stream_Operation (Full_View (T), Op); else return Empty; end if; end Type_Without_Stream_Operation; --------------------- -- Ultimate_Prefix -- --------------------- function Ultimate_Prefix (N : Node_Id) return Node_Id is Pref : Node_Id; begin Pref := N; while Nkind (Pref) in N_Explicit_Dereference | N_Indexed_Component | N_Selected_Component | N_Slice loop Pref := Prefix (Pref); end loop; return Pref; end Ultimate_Prefix; ---------------------------- -- Unique_Defining_Entity -- ---------------------------- function Unique_Defining_Entity (N : Node_Id) return Entity_Id is begin return Unique_Entity (Defining_Entity (N)); end Unique_Defining_Entity; ------------------- -- Unique_Entity -- ------------------- function Unique_Entity (E : Entity_Id) return Entity_Id is U : Entity_Id := E; P : Node_Id; begin case Ekind (E) is when E_Constant => if Present (Full_View (E)) then U := Full_View (E); end if; when Entry_Kind => if Nkind (Parent (E)) = N_Entry_Body then declare Prot_Item : Entity_Id; Prot_Type : Entity_Id; begin if Ekind (E) = E_Entry then Prot_Type := Scope (E); -- Bodies of entry families are nested within an extra scope -- that contains an entry index declaration. else Prot_Type := Scope (Scope (E)); end if; -- A protected type may be declared as a private type, in -- which case we need to get its full view. if Is_Private_Type (Prot_Type) then Prot_Type := Full_View (Prot_Type); end if; -- Full view may not be present on error, in which case -- return E by default. if Present (Prot_Type) then pragma Assert (Ekind (Prot_Type) = E_Protected_Type); -- Traverse the entity list of the protected type and -- locate an entry declaration which matches the entry -- body. Prot_Item := First_Entity (Prot_Type); while Present (Prot_Item) loop if Ekind (Prot_Item) in Entry_Kind and then Corresponding_Body (Parent (Prot_Item)) = E then U := Prot_Item; exit; end if; Next_Entity (Prot_Item); end loop; end if; end; end if; when Formal_Kind => if Present (Spec_Entity (E)) then U := Spec_Entity (E); end if; when E_Package_Body => P := Parent (E); if Nkind (P) = N_Defining_Program_Unit_Name then P := Parent (P); end if; if Nkind (P) = N_Package_Body and then Present (Corresponding_Spec (P)) then U := Corresponding_Spec (P); elsif Nkind (P) = N_Package_Body_Stub and then Present (Corresponding_Spec_Of_Stub (P)) then U := Corresponding_Spec_Of_Stub (P); end if; when E_Protected_Body => P := Parent (E); if Nkind (P) = N_Protected_Body and then Present (Corresponding_Spec (P)) then U := Corresponding_Spec (P); elsif Nkind (P) = N_Protected_Body_Stub and then Present (Corresponding_Spec_Of_Stub (P)) then U := Corresponding_Spec_Of_Stub (P); if Is_Single_Protected_Object (U) then U := Etype (U); end if; end if; if Is_Private_Type (U) then U := Full_View (U); end if; when E_Subprogram_Body => P := Parent (E); if Nkind (P) = N_Defining_Program_Unit_Name then P := Parent (P); end if; P := Parent (P); if Nkind (P) = N_Subprogram_Body and then Present (Corresponding_Spec (P)) then U := Corresponding_Spec (P); elsif Nkind (P) = N_Subprogram_Body_Stub and then Present (Corresponding_Spec_Of_Stub (P)) then U := Corresponding_Spec_Of_Stub (P); elsif Nkind (P) = N_Subprogram_Renaming_Declaration then U := Corresponding_Spec (P); end if; when E_Task_Body => P := Parent (E); if Nkind (P) = N_Task_Body and then Present (Corresponding_Spec (P)) then U := Corresponding_Spec (P); elsif Nkind (P) = N_Task_Body_Stub and then Present (Corresponding_Spec_Of_Stub (P)) then U := Corresponding_Spec_Of_Stub (P); if Is_Single_Task_Object (U) then U := Etype (U); end if; end if; if Is_Private_Type (U) then U := Full_View (U); end if; when Type_Kind => if Present (Full_View (E)) then U := Full_View (E); end if; when others => null; end case; return U; end Unique_Entity; ----------------- -- Unique_Name -- ----------------- function Unique_Name (E : Entity_Id) return String is -- Local subprograms function Add_Homonym_Suffix (E : Entity_Id) return String; function This_Name return String; ------------------------ -- Add_Homonym_Suffix -- ------------------------ function Add_Homonym_Suffix (E : Entity_Id) return String is -- Names in E_Subprogram_Body or E_Package_Body entities are not -- reliable, as they may not include the overloading suffix. -- Instead, when looking for the name of E or one of its enclosing -- scope, we get the name of the corresponding Unique_Entity. U : constant Entity_Id := Unique_Entity (E); Nam : constant String := Get_Name_String (Chars (U)); begin -- If E has homonyms but is not fully qualified, as done in -- GNATprove mode, append the homonym number on the fly. Strip the -- leading space character in the image of natural numbers. Also do -- not print the homonym value of 1. if Has_Homonym (U) then declare N : constant Pos := Homonym_Number (U); S : constant String := N'Img; begin if N > 1 then return Nam & "__" & S (2 .. S'Last); end if; end; end if; return Nam; end Add_Homonym_Suffix; --------------- -- This_Name -- --------------- function This_Name return String is begin return Add_Homonym_Suffix (E); end This_Name; -- Local variables U : constant Entity_Id := Unique_Entity (E); -- Start of processing for Unique_Name begin if E = Standard_Standard or else Has_Fully_Qualified_Name (E) then return This_Name; elsif Ekind (E) = E_Enumeration_Literal then return Unique_Name (Etype (E)) & "__" & This_Name; else declare S : constant Entity_Id := Scope (U); pragma Assert (Present (S)); begin -- Prefix names of predefined types with standard__, but leave -- names of user-defined packages and subprograms without prefix -- (even if technically they are nested in the Standard package). if S = Standard_Standard then if Ekind (U) = E_Package or else Is_Subprogram (U) then return This_Name; else return Unique_Name (S) & "__" & This_Name; end if; -- For intances of generic subprograms use the name of the related -- instance and skip the scope of its wrapper package. elsif Is_Wrapper_Package (S) then pragma Assert (Scope (S) = Scope (Related_Instance (S))); -- Wrapper package and the instantiation are in the same scope declare Related_Name : constant String := Add_Homonym_Suffix (Related_Instance (S)); Enclosing_Name : constant String := Unique_Name (Scope (S)) & "__" & Related_Name; begin if Is_Subprogram (U) and then not Is_Generic_Actual_Subprogram (U) then return Enclosing_Name; else return Enclosing_Name & "__" & This_Name; end if; end; elsif Is_Child_Unit (U) then return Child_Prefix & Unique_Name (S) & "__" & This_Name; else return Unique_Name (S) & "__" & This_Name; end if; end; end if; end Unique_Name; --------------------- -- Unit_Is_Visible -- --------------------- function Unit_Is_Visible (U : Entity_Id) return Boolean is Curr : constant Node_Id := Cunit (Current_Sem_Unit); Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean; -- For a child unit, check whether unit appears in a with_clause -- of a parent. function Unit_In_Context (Comp_Unit : Node_Id) return Boolean; -- Scan the context clause of one compilation unit looking for a -- with_clause for the unit in question. ---------------------------- -- Unit_In_Parent_Context -- ---------------------------- function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is begin if Unit_In_Context (Par_Unit) then return True; elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit))); else return False; end if; end Unit_In_Parent_Context; --------------------- -- Unit_In_Context -- --------------------- function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is Clause : Node_Id; begin Clause := First (Context_Items (Comp_Unit)); while Present (Clause) loop if Nkind (Clause) = N_With_Clause then if Library_Unit (Clause) = U then return True; -- The with_clause may denote a renaming of the unit we are -- looking for, eg. Text_IO which renames Ada.Text_IO. elsif Renamed_Entity (Entity (Name (Clause))) = Defining_Entity (Unit (U)) then return True; end if; end if; Next (Clause); end loop; return False; end Unit_In_Context; -- Start of processing for Unit_Is_Visible begin -- The currrent unit is directly visible if Curr = U then return True; elsif Unit_In_Context (Curr) then return True; -- If the current unit is a body, check the context of the spec elsif Nkind (Unit (Curr)) = N_Package_Body or else (Nkind (Unit (Curr)) = N_Subprogram_Body and then not Acts_As_Spec (Unit (Curr))) then if Unit_In_Context (Library_Unit (Curr)) then return True; end if; end if; -- If the spec is a child unit, examine the parents if Is_Child_Unit (Curr_Entity) then if Nkind (Unit (Curr)) in N_Unit_Body then return Unit_In_Parent_Context (Parent_Spec (Unit (Library_Unit (Curr)))); else return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); end if; else return False; end if; end Unit_Is_Visible; ------------------------------ -- Universal_Interpretation -- ------------------------------ function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is Index : Interp_Index; It : Interp; begin -- The argument may be a formal parameter of an operator or subprogram -- with multiple interpretations, or else an expression for an actual. if Nkind (Opnd) = N_Defining_Identifier or else not Is_Overloaded (Opnd) then if Etype (Opnd) = Universal_Integer or else Etype (Opnd) = Universal_Real then return Etype (Opnd); else return Empty; end if; else Get_First_Interp (Opnd, Index, It); while Present (It.Typ) loop if It.Typ = Universal_Integer or else It.Typ = Universal_Real then return It.Typ; end if; Get_Next_Interp (Index, It); end loop; return Empty; end if; end Universal_Interpretation; --------------- -- Unqualify -- --------------- function Unqualify (Expr : Node_Id) return Node_Id is begin -- Recurse to handle unlikely case of multiple levels of qualification if Nkind (Expr) = N_Qualified_Expression then return Unqualify (Expression (Expr)); -- Normal case, not a qualified expression else return Expr; end if; end Unqualify; ----------------- -- Unqual_Conv -- ----------------- function Unqual_Conv (Expr : Node_Id) return Node_Id is begin -- Recurse to handle unlikely case of multiple levels of qualification -- and/or conversion. if Nkind (Expr) in N_Qualified_Expression | N_Type_Conversion | N_Unchecked_Type_Conversion then return Unqual_Conv (Expression (Expr)); -- Normal case, not a qualified expression else return Expr; end if; end Unqual_Conv; -------------------- -- Validated_View -- -------------------- function Validated_View (Typ : Entity_Id) return Entity_Id is Continue : Boolean; Val_Typ : Entity_Id; begin Continue := True; Val_Typ := Base_Type (Typ); -- Obtain the full view of the input type by stripping away concurrency, -- derivations, and privacy. while Continue loop Continue := False; if Is_Concurrent_Type (Val_Typ) then if Present (Corresponding_Record_Type (Val_Typ)) then Continue := True; Val_Typ := Corresponding_Record_Type (Val_Typ); end if; elsif Is_Derived_Type (Val_Typ) then Continue := True; Val_Typ := Etype (Val_Typ); elsif Is_Private_Type (Val_Typ) then if Present (Underlying_Full_View (Val_Typ)) then Continue := True; Val_Typ := Underlying_Full_View (Val_Typ); elsif Present (Full_View (Val_Typ)) then Continue := True; Val_Typ := Full_View (Val_Typ); end if; end if; end loop; return Val_Typ; end Validated_View; ----------------------- -- Visible_Ancestors -- ----------------------- function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is List_1 : Elist_Id; List_2 : Elist_Id; Elmt : Elmt_Id; begin pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ)); -- Collect all the parents and progenitors of Typ. If the full-view of -- private parents and progenitors is available then it is used to -- generate the list of visible ancestors; otherwise their partial -- view is added to the resulting list. Collect_Parents (T => Typ, List => List_1, Use_Full_View => True); Collect_Interfaces (T => Typ, Ifaces_List => List_2, Exclude_Parents => True, Use_Full_View => True); -- Join the two lists. Avoid duplications because an interface may -- simultaneously be parent and progenitor of a type. Elmt := First_Elmt (List_2); while Present (Elmt) loop Append_Unique_Elmt (Node (Elmt), List_1); Next_Elmt (Elmt); end loop; return List_1; end Visible_Ancestors; ---------------------- -- Within_Init_Proc -- ---------------------- function Within_Init_Proc return Boolean is S : Entity_Id; begin S := Current_Scope; while not Is_Overloadable (S) loop if S = Standard_Standard then return False; else S := Scope (S); end if; end loop; return Is_Init_Proc (S); end Within_Init_Proc; --------------------------- -- Within_Protected_Type -- --------------------------- function Within_Protected_Type (E : Entity_Id) return Boolean is Scop : Entity_Id := Scope (E); begin while Present (Scop) loop if Ekind (Scop) = E_Protected_Type then return True; end if; Scop := Scope (Scop); end loop; return False; end Within_Protected_Type; ------------------ -- Within_Scope -- ------------------ function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is begin return Scope_Within_Or_Same (Scope (E), S); end Within_Scope; ---------------------------- -- Within_Subprogram_Call -- ---------------------------- function Within_Subprogram_Call (N : Node_Id) return Boolean is Par : Node_Id; begin -- Climb the parent chain looking for a function or procedure call Par := N; while Present (Par) loop if Nkind (Par) in N_Entry_Call_Statement | N_Function_Call | N_Procedure_Call_Statement then return True; -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then exit; end if; Par := Parent (Par); end loop; return False; end Within_Subprogram_Call; ---------------- -- Wrong_Type -- ---------------- procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); Matching_Field : Entity_Id; -- Entity to give a more precise suggestion on how to write a one- -- element positional aggregate. function Has_One_Matching_Field return Boolean; -- Determines if Expec_Type is a record type with a single component or -- discriminant whose type matches the found type or is one dimensional -- array whose component type matches the found type. In the case of -- one discriminant, we ignore the variant parts. That's not accurate, -- but good enough for the warning. ---------------------------- -- Has_One_Matching_Field -- ---------------------------- function Has_One_Matching_Field return Boolean is E : Entity_Id; begin Matching_Field := Empty; if Is_Array_Type (Expec_Type) and then Number_Dimensions (Expec_Type) = 1 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) then -- Use type name if available. This excludes multidimensional -- arrays and anonymous arrays. if Comes_From_Source (Expec_Type) then Matching_Field := Expec_Type; -- For an assignment, use name of target elsif Nkind (Parent (Expr)) = N_Assignment_Statement and then Is_Entity_Name (Name (Parent (Expr))) then Matching_Field := Entity (Name (Parent (Expr))); end if; return True; elsif not Is_Record_Type (Expec_Type) then return False; else E := First_Entity (Expec_Type); loop if No (E) then return False; elsif Ekind (E) not in E_Discriminant | E_Component or else Chars (E) in Name_uTag | Name_uParent then Next_Entity (E); else exit; end if; end loop; if not Covers (Etype (E), Found_Type) then return False; elsif Present (Next_Entity (E)) and then (Ekind (E) = E_Component or else Ekind (Next_Entity (E)) = E_Discriminant) then return False; else Matching_Field := E; return True; end if; end if; end Has_One_Matching_Field; -- Start of processing for Wrong_Type begin -- Don't output message if either type is Any_Type, or if a message -- has already been posted for this node. We need to do the latter -- check explicitly (it is ordinarily done in Errout), because we -- are using ! to force the output of the error messages. if Expec_Type = Any_Type or else Found_Type = Any_Type or else Error_Posted (Expr) then return; -- If one of the types is a Taft-Amendment type and the other it its -- completion, it must be an illegal use of a TAT in the spec, for -- which an error was already emitted. Avoid cascaded errors. elsif Is_Incomplete_Type (Expec_Type) and then Has_Completion_In_Body (Expec_Type) and then Full_View (Expec_Type) = Etype (Expr) then return; elsif Is_Incomplete_Type (Etype (Expr)) and then Has_Completion_In_Body (Etype (Expr)) and then Full_View (Etype (Expr)) = Expec_Type then return; -- In an instance, there is an ongoing problem with completion of -- types derived from private types. Their structure is what Gigi -- expects, but the Etype is the parent type rather than the derived -- private type itself. Do not flag error in this case. The private -- completion is an entity without a parent, like an Itype. Similarly, -- full and partial views may be incorrect in the instance. -- There is no simple way to insure that it is consistent ??? -- A similar view discrepancy can happen in an inlined body, for the -- same reason: inserted body may be outside of the original package -- and only partial views are visible at the point of insertion. -- If In_Generic_Actual (Expr) is True then we cannot assume that -- the successful semantic analysis of the generic guarantees anything -- useful about type checking of this instance, so we ignore -- In_Instance in that case. There may be cases where this is not -- right (the symptom would probably be rejecting something -- that ought to be accepted) but we don't currently have any -- concrete examples of this. elsif (In_Instance and then not In_Generic_Actual (Expr)) or else In_Inlined_Body then if Etype (Etype (Expr)) = Etype (Expected_Type) and then (Has_Private_Declaration (Expected_Type) or else Has_Private_Declaration (Etype (Expr))) and then No (Parent (Expected_Type)) then return; elsif Nkind (Parent (Expr)) = N_Qualified_Expression and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type then return; elsif Is_Private_Type (Expected_Type) and then Present (Full_View (Expected_Type)) and then Covers (Full_View (Expected_Type), Etype (Expr)) then return; -- Conversely, type of expression may be the private one elsif Is_Private_Type (Base_Type (Etype (Expr))) and then Full_View (Base_Type (Etype (Expr))) = Expected_Type then return; end if; end if; -- An interesting special check. If the expression is parenthesized -- and its type corresponds to the type of the sole component of the -- expected record type, or to the component type of the expected one -- dimensional array type, then assume we have a bad aggregate attempt. if Nkind (Expr) in N_Subexpr and then Paren_Count (Expr) /= 0 and then Has_One_Matching_Field then Error_Msg_N ("positional aggregate cannot have one component", Expr); if Present (Matching_Field) then if Is_Array_Type (Expec_Type) then Error_Msg_NE ("\write instead `&''First ='> ...`", Expr, Matching_Field); else Error_Msg_NE ("\write instead `& ='> ...`", Expr, Matching_Field); end if; end if; -- Another special check, if we are looking for a pool-specific access -- type and we found an E_Access_Attribute_Type, then we have the case -- of an Access attribute being used in a context which needs a pool- -- specific type, which is never allowed. The one extra check we make -- is that the expected designated type covers the Found_Type. elsif Is_Access_Type (Expec_Type) and then Ekind (Found_Type) = E_Access_Attribute_Type and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type and then Covers (Designated_Type (Expec_Type), Designated_Type (Found_Type)) then Error_Msg_N -- CODEFIX ("result must be general access type!", Expr); Error_Msg_NE -- CODEFIX ("add ALL to }!", Expr, Expec_Type); -- Another special check, if the expected type is an integer type, -- but the expression is of type System.Address, and the parent is -- an addition or subtraction operation whose left operand is the -- expression in question and whose right operand is of an integral -- type, then this is an attempt at address arithmetic, so give -- appropriate message. elsif Is_Integer_Type (Expec_Type) and then Is_RTE (Found_Type, RE_Address) and then Nkind (Parent (Expr)) in N_Op_Add | N_Op_Subtract and then Expr = Left_Opnd (Parent (Expr)) and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) then Error_Msg_N ("address arithmetic not predefined in package System", Parent (Expr)); Error_Msg_N ("\possible missing with/use of System.Storage_Elements", Parent (Expr)); return; -- If the expected type is an anonymous access type, as for access -- parameters and discriminants, the error is on the designated types. elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then if Comes_From_Source (Expec_Type) then Error_Msg_NE ("expected}!", Expr, Expec_Type); else Error_Msg_NE ("expected an access type with designated}", Expr, Designated_Type (Expec_Type)); end if; if Is_Access_Type (Found_Type) and then not Comes_From_Source (Found_Type) then Error_Msg_NE ("\\found an access type with designated}!", Expr, Designated_Type (Found_Type)); else if From_Limited_With (Found_Type) then Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); Error_Msg_Qual_Level := 99; Error_Msg_NE -- CODEFIX ("\\missing `WITH &;", Expr, Scope (Found_Type)); Error_Msg_Qual_Level := 0; else Error_Msg_NE ("found}!", Expr, Found_Type); end if; end if; -- Normal case of one type found, some other type expected else -- If the names of the two types are the same, see if some number -- of levels of qualification will help. Don't try more than three -- levels, and if we get to standard, it's no use (and probably -- represents an error in the compiler) Also do not bother with -- internal scope names. declare Expec_Scope : Entity_Id; Found_Scope : Entity_Id; begin Expec_Scope := Expec_Type; Found_Scope := Found_Type; for Levels in Nat range 0 .. 3 loop if Chars (Expec_Scope) /= Chars (Found_Scope) then Error_Msg_Qual_Level := Levels; exit; end if; Expec_Scope := Scope (Expec_Scope); Found_Scope := Scope (Found_Scope); exit when Expec_Scope = Standard_Standard or else Found_Scope = Standard_Standard or else not Comes_From_Source (Expec_Scope) or else not Comes_From_Source (Found_Scope); end loop; end; if Is_Record_Type (Expec_Type) and then Present (Corresponding_Remote_Type (Expec_Type)) then Error_Msg_NE ("expected}!", Expr, Corresponding_Remote_Type (Expec_Type)); else Error_Msg_NE ("expected}!", Expr, Expec_Type); end if; if Is_Entity_Name (Expr) and then Is_Package_Or_Generic_Package (Entity (Expr)) then Error_Msg_N ("\\found package name!", Expr); elsif Is_Entity_Name (Expr) and then Ekind (Entity (Expr)) in E_Procedure | E_Generic_Procedure then if Ekind (Expec_Type) = E_Access_Subprogram_Type then Error_Msg_N ("found procedure name, possibly missing Access attribute!", Expr); else Error_Msg_N ("\\found procedure name instead of function!", Expr); end if; elsif Nkind (Expr) = N_Function_Call and then Ekind (Expec_Type) = E_Access_Subprogram_Type and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) and then No (Parameter_Associations (Expr)) then Error_Msg_N ("found function name, possibly missing Access attribute!", Expr); -- Catch common error: a prefix or infix operator which is not -- directly visible because the type isn't. elsif Nkind (Expr) in N_Op and then Is_Overloaded (Expr) and then not Is_Immediately_Visible (Expec_Type) and then not Is_Potentially_Use_Visible (Expec_Type) and then not In_Use (Expec_Type) and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) then Error_Msg_N ("operator of the type is not directly visible!", Expr); elsif Ekind (Found_Type) = E_Void and then Present (Parent (Found_Type)) and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration then Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); else Error_Msg_NE ("\\found}!", Expr, Found_Type); end if; -- A special check for cases like M1 and M2 = 0 where M1 and M2 are -- of the same modular type, and (M1 and M2) = 0 was intended. if Expec_Type = Standard_Boolean and then Is_Modular_Integer_Type (Found_Type) and then Nkind (Parent (Expr)) in N_Op_And | N_Op_Or | N_Op_Xor and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare then declare Op : constant Node_Id := Right_Opnd (Parent (Expr)); L : constant Node_Id := Left_Opnd (Op); R : constant Node_Id := Right_Opnd (Op); begin -- The case for the message is when the left operand of the -- comparison is the same modular type, or when it is an -- integer literal (or other universal integer expression), -- which would have been typed as the modular type if the -- parens had been there. if (Etype (L) = Found_Type or else Etype (L) = Universal_Integer) and then Is_Integer_Type (Etype (R)) then Error_Msg_N ("\\possible missing parens for modular operation", Expr); end if; end; end if; -- Reset error message qualification indication Error_Msg_Qual_Level := 0; end if; end Wrong_Type; -------------------------------- -- Yields_Synchronized_Object -- -------------------------------- function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is Has_Sync_Comp : Boolean := False; Id : Entity_Id; begin -- An array type yields a synchronized object if its component type -- yields a synchronized object. if Is_Array_Type (Typ) then return Yields_Synchronized_Object (Component_Type (Typ)); -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object -- yields a synchronized object by default. elsif Is_Descendant_Of_Suspension_Object (Typ) then return True; -- A protected type yields a synchronized object by default elsif Is_Protected_Type (Typ) then return True; -- A record type or type extension yields a synchronized object when its -- discriminants (if any) lack default values and all components are of -- a type that yields a synchronized object. elsif Is_Record_Type (Typ) then -- Inspect all entities defined in the scope of the type, looking for -- components of a type that does not yield a synchronized object or -- for discriminants with default values. Id := First_Entity (Typ); while Present (Id) loop if Comes_From_Source (Id) then if Ekind (Id) = E_Component then if Yields_Synchronized_Object (Etype (Id)) then Has_Sync_Comp := True; -- The component does not yield a synchronized object else return False; end if; elsif Ekind (Id) = E_Discriminant and then Present (Expression (Parent (Id))) then return False; end if; end if; Next_Entity (Id); end loop; -- Ensure that the parent type of a type extension yields a -- synchronized object. if Etype (Typ) /= Typ and then not Is_Private_Type (Etype (Typ)) and then not Yields_Synchronized_Object (Etype (Typ)) then return False; end if; -- If we get here, then all discriminants lack default values and all -- components are of a type that yields a synchronized object. return Has_Sync_Comp; -- A synchronized interface type yields a synchronized object by default elsif Is_Synchronized_Interface (Typ) then return True; -- A task type yields a synchronized object by default elsif Is_Task_Type (Typ) then return True; -- A private type yields a synchronized object if its underlying type -- does. elsif Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then return Yields_Synchronized_Object (Underlying_Type (Typ)); -- Otherwise the type does not yield a synchronized object else return False; end if; end Yields_Synchronized_Object; --------------------------- -- Yields_Universal_Type -- --------------------------- function Yields_Universal_Type (N : Node_Id) return Boolean is begin -- Integer and real literals are of a universal type if Nkind (N) in N_Integer_Literal | N_Real_Literal then return True; -- The values of certain attributes are of a universal type elsif Nkind (N) = N_Attribute_Reference then return Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N))); -- ??? There are possibly other cases to consider else return False; end if; end Yields_Universal_Type; package body Interval_Lists is procedure Check_Consistency (Intervals : Discrete_Interval_List); -- Check that list is sorted, lacks null intervals, and has gaps -- between intervals. function Chosen_Interval (Choice : Node_Id) return Discrete_Interval; -- Given an element of a Discrete_Choices list, a -- Static_Discrete_Predicate list, or an Others_Discrete_Choices -- list (but not an N_Others_Choice node) return the corresponding -- interval. If an element that does not represent a single -- contiguous interval due to a static predicate (or which -- represents a single contiguous interval whose bounds depend on -- a static predicate) is encountered, then that is an error on the -- part of whoever built the list in question. function In_Interval (Value : Uint; Interval : Discrete_Interval) return Boolean; -- Does the given value lie within the given interval? procedure Normalize_Interval_List (List : in out Discrete_Interval_List; Last : out Nat); -- Perform sorting and merging as required by Check_Consistency. ------------------------- -- Aggregate_Intervals -- ------------------------- function Aggregate_Intervals (N : Node_Id) return Discrete_Interval_List is pragma Assert (Nkind (N) = N_Aggregate and then Is_Array_Type (Etype (N))); function Unmerged_Intervals_Count return Nat; -- Count the number of intervals given in the aggregate N; the others -- choice (if present) is not taken into account. function Unmerged_Intervals_Count return Nat is Count : Nat := 0; Choice : Node_Id; Comp : Node_Id; begin Comp := First (Component_Associations (N)); while Present (Comp) loop Choice := First (Choices (Comp)); while Present (Choice) loop if Nkind (Choice) /= N_Others_Choice then Count := Count + 1; end if; Next (Choice); end loop; Next (Comp); end loop; return Count; end Unmerged_Intervals_Count; -- Local variables Comp : Node_Id; Max_I : constant Nat := Unmerged_Intervals_Count; Intervals : Discrete_Interval_List (1 .. Max_I); Num_I : Nat := 0; -- Start of processing for Aggregate_Intervals begin -- No action needed if there are no intervals if Max_I = 0 then return Intervals; end if; -- Internally store all the unsorted intervals Comp := First (Component_Associations (N)); while Present (Comp) loop declare Choice_Intervals : constant Discrete_Interval_List := Choice_List_Intervals (Choices (Comp)); begin for J in Choice_Intervals'Range loop Num_I := Num_I + 1; Intervals (Num_I) := Choice_Intervals (J); end loop; end; Next (Comp); end loop; -- Normalize the lists sorting and merging the intervals declare Aggr_Intervals : Discrete_Interval_List (1 .. Num_I) := Intervals (1 .. Num_I); begin Normalize_Interval_List (Aggr_Intervals, Num_I); Check_Consistency (Aggr_Intervals (1 .. Num_I)); return Aggr_Intervals (1 .. Num_I); end; end Aggregate_Intervals; ------------------------ -- Check_Consistency -- ------------------------ procedure Check_Consistency (Intervals : Discrete_Interval_List) is begin if Serious_Errors_Detected > 0 then return; end if; -- low bound is 1 and high bound equals length pragma Assert (Intervals'First = 1 and Intervals'Last >= 0); for Idx in Intervals'Range loop -- each interval is non-null pragma Assert (Intervals (Idx).Low <= Intervals (Idx).High); if Idx /= Intervals'First then -- intervals are sorted with non-empty gaps between them pragma Assert (Intervals (Idx - 1).High < (Intervals (Idx).Low - 1)); null; end if; end loop; end Check_Consistency; --------------------------- -- Choice_List_Intervals -- --------------------------- function Choice_List_Intervals (Discrete_Choices : List_Id) return Discrete_Interval_List is function Unmerged_Choice_Count return Nat; -- The number of intervals before adjacent intervals are merged. --------------------------- -- Unmerged_Choice_Count -- --------------------------- function Unmerged_Choice_Count return Nat is Choice : Node_Id := First (Discrete_Choices); Count : Nat := 0; begin while Present (Choice) loop -- Non-contiguous choices involving static predicates -- have already been normalized away. if Nkind (Choice) = N_Others_Choice then Count := Count + List_Length (Others_Discrete_Choices (Choice)); else Count := Count + 1; -- an ordinary expression or range end if; Next (Choice); end loop; return Count; end Unmerged_Choice_Count; -- Local variables Choice : Node_Id := First (Discrete_Choices); Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count); Count : Nat := 0; -- Start of processing for Choice_List_Intervals begin while Present (Choice) loop if Nkind (Choice) = N_Others_Choice then declare Others_Choice : Node_Id := First (Others_Discrete_Choices (Choice)); begin while Present (Others_Choice) loop Count := Count + 1; Result (Count) := Chosen_Interval (Others_Choice); Next (Others_Choice); end loop; end; else Count := Count + 1; Result (Count) := Chosen_Interval (Choice); end if; Next (Choice); end loop; pragma Assert (Count = Result'Last); Normalize_Interval_List (Result, Count); Check_Consistency (Result (1 .. Count)); return Result (1 .. Count); end Choice_List_Intervals; --------------------- -- Chosen_Interval -- --------------------- function Chosen_Interval (Choice : Node_Id) return Discrete_Interval is begin case Nkind (Choice) is when N_Range => return (Low => Expr_Value (Low_Bound (Choice)), High => Expr_Value (High_Bound (Choice))); when N_Subtype_Indication => declare Range_Exp : constant Node_Id := Range_Expression (Constraint (Choice)); begin return (Low => Expr_Value (Low_Bound (Range_Exp)), High => Expr_Value (High_Bound (Range_Exp))); end; when N_Others_Choice => raise Program_Error; when others => if Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)) then return (Low => Expr_Value (Type_Low_Bound (Entity (Choice))), High => Expr_Value (Type_High_Bound (Entity (Choice)))); else -- an expression return (Low | High => Expr_Value (Choice)); end if; end case; end Chosen_Interval; ----------------- -- In_Interval -- ----------------- function In_Interval (Value : Uint; Interval : Discrete_Interval) return Boolean is begin return Value >= Interval.Low and then Value <= Interval.High; end In_Interval; --------------- -- Is_Subset -- --------------- function Is_Subset (Subset, Of_Set : Discrete_Interval_List) return Boolean is -- Returns True iff for each interval of Subset we can find -- a single interval of Of_Set which contains the Subset interval. begin if Of_Set'Length = 0 then return Subset'Length = 0; end if; declare Set_Index : Pos range Of_Set'Range := Of_Set'First; begin for Ss_Idx in Subset'Range loop while not In_Interval (Value => Subset (Ss_Idx).Low, Interval => Of_Set (Set_Index)) loop if Set_Index = Of_Set'Last then return False; end if; Set_Index := Set_Index + 1; end loop; if not In_Interval (Value => Subset (Ss_Idx).High, Interval => Of_Set (Set_Index)) then return False; end if; end loop; end; return True; end Is_Subset; ----------------------------- -- Normalize_Interval_List -- ----------------------------- procedure Normalize_Interval_List (List : in out Discrete_Interval_List; Last : out Nat) is Temp_0 : Discrete_Interval := (others => Uint_0); -- Cope with Heap_Sort_G idiosyncrasies. function Is_Null (Idx : Pos) return Boolean; -- True iff List (Idx) defines a null range function Lt_Interval (Idx1, Idx2 : Natural) return Boolean; -- Compare two list elements procedure Merge_Intervals (Null_Interval_Count : out Nat); -- Merge contiguous ranges by replacing one with merged range and -- the other with a null value. Return a count of the null intervals, -- both preexisting and those introduced by merging. procedure Move_Interval (From, To : Natural); -- Copy interval from one location to another function Read_Interval (From : Natural) return Discrete_Interval; -- Normal array indexing unless From = 0 ---------------------- -- Interval_Sorting -- ---------------------- package Interval_Sorting is new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval); ------------- -- Is_Null -- ------------- function Is_Null (Idx : Pos) return Boolean is begin return List (Idx).Low > List (Idx).High; end Is_Null; ----------------- -- Lt_Interval -- ----------------- function Lt_Interval (Idx1, Idx2 : Natural) return Boolean is Elem1 : constant Discrete_Interval := Read_Interval (Idx1); Elem2 : constant Discrete_Interval := Read_Interval (Idx2); Null_1 : constant Boolean := Elem1.Low > Elem1.High; Null_2 : constant Boolean := Elem2.Low > Elem2.High; begin if Null_1 /= Null_2 then -- So that sorting moves null intervals to high end return Null_2; elsif Elem1.Low /= Elem2.Low then return Elem1.Low < Elem2.Low; else return Elem1.High < Elem2.High; end if; end Lt_Interval; --------------------- -- Merge_Intervals -- --------------------- procedure Merge_Intervals (Null_Interval_Count : out Nat) is Not_Null : Pos range List'Range; -- Index of the most recently examined non-null interval Null_Interval : constant Discrete_Interval := (Low => Uint_1, High => Uint_0); -- any null range ok here begin if List'Length = 0 or else Is_Null (List'First) then Null_Interval_Count := List'Length; -- no non-null elements, so no merge candidates return; end if; Null_Interval_Count := 0; Not_Null := List'First; for Idx in List'First + 1 .. List'Last loop if Is_Null (Idx) then -- all remaining elements are null Null_Interval_Count := Null_Interval_Count + List (Idx .. List'Last)'Length; return; elsif List (Idx).Low = List (Not_Null).High + 1 then -- Merge the two intervals into one; discard the other List (Not_Null).High := List (Idx).High; List (Idx) := Null_Interval; Null_Interval_Count := Null_Interval_Count + 1; else if List (Idx).Low <= List (Not_Null).High then raise Intervals_Error; end if; pragma Assert (List (Idx).Low > List (Not_Null).High); Not_Null := Idx; end if; end loop; end Merge_Intervals; ------------------- -- Move_Interval -- ------------------- procedure Move_Interval (From, To : Natural) is Rhs : constant Discrete_Interval := Read_Interval (From); begin if To = 0 then Temp_0 := Rhs; else List (Pos (To)) := Rhs; end if; end Move_Interval; ------------------- -- Read_Interval -- ------------------- function Read_Interval (From : Natural) return Discrete_Interval is begin if From = 0 then return Temp_0; else return List (Pos (From)); end if; end Read_Interval; -- Start of processing for Normalize_Interval_Lists begin Interval_Sorting.Sort (Natural (List'Last)); declare Null_Interval_Count : Nat; begin Merge_Intervals (Null_Interval_Count); Last := List'Last - Null_Interval_Count; if Null_Interval_Count /= 0 then -- Move null intervals introduced during merging to high end Interval_Sorting.Sort (Natural (List'Last)); end if; end; end Normalize_Interval_List; -------------------- -- Type_Intervals -- -------------------- function Type_Intervals (Typ : Entity_Id) return Discrete_Interval_List is begin if Has_Static_Predicate (Typ) then declare -- No sorting or merging needed SDP_List : constant List_Id := Static_Discrete_Predicate (Typ); Range_Or_Expr : Node_Id := First (SDP_List); Result : Discrete_Interval_List (1 .. List_Length (SDP_List)); begin for Idx in Result'Range loop Result (Idx) := Chosen_Interval (Range_Or_Expr); Next (Range_Or_Expr); end loop; pragma Assert (not Present (Range_Or_Expr)); Check_Consistency (Result); return Result; end; else declare Low : constant Uint := Expr_Value (Type_Low_Bound (Typ)); High : constant Uint := Expr_Value (Type_High_Bound (Typ)); begin if Low > High then declare Null_Array : Discrete_Interval_List (1 .. 0); begin return Null_Array; end; else return (1 => (Low => Low, High => High)); end if; end; end if; end Type_Intervals; end Interval_Lists; package body Old_Attr_Util is package body Conditional_Evaluation is type Determining_Expr_Context is (No_Context, If_Expr, Case_Expr, Short_Circuit_Op, Membership_Test); -- Determining_Expr_Context enumeration elements (except for -- No_Context) correspond to the list items in RM 6.1.1 definition -- of "determining expression". type Determining_Expr (Context : Determining_Expr_Context := No_Context) is record Expr : Node_Id := Empty; case Context is when Short_Circuit_Op => Is_And_Then : Boolean; when If_Expr => Is_Then_Part : Boolean; when Case_Expr => Alternatives : Node_Id; when Membership_Test => -- Given a subexpression of in a membership test -- in | | | -- the corresponding determining expression value would -- have First_Non_Preceding = (See RM 6.1.1). First_Non_Preceding : Node_Id; when No_Context => null; end case; end record; type Determining_Expression_List is array (Positive range <>) of Determining_Expr; function Determining_Condition (Det : Determining_Expr) return Node_Id; -- Given a determining expression, build a Boolean-valued -- condition that incorporates that expression into condition -- suitable for deciding whether to initialize a 'Old constant. -- Polarity is "True => initialize the constant". function Determining_Expressions (Expr : Node_Id; Expr_Trailer : Node_Id := Empty) return Determining_Expression_List; -- Given a conditionally evaluated expression, return its -- determining expressions. -- See RM 6.1.1 for definition of term "determining expressions". -- Tests should be performed in the order they occur in the -- array, with short circuiting. -- A determining expression need not be of a boolean type (e.g., -- it might be the determining expression of a case expression). -- The Expr_Trailer parameter should be defaulted for nonrecursive -- calls. function Is_Conditionally_Evaluated (Expr : Node_Id) return Boolean; -- See RM 6.1.1 for definition of term "conditionally evaluated". function Is_Known_On_Entry (Expr : Node_Id) return Boolean; -- See RM 6.1.1 for definition of term "known on entry". -------------------------------------- -- Conditional_Evaluation_Condition -- -------------------------------------- function Conditional_Evaluation_Condition (Expr : Node_Id) return Node_Id is Determiners : constant Determining_Expression_List := Determining_Expressions (Expr); Loc : constant Source_Ptr := Sloc (Expr); Result : Node_Id := New_Occurrence_Of (Standard_True, Loc); begin pragma Assert (Determiners'Length > 0 or else Is_Anonymous_Access_Type (Etype (Expr))); for I in Determiners'Range loop Result := Make_And_Then (Loc, Left_Opnd => Result, Right_Opnd => Determining_Condition (Determiners (I))); end loop; return Result; end Conditional_Evaluation_Condition; --------------------------- -- Determining_Condition -- --------------------------- function Determining_Condition (Det : Determining_Expr) return Node_Id is Loc : constant Source_Ptr := Sloc (Det.Expr); begin case Det.Context is when Short_Circuit_Op => if Det.Is_And_Then then return New_Copy_Tree (Det.Expr); else return Make_Op_Not (Loc, New_Copy_Tree (Det.Expr)); end if; when If_Expr => if Det.Is_Then_Part then return New_Copy_Tree (Det.Expr); else return Make_Op_Not (Loc, New_Copy_Tree (Det.Expr)); end if; when Case_Expr => declare Alts : List_Id := Discrete_Choices (Det.Alternatives); begin if Nkind (First (Alts)) = N_Others_Choice then Alts := Others_Discrete_Choices (First (Alts)); end if; return Make_In (Loc, Left_Opnd => New_Copy_Tree (Det.Expr), Right_Opnd => Empty, Alternatives => New_Copy_List (Alts)); end; when Membership_Test => declare function Copy_Prefix (List : List_Id; Suffix_Start : Node_Id) return List_Id; -- Given a list and a member of that list, returns -- a copy (similar to Nlists.New_Copy_List) of the -- prefix of the list up to but not including -- Suffix_Start. ----------------- -- Copy_Prefix -- ----------------- function Copy_Prefix (List : List_Id; Suffix_Start : Node_Id) return List_Id is Result : constant List_Id := New_List; Elem : Node_Id := First (List); begin while Elem /= Suffix_Start loop Append (New_Copy (Elem), Result); Next (Elem); pragma Assert (Present (Elem)); end loop; return Result; end Copy_Prefix; begin return Make_In (Loc, Left_Opnd => New_Copy_Tree (Left_Opnd (Det.Expr)), Right_Opnd => Empty, Alternatives => Copy_Prefix (Alternatives (Det.Expr), Det.First_Non_Preceding)); end; when No_Context => raise Program_Error; end case; end Determining_Condition; ----------------------------- -- Determining_Expressions -- ----------------------------- function Determining_Expressions (Expr : Node_Id; Expr_Trailer : Node_Id := Empty) return Determining_Expression_List is Par : Node_Id := Expr; Trailer : Node_Id := Expr_Trailer; Next_Element : Determining_Expr; begin -- We want to stop climbing up the tree when we reach the -- postcondition expression. An aspect_specification is -- transformed into a pragma, so reaching a pragma is our -- termination condition. This relies on the fact that -- pragmas are not allowed in declare expressions (or any -- other kind of expression). loop Next_Element.Expr := Empty; case Nkind (Par) is when N_Short_Circuit => if Trailer = Right_Opnd (Par) then Next_Element := (Expr => Left_Opnd (Par), Context => Short_Circuit_Op, Is_And_Then => Nkind (Par) = N_And_Then); end if; when N_If_Expression => -- For an expression like -- (if C1 then ... elsif C2 then ... else Foo'Old) -- the RM says are two determining expressions, -- C1 and C2. Our treatment here (where we only add -- one determining expression to the list) is ok because -- we will see two if-expressions, one within the other. if Trailer /= First (Expressions (Par)) then Next_Element := (Expr => First (Expressions (Par)), Context => If_Expr, Is_Then_Part => Trailer = Next (First (Expressions (Par)))); end if; when N_Case_Expression_Alternative => pragma Assert (Nkind (Parent (Par)) = N_Case_Expression); Next_Element := (Expr => Expression (Parent (Par)), Context => Case_Expr, Alternatives => Par); when N_Membership_Test => if Trailer /= Left_Opnd (Par) and then Is_Non_Empty_List (Alternatives (Par)) and then Trailer /= First (Alternatives (Par)) then pragma Assert (not Present (Right_Opnd (Par))); pragma Assert (Is_List_Member (Trailer) and then List_Containing (Trailer) = Alternatives (Par)); -- This one is different than the others -- because one element in the array result -- may represent multiple determining -- expressions (i.e. every member of the list -- Alternatives (Par) -- up to but not including Trailer). Next_Element := (Expr => Par, Context => Membership_Test, First_Non_Preceding => Trailer); end if; when N_Pragma => declare Previous : constant Node_Id := Prev (Par); Prev_Expr : Node_Id; begin if Nkind (Previous) = N_Pragma and then Split_PPC (Previous) then -- A source-level postcondition of -- A and then B and then C -- results in -- pragma Postcondition (A); -- pragma Postcondition (B); -- pragma Postcondition (C); -- with Split_PPC set to True on all but the -- last pragma. We account for that here. Prev_Expr := Expression (First (Pragma_Argument_Associations (Previous))); -- This Analyze call is needed in the case when -- Sem_Attr.Analyze_Attribute calls -- Eligible_For_Conditional_Evaluation. Without -- it, we end up passing an unanalyzed expression -- to Is_Known_On_Entry and that doesn't work. Analyze (Prev_Expr); Next_Element := (Expr => Prev_Expr, Context => Short_Circuit_Op, Is_And_Then => True); return Determining_Expressions (Prev_Expr) & Next_Element; else pragma Assert (Get_Pragma_Id (Pragma_Name (Par)) in Pragma_Post | Pragma_Postcondition | Pragma_Post_Class | Pragma_Refined_Post | Pragma_Check | Pragma_Contract_Cases); return (1 .. 0 => <>); -- recursion terminates here end if; end; when N_Empty => -- This case should be impossible, but if it does -- happen somehow then we don't want an infinite loop. raise Program_Error; when others => null; end case; Trailer := Par; Par := Parent (Par); if Present (Next_Element.Expr) then return Determining_Expressions (Expr => Par, Expr_Trailer => Trailer) & Next_Element; end if; end loop; end Determining_Expressions; ----------------------------------------- -- Eligible_For_Conditional_Evaluation -- ----------------------------------------- function Eligible_For_Conditional_Evaluation (Expr : Node_Id) return Boolean is begin if Is_Anonymous_Access_Type (Etype (Expr)) then -- The code in exp_attr.adb that also builds declarations -- for 'Old constants doesn't handle the anonymous access -- type case correctly, so we avoid that problem by -- returning True here. return True; elsif Ada_Version < Ada_2020 then return False; elsif not Is_Conditionally_Evaluated (Expr) then return False; else declare Determiners : constant Determining_Expression_List := Determining_Expressions (Expr); begin pragma Assert (Determiners'Length > 0); for Idx in Determiners'Range loop if not Is_Known_On_Entry (Determiners (Idx).Expr) then return False; end if; end loop; end; return True; end if; end Eligible_For_Conditional_Evaluation; -------------------------------- -- Is_Conditionally_Evaluated -- -------------------------------- function Is_Conditionally_Evaluated (Expr : Node_Id) return Boolean is -- There are three possibilities - the expression is -- unconditionally evaluated, repeatedly evaluated, or -- conditionally evaluated (see RM 6.1.1). So we implement -- this test by testing for the other two. function Is_Repeatedly_Evaluated (Expr : Node_Id) return Boolean; -- See RM 6.1.1 for definition of "repeatedly evaluated". ----------------------------- -- Is_Repeatedly_Evaluated -- ----------------------------- function Is_Repeatedly_Evaluated (Expr : Node_Id) return Boolean is Par : Node_Id := Expr; Trailer : Node_Id := Empty; -- There are three ways that an expression can be repeatedly -- evaluated. begin -- An aspect_specification is transformed into a pragma, so -- reaching a pragma is our termination condition. We want to -- stop when we reach the postcondition expression. while Nkind (Par) /= N_Pragma loop pragma Assert (Present (Par)); -- test for case 1: -- A subexpression of a predicate of a -- quantified_expression. if Nkind (Par) = N_Quantified_Expression and then Trailer = Condition (Par) then return True; end if; -- test for cases 2 and 3: -- A subexpression of the expression of an -- array_component_association or of -- a container_element_associatiation. if Nkind (Par) = N_Component_Association and then Trailer = Expression (Par) then -- determine whether Par is part of an array aggregate -- or a container aggregate declare Rover : Node_Id := Par; begin while Nkind (Rover) not in N_Has_Etype loop pragma Assert (Present (Rover)); Rover := Parent (Rover); end loop; if Present (Etype (Rover)) then if Is_Array_Type (Etype (Rover)) or else Is_Container_Aggregate (Rover) then return True; end if; end if; end; end if; Trailer := Par; Par := Parent (Par); end loop; return False; end Is_Repeatedly_Evaluated; begin if not Is_Potentially_Unevaluated (Expr) then -- the expression is unconditionally evaluated return False; elsif Is_Repeatedly_Evaluated (Expr) then return False; end if; return True; end Is_Conditionally_Evaluated; ----------------------- -- Is_Known_On_Entry -- ----------------------- function Is_Known_On_Entry (Expr : Node_Id) return Boolean is -- ??? This implementation is incomplete. See RM 6.1.1 -- for details. In particular, this function *should* return -- True for a function call (or a user-defined literal, which -- is equivalent to a function call) if all actual parameters -- (including defaulted params) are known on entry and the -- function has "Globals => null" specified; the current -- implementation will incorrectly return False in this case. function All_Exps_Known_On_Entry (Expr_List : List_Id) return Boolean; -- Given a list of expressions, returns False iff -- Is_Known_On_Entry is False for at least one list element. ----------------------------- -- All_Exps_Known_On_Entry -- ----------------------------- function All_Exps_Known_On_Entry (Expr_List : List_Id) return Boolean is Expr : Node_Id := First (Expr_List); begin while Present (Expr) loop if not Is_Known_On_Entry (Expr) then return False; end if; Next (Expr); end loop; return True; end All_Exps_Known_On_Entry; begin if Is_Static_Expression (Expr) then return True; end if; if Is_Attribute_Old (Expr) then return True; end if; declare Pref : Node_Id := Expr; begin loop case Nkind (Pref) is when N_Selected_Component => null; when N_Indexed_Component => if not All_Exps_Known_On_Entry (Expressions (Pref)) then return False; end if; when N_Slice => return False; -- just to be clear about this case when others => exit; end case; Pref := Prefix (Pref); end loop; if Is_Entity_Name (Pref) and then Is_Constant_Object (Entity (Pref)) then declare Obj : constant Entity_Id := Entity (Pref); Obj_Typ : constant Entity_Id := Etype (Obj); begin case Ekind (Obj) is when E_In_Parameter => if not Is_Elementary_Type (Obj_Typ) then return False; elsif Is_Aliased (Obj) then return False; end if; when E_Constant => -- return False for a deferred constant if Present (Full_View (Obj)) then return False; end if; -- return False if not "all views are constant". if Is_Immutably_Limited_Type (Obj_Typ) or Needs_Finalization (Obj_Typ) then return False; end if; when others => null; end case; end; return True; end if; -- ??? Cope with a malformed tree. Code to cope with a -- nonstatic use of an enumeration literal should not be -- necessary. if Is_Entity_Name (Pref) and then Ekind (Entity (Pref)) = E_Enumeration_Literal then return True; end if; end; case Nkind (Expr) is when N_Unary_Op => return Is_Known_On_Entry (Right_Opnd (Expr)); when N_Binary_Op => return Is_Known_On_Entry (Left_Opnd (Expr)) and then Is_Known_On_Entry (Right_Opnd (Expr)); when N_Type_Conversion | N_Qualified_Expression => return Is_Known_On_Entry (Expression (Expr)); when N_If_Expression => if not All_Exps_Known_On_Entry (Expressions (Expr)) then return False; end if; when N_Case_Expression => if not Is_Known_On_Entry (Expression (Expr)) then return False; end if; declare Alt : Node_Id := First (Alternatives (Expr)); begin while Present (Alt) loop if not Is_Known_On_Entry (Expression (Alt)) then return False; end if; Next (Alt); end loop; end; return True; when others => null; end case; return False; end Is_Known_On_Entry; end Conditional_Evaluation; package body Indirect_Temps is Indirect_Temp_Access_Type_Char : constant Character := 'K'; -- The character passed to Make_Temporary when declaring -- the access type that is used in the implementation of an -- indirect temporary. -------------------------- -- Indirect_Temp_Needed -- -------------------------- function Indirect_Temp_Needed (Typ : Entity_Id) return Boolean is begin -- There should be no correctness issues if the only cases where -- this function returns False are cases where Typ is an -- anonymous access type and we need to generate a saooaaat (a -- stand-alone object of an anonymous access type) in order get -- accessibility right. In other cases where this function -- returns False, there would be no correctness problems with -- returning True instead; however, returning False when we can -- generally results in simpler code. return False -- If Typ is not definite, then we cannot generate -- Temp : Typ; or else not Is_Definite_Subtype (Typ) -- If Typ is tagged, then generating -- Temp : Typ; -- might generate an object with the wrong tag. If we had -- a predicate that indicated whether the nominal tag is -- trustworthy, we could use that predicate here. or else Is_Tagged_Type (Typ) -- If Typ needs finalization, then generating an implicit -- Temp : Typ; -- declaration could have user-visible side effects. or else Needs_Finalization (Typ) -- In the anonymous access type case, we need to -- generate a saooaaat. We don't want the code in -- in exp_attr.adb that deals with the case where this -- function returns False to have to deal with that case -- (just to avoid code duplication). So we cheat a little -- bit and return True here for an anonymous access type. or else Is_Anonymous_Access_Type (Typ); -- ??? Unimplemented - spec description says: -- For an unconstrained-but-definite discriminated subtype, -- returns True if the potential difference in size between an -- unconstrained object and a constrained object is large. -- -- For example, -- type Typ (Len : Natural := 0) is -- record F : String (1 .. Len); end record; -- -- See Large_Max_Size_Mutable function elsewhere in this -- file (currently declared inside of -- New_Requires_Transient_Scope, so it would have to be -- moved if we want it to be callable from here). end Indirect_Temp_Needed; --------------------------- -- Declare_Indirect_Temp -- --------------------------- procedure Declare_Indirect_Temp (Attr_Prefix : Node_Id; Indirect_Temp : out Entity_Id) is Loc : constant Source_Ptr := Sloc (Attr_Prefix); Prefix_Type : constant Entity_Id := Etype (Attr_Prefix); Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'P', Attr_Prefix); procedure Declare_Indirect_Temp_Via_Allocation; -- Handle the usual case. ------------------------------------------- -- Declare_Indirect_Temp_Via_Allocation -- ------------------------------------------- procedure Declare_Indirect_Temp_Via_Allocation is Access_Type_Id : constant Entity_Id := Make_Temporary (Loc, Indirect_Temp_Access_Type_Char, Attr_Prefix); Temp_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Temp_Id, Object_Definition => New_Occurrence_Of (Access_Type_Id, Loc)); Allocate_Class_Wide : constant Boolean := Is_Specific_Tagged_Type (Prefix_Type); -- If True then access type designates the class-wide type in -- order to preserve (at run time) the value of the underlying -- tag. -- ??? We could do better here (in the case where Prefix_Type -- is tagged and specific) if we had a predicate which takes an -- expression and returns True iff the expression is of -- a specific tagged type and the underlying tag (at run time) -- is statically known to match that of the specific type. -- In that case, Allocate_Class_Wide could safely be False. function Designated_Subtype_Mark return Node_Id; -- Usually, a subtype mark indicating the subtype of the -- attribute prefix. If that subtype is a specific tagged -- type, then returns the corresponding class-wide type. -- If the prefix is of an anonymous access type, then returns -- the designated type of that type. ----------------------------- -- Designated_Subtype_Mark -- ----------------------------- function Designated_Subtype_Mark return Node_Id is Typ : Entity_Id := Prefix_Type; begin if Allocate_Class_Wide then if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then Typ := Full_View (Typ); end if; Typ := Class_Wide_Type (Typ); end if; return New_Occurrence_Of (Typ, Loc); end Designated_Subtype_Mark; Access_Type_Def : constant Node_Id := Make_Access_To_Object_Definition (Loc, Subtype_Indication => Designated_Subtype_Mark); Access_Type_Decl : constant Node_Id := Make_Full_Type_Declaration (Loc, Access_Type_Id, Type_Definition => Access_Type_Def); begin Set_Ekind (Temp_Id, E_Variable); Set_Etype (Temp_Id, Access_Type_Id); Set_Ekind (Access_Type_Id, E_Access_Type); if Append_Decls_In_Reverse_Order then Append_Item (Temp_Decl, Is_Eval_Stmt => False); Append_Item (Access_Type_Decl, Is_Eval_Stmt => False); else Append_Item (Access_Type_Decl, Is_Eval_Stmt => False); Append_Item (Temp_Decl, Is_Eval_Stmt => False); end if; Analyze (Access_Type_Decl); Analyze (Temp_Decl); pragma Assert (Is_Access_Type_For_Indirect_Temp (Access_Type_Id)); declare Expression : Node_Id := Attr_Prefix; Allocator : Node_Id; begin if Allocate_Class_Wide then -- generate T'Class'(T'Class ()) Expression := Make_Type_Conversion (Loc, Subtype_Mark => Designated_Subtype_Mark, Expression => Expression); end if; Allocator := Make_Allocator (Loc, Make_Qualified_Expression (Loc, Subtype_Mark => Designated_Subtype_Mark, Expression => Expression)); -- Allocate saved prefix value on the secondary stack -- in order to avoid introducing a storage leak. This -- allocated object is never explicitly reclaimed. -- -- ??? Emit storage leak warning if RE_SS_Pool -- unavailable? if RTE_Available (RE_SS_Pool) then Set_Storage_Pool (Allocator, RTE (RE_SS_Pool)); Set_Procedure_To_Call (Allocator, RTE (RE_SS_Allocate)); Set_Uses_Sec_Stack (Current_Scope); end if; Append_Item (Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Temp_Id, Loc), Expression => Allocator), Is_Eval_Stmt => True); end; end Declare_Indirect_Temp_Via_Allocation; begin Indirect_Temp := Temp_Id; if Is_Anonymous_Access_Type (Prefix_Type) then -- In the anonymous access type case, we do not want a level -- indirection (which would result in declaring an -- access-to-access type); that would result in correctness -- problems - the accessibility level of the type of the -- 'Old constant would be wrong (See 6.1.1.). So in that case, -- we do not generate an allocator. Instead we generate -- Temp : access Designated := null; -- which is unconditionally elaborated and then -- Temp := ; -- which is conditionally executed. declare Temp_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Temp_Id, Object_Definition => Make_Access_Definition (Loc, Constant_Present => Is_Access_Constant (Prefix_Type), Subtype_Mark => New_Occurrence_Of (Designated_Type (Prefix_Type), Loc))); begin Append_Item (Temp_Decl, Is_Eval_Stmt => False); Analyze (Temp_Decl); Append_Item (Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Temp_Id, Loc), Expression => Attr_Prefix), Is_Eval_Stmt => True); end; else -- the usual case Declare_Indirect_Temp_Via_Allocation; end if; end Declare_Indirect_Temp; ------------------------- -- Indirect_Temp_Value -- ------------------------- function Indirect_Temp_Value (Temp : Entity_Id; Typ : Entity_Id; Loc : Source_Ptr) return Node_Id is Result : Node_Id; begin if Is_Anonymous_Access_Type (Typ) then -- No indirection in this case; just evaluate the temp. Result := New_Occurrence_Of (Temp, Loc); Set_Etype (Result, Etype (Temp)); else Result := Make_Explicit_Dereference (Loc, New_Occurrence_Of (Temp, Loc)); Set_Etype (Result, Designated_Type (Etype (Temp))); if Is_Specific_Tagged_Type (Typ) then -- The designated type of the access type is class-wide, so -- convert to the specific type. Result := Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Typ, Loc), Expression => Result); Set_Etype (Result, Typ); end if; end if; return Result; end Indirect_Temp_Value; function Is_Access_Type_For_Indirect_Temp (T : Entity_Id) return Boolean is begin if Is_Access_Type (T) and then not Comes_From_Source (T) and then Is_Internal_Name (Chars (T)) and then Nkind (Scope (T)) in N_Entity and then Ekind (Scope (T)) in E_Entry | E_Entry_Family | E_Function | E_Procedure and then (Present (Postconditions_Proc (Scope (T))) or else Present (Contract (Scope (T)))) then -- ??? Should define a flag for this. We could incorrectly -- return True if other clients of Make_Temporary happen to -- pass in the same character. declare Name : constant String := Get_Name_String (Chars (T)); begin if Name (Name'First) = Indirect_Temp_Access_Type_Char then return True; end if; end; end if; return False; end Is_Access_Type_For_Indirect_Temp; end Indirect_Temps; end Old_Attr_Util; begin Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access; end Sem_Util;