| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ U T I L -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Casing; use Casing; |
| with Checks; use Checks; |
| with Debug; use Debug; |
| with Einfo.Utils; use Einfo.Utils; |
| with Elists; use Elists; |
| with Errout; use Errout; |
| with Erroutc; use Erroutc; |
| with Exp_Ch3; use Exp_Ch3; |
| with Exp_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 Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| 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 2022: 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 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; |
| Allow_Alt_Model : Boolean := True) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Expr); |
| |
| function Accessibility_Level (Expr : Node_Id) return Node_Id |
| is (Accessibility_Level (Expr, Level, In_Return_Context)); |
| -- Renaming of the enclosing function to facilitate recursive calls |
| |
| function Make_Level_Literal (Level : Uint) return Node_Id; |
| -- Construct an integer literal representing an accessibility level |
| -- with its type set to Natural. |
| |
| function Innermost_Master_Scope_Depth (N : Node_Id) return Uint; |
| -- Returns the scope depth of the given node's innermost |
| -- enclosing 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. |
| |
| function Typ_Access_Level (Typ : Entity_Id) return Uint |
| is (Type_Access_Level (Typ, Allow_Alt_Model)); |
| -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid |
| -- passing the parameter specifically in every call. |
| |
| ---------------------------------- |
| -- Innermost_Master_Scope_Depth -- |
| ---------------------------------- |
| |
| function Innermost_Master_Scope_Depth (N : Node_Id) return Uint is |
| Encl_Scop : Entity_Id; |
| Ent : Entity_Id; |
| Node_Par : Node_Id := Parent (N); |
| Master_Lvl_Modifier : Int := 0; |
| |
| begin |
| -- Locate the nearest enclosing node (by traversing Parents) |
| -- that Defining_Entity can be applied to, and return the |
| -- depth of that entity's nearest enclosing 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 |
| Ent := Defining_Entity_Or_Empty (Node_Par); |
| |
| if Present (Ent) then |
| Encl_Scop := Nearest_Dynamic_Scope (Ent); |
| |
| -- Ignore transient scopes made during expansion |
| |
| if Comes_From_Source (Node_Par) then |
| return |
| Scope_Depth_Default_0 (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 |
| (Typ_Access_Level (Etype (Prefix (Name (N))))); |
| end if; |
| |
| -- We ignore coextensions as they cannot be implemented under the |
| -- "small-integer" model. |
| |
| elsif Nkind (N) = N_Allocator |
| and then (Is_Static_Coextension (N) |
| or else Is_Dynamic_Coextension (N)) |
| then |
| return Make_Level_Literal (Scope_Depth (Standard_Standard)); |
| end if; |
| |
| -- Named access types have a designated level |
| |
| if Is_Named_Access_Type (Etype (N)) then |
| return Make_Level_Literal (Typ_Access_Level (Etype (N))); |
| |
| -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3) |
| |
| else |
| -- Check No_Dynamic_Accessibility_Checks restriction override for |
| -- alternative accessibility model. |
| |
| if Allow_Alt_Model |
| and then No_Dynamic_Accessibility_Checks_Enabled (N) |
| and then Is_Anonymous_Access_Type (Etype (N)) |
| then |
| -- In the alternative model the level is that of the |
| -- designated type. |
| |
| if Debug_Flag_Underscore_B then |
| return Make_Level_Literal (Typ_Access_Level (Etype (N))); |
| |
| -- For function calls the level is that of the innermost |
| -- master, otherwise (for allocators etc.) we get the level |
| -- of the corresponding anonymous access type, which is |
| -- calculated through the normal path of execution. |
| |
| elsif Nkind (N) = N_Function_Call then |
| return Make_Level_Literal |
| (Innermost_Master_Scope_Depth (Expr)); |
| end if; |
| end if; |
| |
| if Nkind (N) = N_Function_Call then |
| -- Dynamic checks are generated when we are within a return |
| -- value or we are in a function call within an anonymous |
| -- access discriminant constraint of a return object (signified |
| -- by In_Return_Context) on the side of the callee. |
| |
| -- So, in this case, return accessibility level of the |
| -- enclosing subprogram. |
| |
| if In_Return_Value (N) |
| or else In_Return_Context |
| then |
| return Make_Level_Literal |
| (Subprogram_Access_Level (Current_Subprogram)); |
| end if; |
| end if; |
| |
| -- When the call is being dereferenced the level is that of the |
| -- enclosing master of the dereferenced call. |
| |
| if Nkind (Parent (N)) in N_Explicit_Dereference |
| | N_Indexed_Component |
| | N_Selected_Component |
| then |
| return Make_Level_Literal |
| (Innermost_Master_Scope_Depth (Expr)); |
| end if; |
| |
| -- Find any relevant enclosing parent nodes that designate an |
| -- object being initialized. |
| |
| -- Note: The above is only relevant if the result is used "in its |
| -- entirety" as RM 3.10.2 (10.2/3) states. However, this is |
| -- accounted for in the case statement in the main body of |
| -- Accessibility_Level for N_Selected_Component. |
| |
| Par := Parent (Expr); |
| Prev_Par := Empty; |
| while Present (Par) loop |
| -- Detect an expanded implicit conversion, typically this |
| -- occurs on implicitly converted actuals in calls. |
| |
| -- Does this catch all implicit conversions ??? |
| |
| if Nkind (Par) = N_Type_Conversion |
| and then Is_Named_Access_Type (Etype (Par)) |
| then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (Par))); |
| end if; |
| |
| -- Jump out when we hit an object declaration or the right-hand |
| -- side of an assignment, or a construct such as an aggregate |
| -- subtype indication which would be the result is not used |
| -- "in its entirety." |
| |
| exit when Nkind (Par) in N_Object_Declaration |
| or else (Nkind (Par) = N_Assignment_Statement |
| and then Name (Par) /= Prev_Par); |
| |
| Prev_Par := Par; |
| Par := Parent (Par); |
| end loop; |
| |
| -- Assignment statements are handled in a similar way in |
| -- accordance to the left-hand part. However, strictly speaking, |
| -- this is illegal according to the RM, but this change is needed |
| -- to pass an ACATS C-test and is useful in general ??? |
| |
| case Nkind (Par) is |
| when N_Object_Declaration => |
| return Make_Level_Literal |
| (Scope_Depth |
| (Scope (Defining_Identifier (Par)))); |
| |
| when N_Assignment_Statement => |
| -- Return the accessibility level of the left-hand part |
| |
| return Accessibility_Level |
| (Expr => Name (Par), |
| Level => Object_Decl_Level, |
| In_Return_Context => In_Return_Context); |
| |
| when others => |
| return Make_Level_Literal |
| (Innermost_Master_Scope_Depth (Expr)); |
| end case; |
| end if; |
| end Function_Call_Or_Allocator_Level; |
| |
| -- Local variables |
| |
| E : 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 |
| (Typ_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 (In_Return_Context |
| or else (Level /= Dynamic_Level |
| and then In_Return_Value (Expr))) |
| then |
| return Make_Level_Literal (Scope_Depth (Standard_Standard)); |
| |
| -- Something went wrong and an extra accessibility formal has not |
| -- been generated when one should have ??? |
| |
| elsif Is_Formal (E) |
| and then 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; |
| |
| -- No_Dynamic_Accessibility_Checks restriction override for |
| -- alternative accessibility model. |
| |
| if Allow_Alt_Model |
| and then No_Dynamic_Accessibility_Checks_Enabled (E) |
| then |
| -- In the alternative model the level is that of the |
| -- designated type entity's context. |
| |
| if Debug_Flag_Underscore_B then |
| return Make_Level_Literal (Typ_Access_Level (Etype (E))); |
| |
| -- Otherwise the level depends on the entity's context |
| |
| elsif Is_Formal (E) then |
| return Make_Level_Literal |
| (Subprogram_Access_Level |
| (Enclosing_Subprogram (E))); |
| else |
| return Make_Level_Literal |
| (Scope_Depth (Enclosing_Dynamic_Scope (E))); |
| end if; |
| end if; |
| |
| -- Return the dynamic level in the normal case |
| |
| return New_Occurrence_Of |
| (Get_Dynamic_Accessibility (E), Loc); |
| |
| -- Initialization procedures have a special extra accessibility |
| -- parameter associated with the level at which the object |
| -- being initialized exists |
| |
| elsif Ekind (E) = E_Record_Type |
| and then Is_Limited_Record (E) |
| and then Current_Scope = Init_Proc (E) |
| and then Present (Init_Proc_Level_Formal (Current_Scope)) |
| then |
| return New_Occurrence_Of |
| (Init_Proc_Level_Formal (Current_Scope), Loc); |
| |
| -- Current instance of the type is deeper than that of the type |
| -- according to RM 3.10.2 (21). |
| |
| elsif Is_Type (E) then |
| -- When restriction No_Dynamic_Accessibility_Checks is active |
| -- along with -gnatd_b. |
| |
| if Allow_Alt_Model |
| and then No_Dynamic_Accessibility_Checks_Enabled (E) |
| and then Debug_Flag_Underscore_B |
| then |
| return Make_Level_Literal (Typ_Access_Level (E)); |
| end if; |
| |
| -- Normal path |
| |
| return Make_Level_Literal (Typ_Access_Level (E) + 1); |
| |
| -- Move up the renamed entity or object if it came from source |
| -- since expansion may have created a dummy renaming under |
| -- certain circumstances. |
| |
| -- Note: We check if the original node of the renaming comes |
| -- from source because the node may have been rewritten. |
| |
| elsif Present (Renamed_Entity_Or_Object (E)) |
| and then Comes_From_Source |
| (Original_Node (Renamed_Entity_Or_Object (E))) |
| then |
| return Accessibility_Level (Renamed_Entity_Or_Object (E)); |
| |
| -- Named access types get their level from their associated type |
| |
| elsif Is_Named_Access_Type (Etype (E)) then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| |
| -- Check if E is an expansion-generated renaming of an iterator |
| -- by examining Related_Expression. If so, determine the |
| -- accessibility level based on the original expression. |
| |
| elsif Ekind (E) in E_Constant | E_Variable |
| and then Present (Related_Expression (E)) |
| then |
| return Accessibility_Level (Related_Expression (E)); |
| |
| elsif Level = Dynamic_Level |
| and then Ekind (E) in E_In_Parameter | E_In_Out_Parameter |
| and then Present (Init_Proc_Level_Formal (Scope (E))) |
| then |
| return New_Occurrence_Of |
| (Init_Proc_Level_Formal (Scope (E)), Loc); |
| |
| -- Normal object - get the level of the enclosing scope |
| |
| else |
| return Make_Level_Literal |
| (Scope_Depth (Enclosing_Dynamic_Scope (E))); |
| end if; |
| |
| -- Handle indexed and selected components including the special cases |
| -- whereby there is an implicit dereference, a component of a |
| -- composite type, or a function call in prefix notation. |
| |
| -- We don't handle function calls in prefix notation correctly ??? |
| |
| when N_Indexed_Component | N_Selected_Component => |
| 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 |
| (Typ_Access_Level (Etype (Pre))); |
| |
| -- The current expression is a named access type, so there is no |
| -- reason to look at the prefix. Instead obtain the level of E's |
| -- named access type. |
| |
| elsif Is_Named_Access_Type (Etype (E)) then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| |
| -- A nondiscriminant selected component where the component |
| -- is an anonymous access type means that its associated |
| -- level is that of the containing type - see RM 3.10.2 (16). |
| |
| -- Note that when restriction No_Dynamic_Accessibility_Checks is |
| -- in effect we treat discriminant components as regular |
| -- components. |
| |
| elsif Nkind (E) = N_Selected_Component |
| and then Ekind (Etype (E)) = E_Anonymous_Access_Type |
| and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type |
| and then (not (Nkind (Selector_Name (E)) in N_Has_Entity |
| and then Ekind (Entity (Selector_Name (E))) |
| = E_Discriminant) |
| |
| -- The alternative accessibility models both treat |
| -- discriminants as regular components. |
| |
| or else (No_Dynamic_Accessibility_Checks_Enabled (E) |
| and then Allow_Alt_Model)) |
| then |
| -- When restriction No_Dynamic_Accessibility_Checks is active |
| -- and -gnatd_b set, the level is that of the designated type. |
| |
| if Allow_Alt_Model |
| and then No_Dynamic_Accessibility_Checks_Enabled (E) |
| and then Debug_Flag_Underscore_B |
| then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| end if; |
| |
| -- Otherwise proceed normally |
| |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (Prefix (E)))); |
| |
| -- 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 |
| -- When restriction No_Dynamic_Accessibility_Checks is active |
| -- and -gnatd_b set, the level is that of the designated type. |
| |
| if Allow_Alt_Model |
| and then No_Dynamic_Accessibility_Checks_Enabled (E) |
| and then Debug_Flag_Underscore_B |
| then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| end if; |
| |
| -- Otherwise proceed normally |
| |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (Prefix (E)))); |
| |
| -- The accessibility calculation routine that handles function |
| -- calls (Function_Call_Level) assumes, in the case the |
| -- result is of an anonymous access type, that the result will be |
| -- used "in its entirety" when the call is present within an |
| -- assignment or object declaration. |
| |
| -- To properly handle cases where the result is not used in its |
| -- entirety, we test if the prefix of the component in question is |
| -- a function call, which tells us that one of its components has |
| -- been identified and is being accessed. Therefore we can |
| -- conclude that the result is not used "in its entirety" |
| -- according to RM 3.10.2 (10.2/3). |
| |
| elsif Nkind (Pre) = N_Function_Call |
| and then not Is_Named_Access_Type (Etype (Pre)) |
| then |
| -- Dynamic checks are generated when we are within a return |
| -- value or we are in a function call within an anonymous |
| -- access discriminant constraint of a return object (signified |
| -- by In_Return_Context) on the side of the callee. |
| |
| -- So, in this case, return a library accessibility level to |
| -- null out the check on the side of the caller. |
| |
| if (In_Return_Value (E) |
| or else In_Return_Context) |
| and then Level /= Dynamic_Level |
| then |
| return Make_Level_Literal |
| (Scope_Depth (Standard_Standard)); |
| end if; |
| |
| return Make_Level_Literal |
| (Innermost_Master_Scope_Depth (Expr)); |
| |
| -- Otherwise, continue recursing over the expression prefixes |
| |
| else |
| return Accessibility_Level (Prefix (E)); |
| end if; |
| |
| -- Qualified expressions |
| |
| when N_Qualified_Expression => |
| if Is_Named_Access_Type (Etype (E)) then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| else |
| return Accessibility_Level (Expression (E)); |
| end if; |
| |
| -- Handle function calls |
| |
| when N_Function_Call => |
| return Function_Call_Or_Allocator_Level (E); |
| |
| -- Explicit dereference accessibility level calculation |
| |
| when N_Explicit_Dereference => |
| Pre := Original_Node (Prefix (E)); |
| |
| -- The prefix is a named access type so the level is taken from |
| -- its type. |
| |
| if Is_Named_Access_Type (Etype (Pre)) then |
| return Make_Level_Literal (Typ_Access_Level (Etype (Pre))); |
| |
| -- Otherwise, recurse deeper |
| |
| else |
| return Accessibility_Level (Prefix (E)); |
| end if; |
| |
| -- Type conversions |
| |
| when N_Type_Conversion | N_Unchecked_Type_Conversion => |
| -- View conversions are special in that they require use to |
| -- inspect the expression of the type conversion. |
| |
| -- Allocators of anonymous access types are internally generated, |
| -- so recurse deeper in that case as well. |
| |
| if Is_View_Conversion (E) |
| or else Ekind (Etype (E)) = E_Anonymous_Access_Type |
| then |
| return Accessibility_Level (Expression (E)); |
| |
| -- We don't care about the master if we are looking at a named |
| -- access type. |
| |
| elsif Is_Named_Access_Type (Etype (E)) then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| |
| -- In section RM 3.10.2 (10/4) the accessibility rules for |
| -- aggregates and value conversions are outlined. Are these |
| -- followed in the case of initialization of an object ??? |
| |
| -- Should use Innermost_Master_Scope_Depth ??? |
| |
| else |
| return Accessibility_Level (Current_Scope); |
| end if; |
| |
| -- Default to the type accessibility level for the type of the |
| -- expression's entity. |
| |
| when others => |
| return Make_Level_Literal (Typ_Access_Level (Etype (E))); |
| end case; |
| end Accessibility_Level; |
| |
| -------------------------------- |
| -- Static_Accessibility_Level -- |
| -------------------------------- |
| |
| function Static_Accessibility_Level |
| (Expr : Node_Id; |
| Level : Static_Accessibility_Level_Kind; |
| In_Return_Context : Boolean := False) return Uint |
| is |
| begin |
| return Intval |
| (Accessibility_Level (Expr, Level, In_Return_Context)); |
| end Static_Accessibility_Level; |
| |
| ---------------------------------- |
| -- Acquire_Warning_Match_String -- |
| ---------------------------------- |
| |
| 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_Actual (Expr); |
| |
| -- 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 |
| if No (V) then |
| return False; |
| end if; |
| |
| 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; |
| Warn : Boolean := False; |
| Emit_Message : Boolean := True) |
| 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; |
| |
| if Emit_Message then |
| Discard_Node |
| (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); |
| 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_Aspect -- |
| ---------------- |
| |
| procedure Bad_Aspect |
| (N : Node_Id; |
| Nam : Name_Id; |
| Warn : Boolean := False) |
| is |
| begin |
| Error_Msg_Warn := Warn; |
| Error_Msg_N ("<<& is not a valid aspect identifier", N); |
| |
| -- Check bad spelling |
| Error_Msg_Name_1 := Aspect_Spell_Check (Nam); |
| if Error_Msg_Name_1 /= No_Name then |
| Error_Msg_N -- CODEFIX |
| ("\<<possible misspelling of %", N); |
| end if; |
| end Bad_Aspect; |
| |
| ------------------- |
| -- 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 := Attribute_Spell_Check (Nam); |
| if Error_Msg_Name_1 /= No_Name then |
| Error_Msg_N -- CODEFIX |
| ("\<<possible misspelling of %", N); |
| end if; |
| 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; |
| Index : 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; |
| Index := First_Index (T); |
| |
| 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. |
| |
| -- If this is for an index with a fixed lower bound, then use |
| -- the fixed lower bound as the lower bound of the actual |
| -- subtype's corresponding index. |
| |
| if not Is_Constrained (T) |
| and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)) |
| then |
| Lo := New_Copy_Tree (Type_Low_Bound (Etype (Index))); |
| |
| else |
| 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))); |
| end if; |
| |
| 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); |
| |
| Next_Index (Index); |
| 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 Build_Discriminant_Reference |
| (Discrim_Name : Node_Id; Obj : Node_Id := P) return Node_Id; |
| -- Build a reference to the discriminant denoted by Discrim_Name. |
| -- The prefix of the result is usually Obj, but it could be |
| -- a prefix of Obj in some corner cases. |
| |
| 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 := Build_Discriminant_Reference (Old_Lo); |
| 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 := Build_Discriminant_Reference (Old_Hi); |
| 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 := Build_Discriminant_Reference (Node (D)); |
| 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_Discriminant_Reference -- |
| ---------------------------------- |
| |
| function Build_Discriminant_Reference |
| (Discrim_Name : Node_Id; Obj : Node_Id := P) return Node_Id |
| is |
| Discrim : constant Entity_Id := Entity (Discrim_Name); |
| |
| function Obj_Is_Good_Prefix return Boolean; |
| -- Returns True if Obj.Discrim makes sense; that is, if |
| -- Obj has Discrim as one of its discriminants (or is an |
| -- access value that designates such an object). |
| |
| ------------------------ |
| -- Obj_Is_Good_Prefix -- |
| ------------------------ |
| |
| function Obj_Is_Good_Prefix return Boolean is |
| Obj_Type : Entity_Id := |
| Implementation_Base_Type (Etype (Obj)); |
| |
| Discriminated_Type : constant Entity_Id := |
| Implementation_Base_Type |
| (Scope (Original_Record_Component (Discrim))); |
| begin |
| -- The order of the following two tests matters in the |
| -- access-to-class-wide case. |
| |
| if Is_Access_Type (Obj_Type) then |
| Obj_Type := Implementation_Base_Type |
| (Designated_Type (Obj_Type)); |
| end if; |
| |
| if Is_Class_Wide_Type (Obj_Type) then |
| Obj_Type := Implementation_Base_Type |
| (Find_Specific_Type (Obj_Type)); |
| end if; |
| |
| -- If a type T1 defines a discriminant D1, then Obj.D1 is ok (for |
| -- our purposes here) if T1 is an ancestor of the type of Obj. |
| -- So that's what we would like to test for here. |
| -- The bad news: Is_Ancestor is only defined in the tagged case. |
| -- The good news: in the untagged case, Implementation_Base_Type |
| -- looks through derived types so we can use a simpler test. |
| |
| if Is_Tagged_Type (Discriminated_Type) then |
| return Is_Ancestor (Discriminated_Type, Obj_Type); |
| else |
| return Discriminated_Type = Obj_Type; |
| end if; |
| end Obj_Is_Good_Prefix; |
| |
| -- Start of processing for Build_Discriminant_Reference |
| |
| begin |
| if not Obj_Is_Good_Prefix then |
| -- If the given discriminant is not a component of the given |
| -- object, then try the enclosing object. |
| |
| if Nkind (Obj) = N_Selected_Component then |
| return Build_Discriminant_Reference |
| (Discrim_Name => Discrim_Name, |
| Obj => Prefix (Obj)); |
| elsif Nkind (Obj) in N_Has_Entity |
| and then Nkind (Parent (Entity (Obj))) = |
| N_Object_Renaming_Declaration |
| then |
| -- Look through a renaming (a corner case of a corner case). |
| return Build_Discriminant_Reference |
| (Discrim_Name => Discrim_Name, |
| Obj => Name (Parent (Entity (Obj)))); |
| else |
| -- We are in some unexpected case here, so revert to the |
| -- old behavior (by falling through to it). |
| null; |
| end if; |
| end if; |
| |
| return Make_Selected_Component (Loc, |
| Prefix => Copy_And_Maybe_Dereference (Obj), |
| Selector_Name => New_Occurrence_Of (Discrim, Loc)); |
| end Build_Discriminant_Reference; |
| |
| ------------------------------------ |
| -- 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 Parent_Kind (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_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 |
| |
| function List_Cannot_Raise_CE (L : List_Id) return Boolean; |
| -- Returns True if none of the list members cannot possibly raise |
| -- Constraint_Error. |
| |
| -------------------------- |
| -- List_Cannot_Raise_CE -- |
| -------------------------- |
| |
| function List_Cannot_Raise_CE (L : List_Id) return Boolean is |
| N : Node_Id; |
| begin |
| N := First (L); |
| while Present (N) loop |
| if Cannot_Raise_Constraint_Error (N) then |
| Next (N); |
| else |
| return False; |
| end if; |
| end loop; |
| |
| return True; |
| end List_Cannot_Raise_CE; |
| |
| -- Start of processing for Cannot_Raise_Constraint_Error |
| |
| 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_Indexed_Component => |
| return not Do_Range_Check (Expr) |
| and then Cannot_Raise_Constraint_Error (Prefix (Expr)) |
| and then List_Cannot_Raise_CE (Expressions (Expr)); |
| |
| when N_Selected_Component => |
| return not Do_Discriminant_Check (Expr) |
| and then Cannot_Raise_Constraint_Error (Prefix (Expr)); |
| |
| when N_Attribute_Reference => |
| if Do_Overflow_Check (Expr) then |
| return False; |
| |
| elsif No (Expressions (Expr)) then |
| return True; |
| |
| else |
| return List_Cannot_Raise_CE (Expressions (Expr)); |
| end if; |
| |
| when N_Type_Conversion => |
| if Do_Overflow_Check (Expr) |
| or else Do_Length_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, |
<