X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fexp_ch3.adb;h=9420558b9fd3678209afac3926380474c8e6449b;hb=da31da6faf00197d0460c8de63d3517f07b80d8a;hp=4b829214bf759884803553efb9ae29232a616159;hpb=d62940bfa0c906f830712fc4334d3a5d5d45c728;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 4b829214bf7..9420558b9fd 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, 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 2, or (at your option) any later ver- -- +-- 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 COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- 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. -- @@ -29,7 +28,9 @@ with Checks; use Checks; with Einfo; use Einfo; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; +with Exp_Atag; use Exp_Atag; with Exp_Ch4; use Exp_Ch4; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; with Exp_Ch11; use Exp_Ch11; @@ -40,24 +41,31 @@ with Exp_Strm; use Exp_Strm; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; -with Hostparm; use Hostparm; with Nlists; use Nlists; +with Namet; use Namet; with Nmake; use Nmake; with Opt; use Opt; 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_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; +with Sem_SCIL; use Sem_SCIL; +with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; with Snames; use Snames; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Validsw; use Validsw; @@ -68,6 +76,10 @@ package body Exp_Ch3 is -- Local Subprograms -- ----------------------- + function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id; + -- Add the declaration of a finalization list to the freeze actions for + -- Def_Id, and return its defining identifier. + procedure Adjust_Discriminants (Rtype : Entity_Id); -- This is used when freezing a record type. It attempts to construct -- more restrictive subtypes for discriminants so that the max size of @@ -79,34 +91,45 @@ package body Exp_Ch3 is -- used for attachment of any actions required in its construction. -- It also supplies the source location used for the procedure. - procedure Build_Class_Wide_Master (T : Entity_Id); - -- for access to class-wide limited types we must build a task master - -- because some subsequent extension may add a task component. To avoid - -- bringing in the tasking run-time whenever an access-to-class-wide - -- limited type is used, we use the soft-link mechanism and add a level - -- of indirection to calls to routines that manipulate Master_Ids. - function Build_Discriminant_Formals (Rec_Id : Entity_Id; Use_Dl : Boolean) return List_Id; -- This function uses the discriminants of a type to build a list of - -- formal parameters, used in the following function. If the flag Use_Dl - -- is set, the list is built using the already defined discriminals - -- of the type. Otherwise new identifiers are created, with the source - -- names of the discriminants. - - procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id); + -- formal parameters, used in Build_Init_Procedure among other places. + -- If the flag Use_Dl is set, the list is built using the already + -- defined discriminals of the type, as is the case for concurrent + -- types with discriminants. Otherwise new identifiers are created, + -- with the source names of the discriminants. + + function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id; + -- This function builds a static aggregate that can serve as the initial + -- value for an array type whose bounds are static, and whose component + -- type is a composite type that has a static equivalent aggregate. + -- The equivalent array aggregate is used both for object initialization + -- and for component initialization, when used in the following function. + + function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id; + -- This function builds a static aggregate that can serve as the initial + -- value for a record type whose components are scalar and initialized + -- with compile-time values, or arrays with similar initialization or + -- defaults. When possible, initialization of an object of the type can + -- be achieved by using a copy of the aggregate as an initial value, thus + -- removing the implicit call that would otherwise constitute elaboration + -- code. + + function Build_Master_Renaming + (N : Node_Id; + T : Entity_Id) return Entity_Id; -- If the designated type of an access type is a task type or contains -- tasks, we make sure that a _Master variable is declared in the current -- scope, and then declare a renaming for it: -- -- atypeM : Master_Id renames _Master; -- - -- where atyp is the name of the access type. This declaration is - -- used when an allocator for the access type is expanded. The node N - -- is the full declaration of the designated type that contains tasks. - -- The renaming declaration is inserted before N, and after the Master - -- declaration. + -- where atyp is the name of the access type. This declaration is used when + -- an allocator for the access type is expanded. The node is the full + -- declaration of the designated type that contains tasks. The renaming + -- declaration is inserted before N, and after the Master declaration. procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); -- Build record initialization procedure. N is the type declaration @@ -123,35 +146,42 @@ package body Exp_Ch3 is -- and attach it to the TSS list procedure Check_Stream_Attributes (Typ : Entity_Id); - -- Check that if a limited extension has a parent with user-defined - -- stream attributes, and does not itself have user-definer - -- stream-attributes, then any limited component of the extension also - -- has the corresponding user-defined stream attributes. + -- Check that if a limited extension has a parent with user-defined stream + -- attributes, and does not itself have user-defined stream-attributes, + -- then any limited component of the extension also has the corresponding + -- user-defined stream attributes. + + procedure Clean_Task_Names + (Typ : Entity_Id; + Proc_Id : Entity_Id); + -- If an initialization procedure includes calls to generate names + -- for task subcomponents, indicate that secondary stack cleanup is + -- needed after an initialization. Typ is the component type, and Proc_Id + -- the initialization procedure for the enclosing composite type. procedure Expand_Tagged_Root (T : Entity_Id); -- Add a field _Tag at the beginning of the record. This field carries -- the value of the access to the Dispatch table. This procedure is only - -- called on root (non CPP_Class) types, the _Tag field being inherited - -- by the descendants. + -- called on root type, the _Tag field being inherited by the descendants. procedure Expand_Record_Controller (T : Entity_Id); -- T must be a record type that Has_Controlled_Component. Add a field -- _controller of type Record_Controller or Limited_Record_Controller -- in the record T. - procedure Freeze_Array_Type (N : Node_Id); + procedure Expand_Freeze_Array_Type (N : Node_Id); -- Freeze an array type. Deals with building the initialization procedure, -- creating the packed array type for a packed array and also with the -- creation of the controlling procedures for the controlled case. The -- argument N is the N_Freeze_Entity node for the type. - procedure Freeze_Enumeration_Type (N : Node_Id); + procedure Expand_Freeze_Enumeration_Type (N : Node_Id); -- Freeze enumeration type with non-standard representation. Builds the -- array and function needed to convert between enumeration pos and -- enumeration representation values. N is the N_Freeze_Entity node -- for the type. - procedure Freeze_Record_Type (N : Node_Id); + procedure Expand_Freeze_Record_Type (N : Node_Id); -- Freeze record type. Builds all necessary discriminant checking -- and other ancillary functions, and builds dispatch tables where -- needed. The argument N is the N_Freeze_Entity node. This processing @@ -162,6 +192,12 @@ package body Exp_Ch3 is -- Treat user-defined stream operations as renaming_as_body if the -- subprogram they rename is not frozen when the type is frozen. + procedure Initialization_Warning (E : Entity_Id); + -- If static elaboration of the package is requested, indicate + -- when a type does meet the conditions for static initialization. If + -- E is a type, it has components that have no static initialization. + -- if E is an entity, its initial expression is not compile-time known. + function Init_Formals (Typ : Entity_Id) return List_Id; -- This function builds the list of formals for an initialization routine. -- The first formal is always _Init with the given type. For task value @@ -178,33 +214,39 @@ package body Exp_Ch3 is -- Check if E is defined in the RTL (in a child of Ada or System). Used -- to avoid to bring in the overhead of _Input, _Output for tagged types. + function Is_Variable_Size_Record (E : Entity_Id) return Boolean; + -- Returns true if E has variable size components + function Make_Eq_Case (E : Entity_Id; CL : Node_Id; Discr : Entity_Id := Empty) return List_Id; - -- Building block for variant record equality. Defined to share the - -- code between the tagged and non-tagged case. Given a Component_List - -- node CL, it generates an 'if' followed by a 'case' statement that - -- compares all components of local temporaries named X and Y (that - -- are declared as formals at some upper level). E provides the Sloc to be - -- used for the generated code. Discr is used as the case statement switch - -- in the case of Unchecked_Union equality. + -- Building block for variant record equality. Defined to share the code + -- between the tagged and non-tagged case. Given a Component_List node CL, + -- it generates an 'if' followed by a 'case' statement that compares all + -- components of local temporaries named X and Y (that are declared as + -- formals at some upper level). E provides the Sloc to be used for the + -- generated code. Discr is used as the case statement switch in the case + -- of Unchecked_Union equality. function Make_Eq_If (E : Entity_Id; L : List_Id) return Node_Id; - -- Building block for variant record equality. Defined to share the - -- code between the tagged and non-tagged case. Given the list of - -- components (or discriminants) L, it generates a return statement - -- that compares all components of local temporaries named X and Y - -- (that are declared as formals at some upper level). E provides the Sloc - -- to be used for the generated code. + -- Building block for variant record equality. Defined to share the code + -- between the tagged and non-tagged case. Given the list of components + -- (or discriminants) L, it generates a return statement that compares all + -- components of local temporaries named X and Y (that are declared as + -- formals at some upper level). E provides the Sloc to be used for the + -- generated code. procedure Make_Predefined_Primitive_Specs (Tag_Typ : Entity_Id; Predef_List : out List_Id; - Renamed_Eq : out Node_Id); + Renamed_Eq : out Entity_Id); -- Create a list with the specs of the predefined primitive operations. + -- For tagged types that are interfaces all these primitives are defined + -- abstract. + -- -- The following entries are present for all tagged types, and provide -- the results of the corresponding attribute applied to the object. -- Dispatching is required in general, since the result of the attribute @@ -217,32 +259,50 @@ package body Exp_Ch3 is -- typSI provides result of 'Input attribute -- typSO provides result of 'Output attribute -- - -- The following entries are additionally present for non-limited - -- tagged types, and implement additional dispatching operations - -- for predefined operations: + -- The following entries are additionally present for non-limited tagged + -- types, and implement additional dispatching operations for predefined + -- operations: -- -- _equality implements "=" operator -- _assign implements assignment operation -- typDF implements deep finalization - -- typDA implements deep adust + -- typDA implements deep adjust -- -- The latter two are empty procedures unless the type contains some -- controlled components that require finalization actions (the deep -- in the name refers to the fact that the action applies to components). -- - -- The list is returned in Predef_List. The Parameter Renamed_Eq - -- either returns the value Empty, or else the defining unit name - -- for the predefined equality function in the case where the type - -- has a primitive operation that is a renaming of predefined equality - -- (but only if there is also an overriding user-defined equality - -- function). The returned Renamed_Eq will be passed to the - -- corresponding parameter of Predefined_Primitive_Bodies. + -- The list is returned in Predef_List. The Parameter Renamed_Eq either + -- returns the value Empty, or else the defining unit name for the + -- predefined equality function in the case where the type has a primitive + -- operation that is a renaming of predefined equality (but only if there + -- is also an overriding user-defined equality function). The returned + -- Renamed_Eq will be passed to the corresponding parameter of + -- Predefined_Primitive_Bodies. function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean; - -- returns True if there are representation clauses for type T that - -- are not inherited. If the result is false, the init_proc and the - -- discriminant_checking functions of the parent can be reused by - -- a derived type. + -- returns True if there are representation clauses for type T that are not + -- inherited. If the result is false, the init_proc and the discriminant + -- checking functions of the parent can be reused by a derived type. + + procedure Make_Controlling_Function_Wrappers + (Tag_Typ : Entity_Id; + Decl_List : out List_Id; + Body_List : out List_Id); + -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions + -- associated with inherited functions with controlling results which + -- are not overridden. The body of each wrapper function consists solely + -- of a return statement whose expression is an extension aggregate + -- invoking the inherited subprogram's parent subprogram and extended + -- with a null association list. + + procedure Make_Null_Procedure_Specs + (Tag_Typ : Entity_Id; + Decl_List : out List_Id); + -- Ada 2005 (AI-251): Makes specs for null procedures associated with any + -- null procedures inherited from an interface type that have not been + -- overridden. Only one null procedure will be created for a given set of + -- inherited null procedures with homographic profiles. function Predef_Spec_Or_Body (Loc : Source_Ptr; @@ -276,7 +336,7 @@ package body Exp_Ch3 is function Predefined_Primitive_Bodies (Tag_Typ : Entity_Id; - Renamed_Eq : Node_Id) return List_Id; + Renamed_Eq : Entity_Id) return List_Id; -- Create the bodies of the predefined primitives that are described in -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote -- the defining unit name of the type's predefined equality as returned @@ -284,7 +344,7 @@ package body Exp_Ch3 is function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; -- Freeze entities of all predefined primitive operations. This is needed - -- because the bodies of these operations do not normally do any freezeing. + -- because the bodies of these operations do not normally do any freezing. function Stream_Operation_OK (Typ : Entity_Id; @@ -295,16 +355,38 @@ package body Exp_Ch3 is -- the generation of these operations, as a useful optimization or for -- certification purposes. + --------------------- + -- Add_Final_Chain -- + --------------------- + + function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id is + Loc : constant Source_Ptr := Sloc (Def_Id); + Flist : Entity_Id; + + begin + Flist := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Def_Id), 'L')); + + Append_Freeze_Action (Def_Id, + Make_Object_Declaration (Loc, + Defining_Identifier => Flist, + Object_Definition => + New_Reference_To (RTE (RE_List_Controller), Loc))); + + return Flist; + end Add_Final_Chain; + -------------------------- -- Adjust_Discriminants -- -------------------------- - -- This procedure attempts to define subtypes for discriminants that - -- are more restrictive than those declared. Such a replacement is - -- possible if we can demonstrate that values outside the restricted - -- range would cause constraint errors in any case. The advantage of - -- restricting the discriminant types in this way is tha the maximum - -- size of the variant record can be calculated more conservatively. + -- This procedure attempts to define subtypes for discriminants that are + -- more restrictive than those declared. Such a replacement is possible if + -- we can demonstrate that values outside the restricted range would cause + -- constraint errors in any case. The advantage of restricting the + -- discriminant types in this way is that the maximum size of the variant + -- record can be calculated more conservatively. -- An example of a situation in which we can perform this type of -- restriction is the following: @@ -455,11 +537,12 @@ package body Exp_Ch3 is --------------------------- procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is - Loc : constant Source_Ptr := Sloc (Nod); - Comp_Type : constant Entity_Id := Component_Type (A_Type); - Index_List : List_Id; - Proc_Id : Entity_Id; - Body_Stmts : List_Id; + Loc : constant Source_Ptr := Sloc (Nod); + Comp_Type : constant Entity_Id := Component_Type (A_Type); + Index_List : List_Id; + Proc_Id : Entity_Id; + Body_Stmts : List_Id; + Has_Default_Init : Boolean; function Init_Component return List_Id; -- Create one statement to initialize one array component, designated @@ -493,11 +576,15 @@ package body Exp_Ch3 is Name => Comp, Expression => Get_Simple_Init_Val - (Comp_Type, Loc, Component_Size (A_Type)))); + (Comp_Type, Nod, Component_Size (A_Type)))); else + Clean_Task_Names (Comp_Type, Proc_Id); return - Build_Initialization_Call (Loc, Comp, Comp_Type, True, A_Type); + Build_Initialization_Call + (Loc, Comp, Comp_Type, + In_Init_Proc => True, + Enclos_Type => A_Type); end if; end Init_Component; @@ -553,7 +640,19 @@ package body Exp_Ch3 is -- Start of processing for Build_Array_Init_Proc begin - if Suppress_Init_Proc (A_Type) then + -- Nothing to generate in the following cases: + + -- 1. Initialization is suppressed for the type + -- 2. The type is a value type, in the CIL sense. + -- 3. The type has CIL/JVM convention. + -- 4. An initialization already exists for the base type + + if Suppress_Init_Proc (A_Type) + or else Is_Value_Type (Comp_Type) + or else Convention (A_Type) = Convention_CIL + or else Convention (A_Type) = Convention_Java + or else Present (Base_Init_Proc (A_Type)) + then return; end if; @@ -564,7 +663,7 @@ package body Exp_Ch3 is -- 1. The component type has an initialization procedure -- 2. The component type needs simple initialization -- 3. Tasks are present - -- 4. The type is marked as a publc entity + -- 4. The type is marked as a public entity -- The reason for the public entity test is to deal properly with the -- Initialize_Scalars pragma. This pragma can be set in the client and @@ -580,17 +679,37 @@ package body Exp_Ch3 is -- the issue arises) in a special manner anyway which does not need an -- init_proc. - if Has_Non_Null_Base_Init_Proc (Comp_Type) - or else Needs_Simple_Initialization (Comp_Type) - or else Has_Task (Comp_Type) + Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) + or else Needs_Simple_Initialization (Comp_Type) + or else Has_Task (Comp_Type); + + if Has_Default_Init or else (not Restriction_Active (No_Initialize_Scalars) - and then Is_Public (A_Type) - and then Root_Type (A_Type) /= Standard_String - and then Root_Type (A_Type) /= Standard_Wide_String - and then Root_Type (A_Type) /= Standard_Wide_Wide_String) + and then Is_Public (A_Type) + and then Root_Type (A_Type) /= Standard_String + and then Root_Type (A_Type) /= Standard_Wide_String + and then Root_Type (A_Type) /= Standard_Wide_Wide_String) then Proc_Id := - Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type)); + Make_Defining_Identifier (Loc, + Chars => Make_Init_Proc_Name (A_Type)); + + -- If No_Default_Initialization restriction is active, then we don't + -- want to build an init_proc, but we need to mark that an init_proc + -- would be needed if this restriction was not active (so that we can + -- detect attempts to call it), so set a dummy init_proc in place. + -- This is only done though when actual default initialization is + -- needed (and not done when only Is_Public is True), since otherwise + -- objects such as arrays of scalars could be wrongly flagged as + -- violating the restriction. + + if Restriction_Active (No_Default_Initialization) then + if Has_Default_Init then + Set_Init_Proc (A_Type, Proc_Id); + end if; + + return; + end if; Body_Stmts := Init_One_Dimension (1); @@ -616,11 +735,11 @@ package body Exp_Ch3 is -- Set inlined unless controlled stuff or tasks around, in which -- case we do not want to inline, because nested stuff may cause - -- difficulties in interunit inlining, and furthermore there is + -- difficulties in inter-unit inlining, and furthermore there is -- in any case no point in inlining such complex init procs. if not Has_Task (Proc_Id) - and then not Controlled_Type (Proc_Id) + and then not Needs_Finalization (Proc_Id) then Set_Is_Inlined (Proc_Id); end if; @@ -635,9 +754,22 @@ package body Exp_Ch3 is Set_Init_Proc (A_Type, Proc_Id); if List_Length (Body_Stmts) = 1 - and then Nkind (First (Body_Stmts)) = N_Null_Statement + + -- We must skip SCIL nodes because they may have been added to this + -- list by Insert_Actions. + + and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement then Set_Is_Null_Init_Proc (Proc_Id); + + else + -- Try to build a static aggregate to initialize statically + -- objects of the type. This can only be done for constrained + -- one-dimensional arrays with static bounds. + + Set_Static_Initialization + (Proc_Id, + Build_Equivalent_Array_Aggregate (First_Subtype (A_Type))); end if; end if; end Build_Array_Init_Proc; @@ -651,6 +783,7 @@ package body Exp_Ch3 is M_Id : Entity_Id; Decl : Node_Id; P : Node_Id; + Par : Node_Id; begin -- Nothing to do if there is no task hierarchy @@ -659,13 +792,23 @@ package body Exp_Ch3 is return; end if; + -- Find declaration that created the access type: either a type + -- declaration, or an object declaration with an access definition, + -- in which case the type is anonymous. + + if Is_Itype (T) then + P := Associated_Node_For_Itype (T); + else + P := Parent (T); + end if; + -- Nothing to do if we already built a master entity for this scope if not Has_Master_Entity (Scope (T)) then - -- first build the master entity + -- First build the master entity -- _Master : constant Master_Id := Current_Master.all; - -- and insert it just before the current declaration + -- and insert it just before the current declaration. Decl := Make_Object_Declaration (Loc, @@ -677,27 +820,30 @@ package body Exp_Ch3 is Make_Explicit_Dereference (Loc, New_Reference_To (RTE (RE_Current_Master), Loc))); - P := Parent (T); - Insert_Before (P, Decl); + Insert_Action (P, Decl); Analyze (Decl); Set_Has_Master_Entity (Scope (T)); - -- Now mark the containing scope as a task master + -- Now mark the containing scope as a task master. Masters + -- associated with return statements are already marked at + -- this stage (see Analyze_Subprogram_Body). - while Nkind (P) /= N_Compilation_Unit loop - P := Parent (P); + if Ekind (Current_Scope) /= E_Return_Statement then + Par := P; + while Nkind (Par) /= N_Compilation_Unit loop + Par := Parent (Par); -- If we fall off the top, we are at the outer level, and the -- environment task is our effective master, so nothing to mark. - if Nkind (P) = N_Task_Body - or else Nkind (P) = N_Block_Statement - or else Nkind (P) = N_Subprogram_Body - then - Set_Is_Task_Master (P, True); - exit; - end if; - end loop; + if Nkind_In + (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body) + then + Set_Is_Task_Master (Par, True); + exit; + end if; + end loop; + end if; end if; -- Now define the renaming of the master_id @@ -711,7 +857,7 @@ package body Exp_Ch3 is Defining_Identifier => M_Id, Subtype_Mark => New_Reference_To (Standard_Integer, Loc), Name => Make_Identifier (Loc, Name_uMaster)); - Insert_Before (Parent (T), Decl); + Insert_Before (P, Decl); Analyze (Decl); Set_Master_Id (T, M_Id); @@ -736,12 +882,12 @@ package body Exp_Ch3 is function Build_Case_Statement (Case_Id : Entity_Id; Variant : Node_Id) return Node_Id; - -- Build a case statement containing only two alternatives. The - -- first alternative corresponds exactly to the discrete choices - -- given on the variant with contains the components that we are - -- generating the checks for. If the discriminant is one of these - -- return False. The second alternative is an OTHERS choice that - -- will return True indicating the discriminant did not match. + -- Build a case statement containing only two alternatives. The first + -- alternative corresponds exactly to the discrete choices given on the + -- variant with contains the components that we are generating the + -- checks for. If the discriminant is one of these return False. The + -- second alternative is an OTHERS choice that will return True + -- indicating the discriminant did not match. function Build_Dcheck_Function (Case_Id : Entity_Id; @@ -772,8 +918,8 @@ package body Exp_Ch3 is begin Case_Node := New_Node (N_Case_Statement, Loc); - -- Replace the discriminant which controls the variant, with the - -- name of the formal of the checking function. + -- Replace the discriminant which controls the variant, with the name + -- of the formal of the checking function. Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id))); @@ -804,7 +950,7 @@ package body Exp_Ch3 is end loop; Return_Node := - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, Name => @@ -814,7 +960,7 @@ package body Exp_Ch3 is else Return_Node := - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (Standard_False, Loc)); end if; @@ -828,7 +974,7 @@ package body Exp_Ch3 is Set_Discrete_Choices (Case_Alt_Node, Choice_List); Return_Node := - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc)); @@ -907,17 +1053,25 @@ package body Exp_Ch3 is Saved_Enclosing_Func_Id : Entity_Id; begin - -- Build the discriminant checking function for each variant, label - -- all components of that variant with the function's name. + -- Build the discriminant-checking function for each variant, and + -- label all components of that variant with the function's name. + -- We only Generate a discriminant-checking function when the + -- variant is not empty, to prevent the creation of dead code. + -- The exception to that is when Frontend_Layout_On_Target is set, + -- because the variant record size function generated in package + -- Layout needs to generate calls to all discriminant-checking + -- functions, including those for empty variants. Discr_Name := Entity (Name (Variant_Part_Node)); Variant := First_Non_Pragma (Variants (Variant_Part_Node)); while Present (Variant) loop - Func_Id := Build_Dcheck_Function (Discr_Name, Variant); Component_List_Node := Component_List (Variant); - if not Null_Present (Component_List_Node) then + if not Null_Present (Component_List_Node) + or else Frontend_Layout_On_Target + then + Func_Id := Build_Dcheck_Function (Discr_Name, Variant); Decl := First_Non_Pragma (Component_Items (Component_List_Node)); @@ -988,6 +1142,7 @@ package body Exp_Ch3 is Parameter_List : constant List_Id := New_List; D : Entity_Id; Formal : Entity_Id; + Formal_Type : Entity_Id; Param_Spec_Node : Node_Id; begin @@ -998,15 +1153,17 @@ package body Exp_Ch3 is if Use_Dl then Formal := Discriminal (D); + Formal_Type := Etype (Formal); else Formal := Make_Defining_Identifier (Loc, Chars (D)); + Formal_Type := Etype (D); end if; Param_Spec_Node := Make_Parameter_Specification (Loc, Defining_Identifier => Formal, Parameter_Type => - New_Reference_To (Etype (D), Loc)); + New_Reference_To (Formal_Type, Loc)); Append (Param_Spec_Node, Parameter_List); Next_Discriminant (D); end loop; @@ -1015,25 +1172,197 @@ package body Exp_Ch3 is return Parameter_List; end Build_Discriminant_Formals; + -------------------------------------- + -- Build_Equivalent_Array_Aggregate -- + -------------------------------------- + + function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (T); + Comp_Type : constant Entity_Id := Component_Type (T); + Index_Type : constant Entity_Id := Etype (First_Index (T)); + Proc : constant Entity_Id := Base_Init_Proc (T); + Lo, Hi : Node_Id; + Aggr : Node_Id; + Expr : Node_Id; + + begin + if not Is_Constrained (T) + or else Number_Dimensions (T) > 1 + or else No (Proc) + then + Initialization_Warning (T); + return Empty; + end if; + + Lo := Type_Low_Bound (Index_Type); + Hi := Type_High_Bound (Index_Type); + + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + Initialization_Warning (T); + return Empty; + end if; + + if Is_Record_Type (Comp_Type) + and then Present (Base_Init_Proc (Comp_Type)) + then + Expr := Static_Initialization (Base_Init_Proc (Comp_Type)); + + if No (Expr) then + Initialization_Warning (T); + return Empty; + end if; + + else + Initialization_Warning (T); + return Empty; + end if; + + Aggr := Make_Aggregate (Loc, No_List, New_List); + Set_Etype (Aggr, T); + Set_Aggregate_Bounds (Aggr, + Make_Range (Loc, + Low_Bound => New_Copy (Lo), + High_Bound => New_Copy (Hi))); + Set_Parent (Aggr, Parent (Proc)); + + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => + New_List ( + Make_Range (Loc, + Low_Bound => New_Copy (Lo), + High_Bound => New_Copy (Hi))), + Expression => Expr)); + + if Static_Array_Aggregate (Aggr) then + return Aggr; + else + Initialization_Warning (T); + return Empty; + end if; + end Build_Equivalent_Array_Aggregate; + + --------------------------------------- + -- Build_Equivalent_Record_Aggregate -- + --------------------------------------- + + function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is + Agg : Node_Id; + Comp : Entity_Id; + Comp_Type : Entity_Id; + + -- Start of processing for Build_Equivalent_Record_Aggregate + + begin + if not Is_Record_Type (T) + or else Has_Discriminants (T) + or else Is_Limited_Type (T) + or else Has_Non_Standard_Rep (T) + then + Initialization_Warning (T); + return Empty; + end if; + + Comp := First_Component (T); + + -- A null record needs no warning + + if No (Comp) then + return Empty; + end if; + + while Present (Comp) loop + + -- Array components are acceptable if initialized by a positional + -- aggregate with static components. + + if Is_Array_Type (Etype (Comp)) then + Comp_Type := Component_Type (Etype (Comp)); + + if Nkind (Parent (Comp)) /= N_Component_Declaration + or else No (Expression (Parent (Comp))) + or else Nkind (Expression (Parent (Comp))) /= N_Aggregate + then + Initialization_Warning (T); + return Empty; + + elsif Is_Scalar_Type (Component_Type (Etype (Comp))) + and then + (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) + or else + not Compile_Time_Known_Value (Type_High_Bound (Comp_Type))) + then + Initialization_Warning (T); + return Empty; + + elsif + not Static_Array_Aggregate (Expression (Parent (Comp))) + then + Initialization_Warning (T); + return Empty; + end if; + + elsif Is_Scalar_Type (Etype (Comp)) then + Comp_Type := Etype (Comp); + + if Nkind (Parent (Comp)) /= N_Component_Declaration + or else No (Expression (Parent (Comp))) + or else not Compile_Time_Known_Value (Expression (Parent (Comp))) + or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) + or else not + Compile_Time_Known_Value (Type_High_Bound (Comp_Type)) + then + Initialization_Warning (T); + return Empty; + end if; + + -- For now, other types are excluded + + else + Initialization_Warning (T); + return Empty; + end if; + + Next_Component (Comp); + end loop; + + -- All components have static initialization. Build positional aggregate + -- from the given expressions or defaults. + + Agg := Make_Aggregate (Sloc (T), New_List, New_List); + Set_Parent (Agg, Parent (T)); + + Comp := First_Component (T); + while Present (Comp) loop + Append + (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg)); + Next_Component (Comp); + end loop; + + Analyze_And_Resolve (Agg, T); + return Agg; + end Build_Equivalent_Record_Aggregate; + ------------------------------- -- Build_Initialization_Call -- ------------------------------- - -- References to a discriminant inside the record type declaration - -- can appear either in the subtype_indication to constrain a - -- record or an array, or as part of a larger expression given for - -- the initial value of a component. In both of these cases N appears - -- in the record initialization procedure and needs to be replaced by - -- the formal parameter of the initialization procedure which - -- corresponds to that discriminant. + -- References to a discriminant inside the record type declaration can + -- appear either in the subtype_indication to constrain a record or an + -- array, or as part of a larger expression given for the initial value + -- of a component. In both of these cases N appears in the record + -- initialization procedure and needs to be replaced by the formal + -- parameter of the initialization procedure which corresponds to that + -- discriminant. -- In the example below, references to discriminants D1 and D2 in proc_1 -- are replaced by references to formals with the same name -- (discriminals) - -- A similar replacement is done for calls to any record - -- initialization procedure for any components that are themselves - -- of a record type. + -- A similar replacement is done for calls to any record initialization + -- procedure for any components that are themselves of a record type. -- type R (D1, D2 : Integer) is record -- X : Integer := F * D1; @@ -1055,27 +1384,46 @@ package body Exp_Ch3 is In_Init_Proc : Boolean := False; Enclos_Type : Entity_Id := Empty; Discr_Map : Elist_Id := New_Elmt_List; - With_Default_Init : Boolean := False) return List_Id + With_Default_Init : Boolean := False; + Constructor_Ref : Node_Id := Empty) return List_Id is - First_Arg : Node_Id; + Res : constant List_Id := New_List; + Arg : Node_Id; Args : List_Id; - Decls : List_Id; + Controller_Typ : Entity_Id; Decl : Node_Id; + Decls : List_Id; Discr : Entity_Id; - Arg : Node_Id; - Proc : constant Entity_Id := Base_Init_Proc (Typ); - Init_Type : constant Entity_Id := Etype (First_Formal (Proc)); - Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type); - Res : constant List_Id := New_List; + First_Arg : Node_Id; + Full_Init_Type : Entity_Id; Full_Type : Entity_Id := Typ; - Controller_Typ : Entity_Id; + Init_Type : Entity_Id; + Proc : Entity_Id; begin + pragma Assert (Constructor_Ref = Empty + or else Is_CPP_Constructor_Call (Constructor_Ref)); + + if No (Constructor_Ref) then + Proc := Base_Init_Proc (Typ); + else + Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref))); + end if; + + pragma Assert (Present (Proc)); + Init_Type := Etype (First_Formal (Proc)); + Full_Init_Type := Underlying_Type (Init_Type); + -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars -- is active (in which case we make the call anyway, since in the -- actual compiled client it may be non null). + -- Also nothing to do for value types. - if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then + if (Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars) + or else Is_Value_Type (Typ) + or else + (Is_Array_Type (Typ) and then Is_Value_Type (Component_Type (Typ))) + then return Empty_List; end if; @@ -1093,6 +1441,7 @@ package body Exp_Ch3 is -- honest. Actually it isn't quite type honest, because there can be -- conflicts of views in the private type case. That is why we set -- Conversion_OK in the conversion node. + if (Is_Record_Type (Typ) or else Is_Array_Type (Typ) or else Is_Private_Type (Typ)) @@ -1120,6 +1469,7 @@ package body Exp_Ch3 is -- for the value 3 (should be rtsfindable constant ???) Append_To (Args, Make_Integer_Literal (Loc, 3)); + else Append_To (Args, Make_Identifier (Loc, Name_uMaster)); end if; @@ -1136,7 +1486,8 @@ package body Exp_Ch3 is Strval => "")); else - Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type); + Decls := + Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc); Decl := Last (Decls); Append_To (Args, @@ -1157,9 +1508,9 @@ package body Exp_Ch3 is while Present (Discr) loop -- If this is a discriminated concurrent type, the init_proc - -- for the corresponding record is being called. Use that - -- type directly to find the discriminant value, to handle - -- properly intervening renamed discriminants. + -- for the corresponding record is being called. Use that type + -- directly to find the discriminant value, to handle properly + -- intervening renamed discriminants. declare T : Entity_Id := Full_Type; @@ -1206,11 +1557,10 @@ package body Exp_Ch3 is Prefix => New_Copy (Prefix (Id_Ref)), Attribute_Name => Name_Unrestricted_Access); - -- Otherwise make a copy of the default expression. Note - -- that we use the current Sloc for this, because we do not - -- want the call to appear to be at the declaration point. - -- Within the expression, replace discriminants with their - -- discriminals. + -- Otherwise make a copy of the default expression. Note that + -- we use the current Sloc for this, because we do not want the + -- call to appear to be at the declaration point. Within the + -- expression, replace discriminants with their discriminals. else Arg := @@ -1221,22 +1571,26 @@ package body Exp_Ch3 is if Is_Constrained (Full_Type) then Arg := Duplicate_Subexpr_No_Checks (Arg); else - -- The constraints come from the discriminant default - -- exps, they must be reevaluated, so we use New_Copy_Tree - -- but we ensure the proper Sloc (for any embedded calls). + -- The constraints come from the discriminant default exps, + -- they must be reevaluated, so we use New_Copy_Tree but we + -- ensure the proper Sloc (for any embedded calls). Arg := New_Copy_Tree (Arg, New_Sloc => Loc); end if; end if; - -- Ada 2005 (AI-287) In case of default initialized components, - -- we need to generate the corresponding selected component node - -- to access the discriminant value. In other cases this is not - -- required because we are inside the init proc and we use the - -- corresponding formal. + -- Ada 2005 (AI-287): In case of default initialized components, + -- if the component is constrained with a discriminant of the + -- enclosing type, we need to generate the corresponding selected + -- component node to access the discriminant value. In other cases + -- this is not required, either because we are inside the init + -- proc and we use the corresponding formal, or else because the + -- component is constrained by an expression. if With_Default_Init and then Nkind (Id_Ref) = N_Selected_Component + and then Nkind (Arg) = N_Identifier + and then Ekind (Entity (Arg)) = E_Discriminant then Append_To (Args, Make_Selected_Component (Loc, @@ -1259,6 +1613,10 @@ package body Exp_Ch3 is and then Chars (Selector_Name (Id_Ref)) = Name_uParent then Append_To (Args, New_Occurrence_Of (Standard_False, Loc)); + + elsif Present (Constructor_Ref) then + Append_List_To (Args, + New_Copy_List (Parameter_Associations (Constructor_Ref))); end if; Append_To (Res, @@ -1266,7 +1624,7 @@ package body Exp_Ch3 is Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => Args)); - if Controlled_Type (Typ) + if Needs_Finalization (Typ) and then Nkind (Id_Ref) = N_Selected_Component then if Chars (Selector_Name (Id_Ref)) /= Name_uParent then @@ -1281,6 +1639,7 @@ package body Exp_Ch3 is -- If the enclosing type is an extension with new controlled -- components, it has his own record controller. If the parent -- also had a record controller, attach it to the new one. + -- Build_Init_Statements relies on the fact that in this specific -- case the last statement of the result is the attach call to -- the controller. If this is changed, it must be synchronized. @@ -1289,7 +1648,7 @@ package body Exp_Ch3 is and then Has_New_Controlled_Component (Enclos_Type) and then Has_Controlled_Component (Typ) then - if Is_Return_By_Reference_Type (Typ) then + if Is_Inherently_Limited_Type (Typ) then Controller_Typ := RTE (RE_Limited_Record_Controller); else Controller_Typ := RTE (RE_Record_Controller); @@ -1318,7 +1677,10 @@ package body Exp_Ch3 is -- Build_Master_Renaming -- --------------------------- - procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is + function Build_Master_Renaming + (N : Node_Id; + T : Entity_Id) return Entity_Id + is Loc : constant Source_Ptr := Sloc (N); M_Id : Entity_Id; Decl : Node_Id; @@ -1327,7 +1689,7 @@ package body Exp_Ch3 is -- Nothing to do if there is no task hierarchy if Restriction_Active (No_Task_Hierarchy) then - return; + return Empty; end if; M_Id := @@ -1341,7 +1703,28 @@ package body Exp_Ch3 is Name => Make_Identifier (Loc, Name_uMaster)); Insert_Before (N, Decl); Analyze (Decl); + return M_Id; + + exception + when RE_Not_Available => + return Empty; + end Build_Master_Renaming; + + --------------------------- + -- Build_Master_Renaming -- + --------------------------- + + procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is + M_Id : Entity_Id; + + begin + -- Nothing to do if there is no task hierarchy + if Restriction_Active (No_Task_Hierarchy) then + return; + end if; + + M_Id := Build_Master_Renaming (N, T); Set_Master_Id (T, M_Id); exception @@ -1354,18 +1737,18 @@ package body Exp_Ch3 is ---------------------------- procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is - Loc : Source_Ptr := Sloc (N); - Discr_Map : constant Elist_Id := New_Elmt_List; - Proc_Id : Entity_Id; - Rec_Type : Entity_Id; - Set_Tag : Entity_Id := Empty; + Loc : Source_Ptr := Sloc (N); + Discr_Map : constant Elist_Id := New_Elmt_List; + Proc_Id : Entity_Id; + Rec_Type : Entity_Id; + Set_Tag : Entity_Id := Empty; function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; - -- Build a assignment statement node which assigns to record - -- component its default expression if defined. The left hand side - -- of the assignment is marked Assignment_OK so that initialization - -- of limited private records works correctly, Return also the - -- adjustment call for controlled objects + -- Build a assignment statement node which assigns to record component + -- its default expression if defined. The assignment left hand side is + -- marked Assignment_OK so that initialization of limited private + -- records works correctly, Return also the adjustment call for + -- controlled objects procedure Build_Discriminant_Assignments (Statement_List : List_Id); -- If the record has discriminants, adds assignment statements to @@ -1399,8 +1782,13 @@ package body Exp_Ch3 is -- of the initialization procedure (by calling all the preceding -- auxiliary routines), and install it as the _init TSS. + procedure Build_Offset_To_Top_Functions; + -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec + -- and body of the Offset_To_Top function that is generated when the + -- parent of a type with discriminants has secondary dispatch tables. + procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); - -- Add range checks to components of disciminated records. S is a + -- Add range checks to components of discriminated records. S is a -- subtype indication of a record component. Check_List is a list -- to which the check actions are appended. @@ -1408,10 +1796,10 @@ package body Exp_Ch3 is (T : Entity_Id) return Boolean; -- Determines if a component needs simple initialization, given its type -- T. This is the same as Needs_Simple_Initialization except for the - -- following difference: the types Tag, Interface_Tag, and Vtable_Ptr - -- which are access types which would normally require simple - -- initialization to null, do not require initialization as components, - -- since they are explicitly initialized by other means. + -- following difference: the types Tag and Interface_Tag, that are + -- access types which would normally require simple initialization to + -- null, do not require initialization as components, since they are + -- explicitly initialized by other means. procedure Constrain_Array (SI : Node_Id; @@ -1425,12 +1813,12 @@ package body Exp_Ch3 is (Index : Node_Id; S : Node_Id; Check_List : List_Id); - -- Called from Build_Record_Checks. -- Process an index constraint in a constrained array declaration. -- The constraint can be a subtype name, or a range with or without -- an explicit subtype mark. The index is the corresponding index of the -- unconstrained array. S is the range expression. Check_List is a list - -- to which the check actions are appended. + -- to which the check actions are appended (called from + -- Build_Record_Checks). function Parent_Subtype_Renaming_Discrims return Boolean; -- Returns True for base types N that rename discriminants, else False @@ -1481,28 +1869,12 @@ package body Exp_Ch3 is Attribute_Name => Name_Unrestricted_Access); end if; - -- Ada 2005 (AI-231): Add the run-time check if required - - if Ada_Version >= Ada_05 - and then Can_Never_Be_Null (Etype (Id)) -- Lhs - then - if Nkind (Exp) = N_Null then - return New_List ( - Make_Raise_Constraint_Error (Sloc (Exp), - Reason => CE_Null_Not_Allowed)); - - elsif Present (Etype (Exp)) - and then not Can_Never_Be_Null (Etype (Exp)) - then - Install_Null_Excluding_Check (Exp); - end if; - end if; - - -- Take a copy of Exp to ensure that later copies of this - -- component_declaration in derived types see the original tree, - -- not a node rewritten during expansion of the init_proc. + -- Take a copy of Exp to ensure that later copies of this component + -- declaration in derived types see the original tree, not a node + -- rewritten during expansion of the init_proc. If the copy contains + -- itypes, the scope of the new itypes is the init_proc being built. - Exp := New_Copy_Tree (Exp); + Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id); Res := New_List ( Make_Assignment_Statement (Loc, @@ -1512,15 +1884,15 @@ package body Exp_Ch3 is Set_No_Ctrl_Actions (First (Res)); -- Adjust the tag if tagged (because of possible view conversions). - -- Suppress the tag adjustment when Java_VM because JVM tags are + -- Suppress the tag adjustment when VM_Target because VM tags are -- represented implicitly in objects. - if Is_Tagged_Type (Typ) and then not Java_VM then + if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then Append_To (Res, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Lhs), + Prefix => New_Copy_Tree (Lhs, New_Scope => Proc_Id), Selector_Name => New_Reference_To (First_Tag_Component (Typ), Loc)), @@ -1530,23 +1902,28 @@ package body Exp_Ch3 is (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)))); end if; - -- Adjust the component if controlled except if it is an - -- aggregate that will be expanded inline + -- Adjust the component if controlled except if it is an aggregate + -- that will be expanded inline. if Kind = N_Qualified_Expression then Kind := Nkind (Expression (N)); end if; - if Controlled_Type (Typ) - and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) + if Needs_Finalization (Typ) + and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) + and then not Is_Inherently_Limited_Type (Typ) then - Append_List_To (Res, - Make_Adjust_Call ( - Ref => New_Copy_Tree (Lhs), - Typ => Etype (Id), - Flist_Ref => - Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)), - With_Attach => Make_Integer_Literal (Loc, 1))); + declare + Ref : constant Node_Id := + New_Copy_Tree (Lhs, New_Scope => Proc_Id); + begin + Append_List_To (Res, + Make_Adjust_Call ( + Ref => Ref, + Typ => Etype (Id), + Flist_Ref => Find_Final_List (Etype (Id), Ref), + With_Attach => Make_Integer_Literal (Loc, 1))); + end; end if; return Res; @@ -1571,9 +1948,10 @@ package body Exp_Ch3 is D := First_Discriminant (Rec_Type); while Present (D) loop + -- Don't generate the assignment for discriminants in derived -- tagged types if the discriminant is a renaming of some - -- ancestor discriminant. This initialization will be done + -- ancestor discriminant. This initialization will be done -- when initializing the _parent field of the derived record. if Is_Tagged and then @@ -1692,18 +2070,10 @@ package body Exp_Ch3 is New_Reference_To (Discriminal (Entity (Arg)), Loc)); -- Case of access discriminants. We replace the reference - -- to the type by a reference to the actual object + -- to the type by a reference to the actual object. --- ??? why is this code deleted without comment - --- elsif Nkind (Arg) = N_Attribute_Reference --- and then Is_Entity_Name (Prefix (Arg)) --- and then Is_Type (Entity (Prefix (Arg))) --- then --- Append_To (Args, --- Make_Attribute_Reference (Loc, --- Prefix => New_Copy (Prefix (Id_Ref)), --- Attribute_Name => Name_Unrestricted_Access)); + -- Is above comment right??? Use of New_Copy below seems mighty + -- suspicious ??? else Append_To (Args, New_Copy (Arg)); @@ -1722,120 +2092,143 @@ package body Exp_Ch3 is return Res; end Build_Init_Call_Thru; - -------------------------- - -- Build_Init_Procedure -- - -------------------------- + ----------------------------------- + -- Build_Offset_To_Top_Functions -- + ----------------------------------- - procedure Build_Init_Procedure is - Body_Node : Node_Id; - Handled_Stmt_Node : Node_Id; - Parameters : List_Id; - Proc_Spec_Node : Node_Id; - Body_Stmts : List_Id; - Record_Extension_Node : Node_Id; - Init_Tag : Node_Id; + procedure Build_Offset_To_Top_Functions is + + procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id); + -- Generate: + -- function Fxx (O : in Rec_Typ) return Storage_Offset is + -- begin + -- return O.Iface_Comp'Position; + -- end Fxx; - procedure Init_Secondary_Tags (Typ : Entity_Id); - -- Ada 2005 (AI-251): Initialize the tags of all the secondary - -- tables associated with abstract interface types + ---------------------------------- + -- Build_Offset_To_Top_Function -- + ---------------------------------- - ------------------------- - -- Init_Secondary_Tags -- - ------------------------- + procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is + Body_Node : Node_Id; + Func_Id : Entity_Id; + Spec_Node : Node_Id; - procedure Init_Secondary_Tags (Typ : Entity_Id) is - ADT : Elmt_Id; + begin + Func_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('F')); - procedure Init_Secondary_Tags_Internal (Typ : Entity_Id); - -- Internal subprogram used to recursively climb to the root type + Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id); - ---------------------------------- - -- Init_Secondary_Tags_Internal -- - ---------------------------------- + -- Generate + -- function Fxx (O : in Rec_Typ) return Storage_Offset; - procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is - E : Entity_Id; - Aux_N : Node_Id; + Spec_Node := New_Node (N_Function_Specification, Loc); + Set_Defining_Unit_Name (Spec_Node, Func_Id); + Set_Parameter_Specifications (Spec_Node, New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), + In_Present => True, + Parameter_Type => New_Reference_To (Rec_Type, Loc)))); + Set_Result_Definition (Spec_Node, + New_Reference_To (RTE (RE_Storage_Offset), Loc)); + + -- Generate + -- function Fxx (O : in Rec_Typ) return Storage_Offset is + -- begin + -- return O.Iface_Comp'Position; + -- end Fxx; + + Body_Node := New_Node (N_Subprogram_Body, Loc); + Set_Specification (Body_Node, Spec_Node); + Set_Declarations (Body_Node, New_List); + Set_Handled_Statement_Sequence (Body_Node, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uO), + Selector_Name => New_Reference_To + (Iface_Comp, Loc)), + Attribute_Name => Name_Position))))); + + Set_Ekind (Func_Id, E_Function); + Set_Mechanism (Func_Id, Default_Mechanism); + Set_Is_Internal (Func_Id, True); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; - begin - if not Is_Interface (Typ) - and then Etype (Typ) /= Typ - then - Init_Secondary_Tags_Internal (Etype (Typ)); - end if; + Analyze (Body_Node); - if Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) - then - E := First_Entity (Typ); - while Present (E) loop - if Is_Tag (E) - and then Chars (E) /= Name_uTag - then - Aux_N := Node (ADT); - pragma Assert (Present (Aux_N)); - - -- Initialize the pointer to the secondary DT - -- associated with the interface - - Append_To (Body_Stmts, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => - New_Reference_To (E, Loc)), - Expression => - New_Reference_To (Aux_N, Loc))); - - -- Generate: - -- Set_Offset_To_Top (DT_Ptr, n); - - Append_To (Body_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To - (RTE (RE_Set_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (Aux_N, Loc)), - Unchecked_Convert_To (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, - Name_uInit), - Selector_Name => New_Reference_To - (E, Loc)), - Attribute_Name => Name_Position))))); - - Next_Elmt (ADT); - end if; + Append_Freeze_Action (Rec_Type, Body_Node); + end Build_Offset_To_Top_Function; - Next_Entity (E); - end loop; - end if; - end Init_Secondary_Tags_Internal; + -- Local variables - -- Start of processing for Init_Secondary_Tags + Ifaces_Comp_List : Elist_Id; + Iface_Comp_Elmt : Elmt_Id; + Iface_Comp : Node_Id; - begin - -- Skip the first _Tag, which is the main tag of the - -- tagged type. Following tags correspond with abstract - -- interfaces. + -- Start of processing for Build_Offset_To_Top_Functions + + begin + -- Offset_To_Top_Functions are built only for derivations of types + -- with discriminants that cover interface types. + -- Nothing is needed either in case of virtual machines, since + -- interfaces are handled directly by the VM. + + if not Is_Tagged_Type (Rec_Type) + or else Etype (Rec_Type) = Rec_Type + or else not Has_Discriminants (Etype (Rec_Type)) + or else not Tagged_Type_Expansion + then + return; + end if; + + Collect_Interface_Components (Rec_Type, Ifaces_Comp_List); + + -- For each interface type with secondary dispatch table we generate + -- the Offset_To_Top_Functions (required to displace the pointer in + -- interface conversions) + + Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); + while Present (Iface_Comp_Elmt) loop + Iface_Comp := Node (Iface_Comp_Elmt); + pragma Assert (Is_Interface (Related_Type (Iface_Comp))); + + -- If the interface is a parent of Rec_Type it shares the primary + -- dispatch table and hence there is no need to build the function + + if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type) then + Build_Offset_To_Top_Function (Iface_Comp); + end if; + + Next_Elmt (Iface_Comp_Elmt); + end loop; + end Build_Offset_To_Top_Functions; - ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); - Init_Secondary_Tags_Internal (Typ); - end Init_Secondary_Tags; + -------------------------- + -- Build_Init_Procedure -- + -------------------------- - -- Start of processing for Build_Init_Procedure + procedure Build_Init_Procedure is + Body_Node : Node_Id; + Handled_Stmt_Node : Node_Id; + Parameters : List_Id; + Proc_Spec_Node : Node_Id; + Body_Stmts : List_Id; + Record_Extension_Node : Node_Id; + Init_Tags_List : List_Id; begin Body_Stmts := New_List; Body_Node := New_Node (N_Subprogram_Body, Loc); - - Proc_Id := - Make_Defining_Identifier (Loc, - Chars => Make_Init_Proc_Name (Rec_Type)); Set_Ekind (Proc_Id, E_Procedure); Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); @@ -1854,7 +2247,8 @@ package body Exp_Ch3 is and then not Is_CPP_Class (Rec_Type) then Set_Tag := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); Append_To (Parameters, Make_Parameter_Specification (Loc, @@ -1870,8 +2264,9 @@ package body Exp_Ch3 is if Parent_Subtype_Renaming_Discrims then -- N is a Derived_Type_Definition that renames the parameters - -- of the ancestor type. We init it by expanding our discrims - -- and call the ancestor _init_proc with a type-converted object + -- of the ancestor type. We initialize it by expanding our + -- discriminants and call the ancestor _init_proc with a + -- type-converted object Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); @@ -1913,18 +2308,23 @@ package body Exp_Ch3 is -- Add here the assignment to instantiate the Tag - -- The assignement corresponds to the code: + -- The assignment corresponds to the code: -- _Init._Tag := Typ'Tag; - -- Suppress the tag assignment when Java_VM because JVM tags are - -- represented implicitly in objects. + -- Suppress the tag assignment when VM_Target because VM tags are + -- represented implicitly in objects. It is also suppressed in case + -- of CPP_Class types because in this case the tag is initialized in + -- the C++ side. if Is_Tagged_Type (Rec_Type) and then not Is_CPP_Class (Rec_Type) - and then not Java_VM + and then Tagged_Type_Expansion + and then not No_Run_Time_Mode then - Init_Tag := + -- Initialize the primary tag + + Init_Tags_List := New_List ( Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, @@ -1934,43 +2334,70 @@ package body Exp_Ch3 is Expression => New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)); + (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); + + -- Generate the SCIL node associated with the initialization of + -- the tag component. + + if Generate_SCIL then + declare + New_Node : Node_Id; + + begin + New_Node := + Make_SCIL_Tag_Init (Sloc (First (Init_Tags_List))); + Set_SCIL_Related_Node (New_Node, First (Init_Tags_List)); + Set_SCIL_Entity (New_Node, Rec_Type); + Prepend_To (Init_Tags_List, New_Node); + end; + end if; + + -- Ada 2005 (AI-251): Initialize the secondary tags components + -- located at fixed positions (tags whose position depends on + -- variable size components are initialized later ---see below). + + if Ada_Version >= Ada_05 + and then not Is_Interface (Rec_Type) + and then Has_Interfaces (Rec_Type) + then + Init_Secondary_Tags + (Typ => Rec_Type, + Target => Make_Identifier (Loc, Name_uInit), + Stmts_List => Init_Tags_List, + Fixed_Comps => True, + Variable_Comps => False); + end if; -- The tag must be inserted before the assignments to other -- components, because the initial value of the component may - -- depend ot the tag (eg. through a dispatching operation on + -- depend on the tag (eg. through a dispatching operation on -- an access to the current type). The tag assignment is not done -- when initializing the parent component of a type extension, -- because in that case the tag is set in the extension. + -- Extensions of imported C++ classes add a final complication, -- because we cannot inhibit tag setting in the constructor for -- the parent. In that case we insert the tag initialization -- after the calls to initialize the parent. - Init_Tag := - Make_If_Statement (Loc, - Condition => New_Occurrence_Of (Set_Tag, Loc), - Then_Statements => New_List (Init_Tag)); - - if not Is_CPP_Class (Etype (Rec_Type)) then - Prepend_To (Body_Stmts, Init_Tag); - - -- Ada 2005 (AI-251): Initialization of all the tags - -- corresponding with abstract interfaces + if not Is_CPP_Class (Root_Type (Rec_Type)) then + Prepend_To (Body_Stmts, + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Set_Tag, Loc), + Then_Statements => Init_Tags_List)); - if Ada_Version >= Ada_05 - and then not Is_Interface (Rec_Type) - then - Init_Secondary_Tags (Rec_Type); - end if; + -- CPP_Class derivation: In this case the dispatch table of the + -- parent was built in the C++ side and we copy the table of the + -- parent to initialize the new dispatch table. else declare - Nod : Node_Id := First (Body_Stmts); + Nod : Node_Id; begin -- We assume the first init_proc call is for the parent + Nod := First (Body_Stmts); while Present (Next (Nod)) and then (Nkind (Nod) /= N_Procedure_Call_Statement or else not Is_Init_Proc (Name (Nod))) @@ -1978,9 +2405,91 @@ package body Exp_Ch3 is Nod := Next (Nod); end loop; - Insert_After (Nod, Init_Tag); + -- Generate: + -- ancestor_constructor (_init.parent); + -- if Arg2 then + -- inherit_prim_ops (_init._tag, new_dt, num_prims); + -- _init._tag := new_dt; + -- end if; + + Prepend_To (Init_Tags_List, + Build_Inherit_Prims (Loc, + Typ => Rec_Type, + Old_Tag_Node => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, + Chars => Name_uInit), + Selector_Name => + New_Reference_To + (First_Tag_Component (Rec_Type), Loc)), + New_Tag_Node => + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Rec_Type))), + Loc), + Num_Prims => + UI_To_Int + (DT_Entry_Count (First_Tag_Component (Rec_Type))))); + + Insert_After (Nod, + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Set_Tag, Loc), + Then_Statements => Init_Tags_List)); + + -- We have inherited table of the parent from the CPP side. + -- Now we fill the slots associated with Ada primitives. + -- This needs more work to avoid its execution each time + -- an object is initialized??? + + declare + E : Elmt_Id; + Prim : Node_Id; + + begin + E := First_Elmt (Primitive_Operations (Rec_Type)); + while Present (E) loop + Prim := Node (E); + + if not Is_Imported (Prim) + and then Convention (Prim) = Convention_CPP + and then not Present (Interface_Alias (Prim)) + then + Append_List_To (Init_Tags_List, + Register_Primitive (Loc, Prim => Prim)); + end if; + + Next_Elmt (E); + end loop; + end; end; end if; + + -- Ada 2005 (AI-251): Initialize the secondary tag components + -- located at variable positions. We delay the generation of this + -- code until here because the value of the attribute 'Position + -- applied to variable size components of the parent type that + -- depend on discriminants is only safely read at runtime after + -- the parent components have been initialized. + + if Ada_Version >= Ada_05 + and then not Is_Interface (Rec_Type) + and then Has_Interfaces (Rec_Type) + and then Has_Discriminants (Etype (Rec_Type)) + and then Is_Variable_Size_Record (Etype (Rec_Type)) + then + Init_Tags_List := New_List; + + Init_Secondary_Tags + (Typ => Rec_Type, + Target => Make_Identifier (Loc, Name_uInit), + Stmts_List => Init_Tags_List, + Fixed_Comps => False, + Variable_Comps => True); + + if Is_Non_Empty_List (Init_Tags_List) then + Append_List_To (Body_Stmts, Init_Tags_List); + end if; + end if; end if; Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); @@ -2002,8 +2511,16 @@ package body Exp_Ch3 is Set_Init_Proc (Rec_Type, Proc_Id); if List_Length (Body_Stmts) = 1 - and then Nkind (First (Body_Stmts)) = N_Null_Statement + + -- We must skip SCIL nodes because they may have been added to this + -- list by Insert_Actions. + + and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement + and then VM_Target = No_VM then + -- Even though the init proc may be null at this time it might get + -- some stuff added to it later by the VM backend. + Set_Is_Null_Init_Proc (Proc_Id); end if; end Build_Init_Procedure; @@ -2015,17 +2532,16 @@ package body Exp_Ch3 is function Build_Init_Statements (Comp_List : Node_Id) return List_Id is Check_List : constant List_Id := New_List; Alt_List : List_Id; + Decl : Node_Id; + Id : Entity_Id; + Names : Node_Id; Statement_List : List_Id; Stmts : List_Id; + Typ : Entity_Id; + Variant : Node_Id; Per_Object_Constraint_Components : Boolean; - Decl : Node_Id; - Variant : Node_Id; - - Id : Entity_Id; - Typ : Entity_Id; - function Has_Access_Constraint (E : Entity_Id) return Boolean; -- Components with access discriminants that depend on the current -- instance must be initialized after all other components. @@ -2066,8 +2582,49 @@ package body Exp_Ch3 is Statement_List := New_List; - -- Loop through components, skipping pragmas, in 2 steps. The first - -- step deals with regular components. The second step deals with + -- Loop through visible declarations of task types and protected + -- types moving any expanded code from the spec to the body of the + -- init procedure. + + if Is_Task_Record_Type (Rec_Type) + or else Is_Protected_Record_Type (Rec_Type) + then + declare + Decl : constant Node_Id := + Parent (Corresponding_Concurrent_Type (Rec_Type)); + Def : Node_Id; + N1 : Node_Id; + N2 : Node_Id; + + begin + if Is_Task_Record_Type (Rec_Type) then + Def := Task_Definition (Decl); + else + Def := Protected_Definition (Decl); + end if; + + if Present (Def) then + N1 := First (Visible_Declarations (Def)); + while Present (N1) loop + N2 := N1; + N1 := Next (N1); + + if Nkind (N2) in N_Statement_Other_Than_Procedure_Call + or else Nkind (N2) in N_Raise_xxx_Error + or else Nkind (N2) = N_Procedure_Call_Statement + then + Append_To (Statement_List, + New_Copy_Tree (N2, New_Scope => Proc_Id)); + Rewrite (N2, Make_Null_Statement (Sloc (N2))); + Analyze (N2); + end if; + end loop; + end if; + end; + end if; + + -- Loop through components, skipping pragmas, in 2 steps. The first + -- step deals with regular components. The second step deals with -- components have per object constraints, and no explicit initia- -- lization. @@ -2095,28 +2652,49 @@ package body Exp_Ch3 is -- Case of explicit initialization if Present (Expression (Decl)) then - Stmts := Build_Assignment (Id, Expression (Decl)); + if Is_CPP_Constructor_Call (Expression (Decl)) then + Stmts := + Build_Initialization_Call + (Loc, + Id_Ref => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ => Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map, + Constructor_Ref => Expression (Decl)); + else + Stmts := Build_Assignment (Id, Expression (Decl)); + end if; -- Case of composite component with its own Init_Proc - elsif Has_Non_Null_Base_Init_Proc (Typ) then + elsif not Is_Interface (Typ) + and then Has_Non_Null_Base_Init_Proc (Typ) + then Stmts := Build_Initialization_Call (Loc, - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => New_Occurrence_Of (Id, Loc)), - Typ, - True, - Rec_Type, - Discr_Map => Discr_Map); + Id_Ref => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ => Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map); + + Clean_Task_Names (Typ, Proc_Id); -- Case of component needing simple initialization elsif Component_Needs_Simple_Initialization (Typ) then Stmts := Build_Assignment - (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))); + (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))); -- Nothing needed for this case @@ -2134,15 +2712,16 @@ package body Exp_Ch3 is -- the _Parent field is attached to it when the attachment -- can occur. It does not work to simply initialize the -- controller first: it must be initialized after the parent - -- if the parent holds discriminants that can be used - -- to compute the offset of the controller. We assume here - -- that the last statement of the initialization call is the - -- attachement of the parent (see Build_Initialization_Call) + -- if the parent holds discriminants that can be used to + -- compute the offset of the controller. We assume here that + -- the last statement of the initialization call is the + -- attachment of the parent (see Build_Initialization_Call) if Chars (Id) = Name_uController and then Rec_Type /= Etype (Rec_Type) and then Has_Controlled_Component (Etype (Rec_Type)) and then Has_New_Controlled_Component (Rec_Type) + and then Present (Last (Statement_List)) then Insert_List_Before (Last (Statement_List), Stmts); else @@ -2154,68 +2733,11 @@ package body Exp_Ch3 is Next_Non_Pragma (Decl); end loop; - if Per_Object_Constraint_Components then - - -- Second pass: components with per-object constraints - - Decl := First_Non_Pragma (Component_Items (Comp_List)); - - while Present (Decl) loop - Loc := Sloc (Decl); - Id := Defining_Identifier (Decl); - Typ := Etype (Id); - - if Has_Access_Constraint (Id) - and then No (Expression (Decl)) - then - if Has_Non_Null_Base_Init_Proc (Typ) then - Append_List_To (Statement_List, - Build_Initialization_Call (Loc, - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => New_Occurrence_Of (Id, Loc)), - Typ, True, Rec_Type, Discr_Map => Discr_Map)); - - elsif Component_Needs_Simple_Initialization (Typ) then - Append_List_To (Statement_List, - Build_Assignment - (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id)))); - end if; - end if; - - Next_Non_Pragma (Decl); - end loop; - end if; - - -- Process the variant part - - if Present (Variant_Part (Comp_List)) then - Alt_List := New_List; - Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); - - while Present (Variant) loop - Loc := Sloc (Variant); - Append_To (Alt_List, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_Copy_List (Discrete_Choices (Variant)), - Statements => - Build_Init_Statements (Component_List (Variant)))); - - Next_Non_Pragma (Variant); - end loop; - - -- The expression of the case statement which is a reference - -- to one of the discriminants is replaced by the appropriate - -- formal parameter of the initialization procedure. - - Append_To (Statement_List, - Make_Case_Statement (Loc, - Expression => - New_Reference_To (Discriminal ( - Entity (Name (Variant_Part (Comp_List)))), Loc), - Alternatives => Alt_List)); - end if; + -- Set up tasks and protected object support. This needs to be done + -- before any component with a per-object access discriminant + -- constraint, or any variant part (which may contain such + -- components) is initialized, because the initialization of these + -- components may reference the enclosing concurrent object. -- For a task record type, add the task create call and calls -- to bind any interrupt (signal) entries. @@ -2242,6 +2764,17 @@ package body Exp_Ch3 is Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); + -- Generate the statements which map a string entry name to a + -- task entry index. Note that the task may not have entries. + + if Entry_Names_OK then + Names := Build_Entry_Names (Rec_Type); + + if Present (Names) then + Append_To (Statement_List, Names); + end if; + end if; + declare Task_Type : constant Entity_Id := Corresponding_Concurrent_Type (Rec_Type); @@ -2292,6 +2825,83 @@ package body Exp_Ch3 is if Is_Protected_Record_Type (Rec_Type) then Append_List_To (Statement_List, Make_Initialize_Protection (Rec_Type)); + + -- Generate the statements which map a string entry name to a + -- protected entry index. Note that the protected type may not + -- have entries. + + if Entry_Names_OK then + Names := Build_Entry_Names (Rec_Type); + + if Present (Names) then + Append_To (Statement_List, Names); + end if; + end if; + end if; + + if Per_Object_Constraint_Components then + + -- Second pass: components with per-object constraints + + Decl := First_Non_Pragma (Component_Items (Comp_List)); + while Present (Decl) loop + Loc := Sloc (Decl); + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + if Has_Access_Constraint (Id) + and then No (Expression (Decl)) + then + if Has_Non_Null_Base_Init_Proc (Typ) then + Append_List_To (Statement_List, + Build_Initialization_Call (Loc, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map)); + + Clean_Task_Names (Typ, Proc_Id); + + elsif Component_Needs_Simple_Initialization (Typ) then + Append_List_To (Statement_List, + Build_Assignment + (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)))); + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + end if; + + -- Process the variant part + + if Present (Variant_Part (Comp_List)) then + Alt_List := New_List; + Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (Variant) loop + Loc := Sloc (Variant); + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_Copy_List (Discrete_Choices (Variant)), + Statements => + Build_Init_Statements (Component_List (Variant)))); + Next_Non_Pragma (Variant); + end loop; + + -- The expression of the case statement which is a reference + -- to one of the discriminants is replaced by the appropriate + -- formal parameter of the initialization procedure. + + Append_To (Statement_List, + Make_Case_Statement (Loc, + Expression => + New_Reference_To (Discriminal ( + Entity (Name (Variant_Part (Comp_List)))), Loc), + Alternatives => Alt_List)); end if; -- If no initializations when generated for component declarations @@ -2345,8 +2955,10 @@ package body Exp_Ch3 is return Needs_Simple_Initialization (T) and then not Is_RTE (T, RE_Tag) - and then not Is_RTE (T, RE_Vtable_Ptr) - and then not Is_RTE (T, RE_Interface_Tag); -- Ada 2005 (AI-251) + + -- Ada 2005 (AI-251): Check also the tag of abstract interfaces + + and then not Is_RTE (T, RE_Interface_Tag); end Component_Needs_Simple_Initialization; --------------------- @@ -2441,7 +3053,7 @@ package body Exp_Ch3 is end if; -- Check if we have done some trivial renaming of the parent - -- discriminants, i.e. someting like + -- discriminants, i.e. something like -- -- type DT (X1,X2: int) is new PT (X1,X2); @@ -2478,6 +3090,15 @@ package body Exp_Ch3 is return False; end if; + -- If it is a type derived from a type with unknown discriminants, + -- we cannot build an initialization procedure for it. + + if Has_Unknown_Discriminants (Rec_Id) + or else Has_Unknown_Discriminants (Etype (Rec_Id)) + then + return False; + end if; + -- Otherwise we need to generate an initialization procedure if -- Is_CPP_Class is False and at least one of the following applies: @@ -2516,15 +3137,14 @@ package body Exp_Ch3 is -- since the call is generated, there had better be a routine -- at the other end of the call, even if it does nothing!) - -- Note: the reason we exclude the CPP_Class case is ??? + -- Note: the reason we exclude the CPP_Class case is because in this + -- case the initialization is performed in the C++ side. if Is_CPP_Class (Rec_Id) then return False; - elsif not Restriction_Active (No_Initialize_Scalars) - and then Is_Public (Rec_Id) - then - return True; + elsif Is_Interface (Rec_Id) then + return False; elsif (Has_Discriminants (Rec_Id) and then not Is_Unchecked_Union (Rec_Id)) @@ -2536,7 +3156,6 @@ package body Exp_Ch3 is end if; Id := First_Component (Rec_Id); - while Present (Id) loop Comp_Decl := Parent (Id); Typ := Etype (Id); @@ -2551,14 +3170,36 @@ package body Exp_Ch3 is Next_Component (Id); end loop; + -- As explained above, a record initialization procedure is needed + -- for public types in case Initialize_Scalars applies to a client. + -- However, such a procedure is not needed in the case where either + -- of restrictions No_Initialize_Scalars or No_Default_Initialization + -- applies. No_Initialize_Scalars excludes the possibility of using + -- Initialize_Scalars in any partition, and No_Default_Initialization + -- implies that no initialization should ever be done for objects of + -- the type, so is incompatible with Initialize_Scalars. + + if not Restriction_Active (No_Initialize_Scalars) + and then not Restriction_Active (No_Default_Initialization) + and then Is_Public (Rec_Id) + then + return True; + end if; + return False; end Requires_Init_Proc; -- Start of processing for Build_Record_Init_Proc begin + -- Check for value type, which means no initialization required + Rec_Type := Defining_Identifier (N); + if Is_Value_Type (Rec_Type) then + return; + end if; + -- This may be full declaration of a private type, in which case -- the visible entity is a record, and the private entity has been -- exchanged with it in the private part of the current package. @@ -2571,17 +3212,15 @@ package body Exp_Ch3 is -- If there are discriminants, build the discriminant map to replace -- discriminants by their discriminals in complex bound expressions. - -- These only arise for the corresponding records of protected types. + -- These only arise for the corresponding records of synchronized types. if Is_Concurrent_Record_Type (Rec_Type) and then Has_Discriminants (Rec_Type) then declare Disc : Entity_Id; - begin Disc := First_Discriminant (Rec_Type); - while Present (Disc) loop Append_Elmt (Disc, Discr_Map); Append_Elmt (Discriminal (Disc), Discr_Map); @@ -2611,6 +3250,21 @@ package body Exp_Ch3 is elsif Requires_Init_Proc (Rec_Type) or else Is_Unchecked_Union (Rec_Type) then + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => Make_Init_Proc_Name (Rec_Type)); + + -- If No_Default_Initialization restriction is active, then we don't + -- want to build an init_proc, but we need to mark that an init_proc + -- would be needed if this restriction was not active (so that we can + -- detect attempts to call it), so set a dummy init_proc in place. + + if Restriction_Active (No_Default_Initialization) then + Set_Init_Proc (Rec_Type, Proc_Id); + return; + end if; + + Build_Offset_To_Top_Functions; Build_Init_Procedure; Set_Is_Public (Proc_Id, Is_Public (Pe)); @@ -2624,7 +3278,7 @@ package body Exp_Ch3 is if not Is_Concurrent_Type (Rec_Type) and then not Has_Task (Rec_Type) - and then not Controlled_Type (Rec_Type) + and then not Needs_Finalization (Rec_Type) then Set_Is_Inlined (Proc_Id); end if; @@ -2635,6 +3289,70 @@ package body Exp_Ch3 is if not Debug_Generated_Code then Set_Debug_Info_Off (Proc_Id); end if; + + declare + Agg : constant Node_Id := + Build_Equivalent_Record_Aggregate (Rec_Type); + + procedure Collect_Itypes (Comp : Node_Id); + -- Generate references to itypes in the aggregate, because + -- the first use of the aggregate may be in a nested scope. + + -------------------- + -- Collect_Itypes -- + -------------------- + + procedure Collect_Itypes (Comp : Node_Id) is + Ref : Node_Id; + Sub_Aggr : Node_Id; + Typ : constant Entity_Id := Etype (Comp); + + begin + if Is_Array_Type (Typ) + and then Is_Itype (Typ) + then + Ref := Make_Itype_Reference (Loc); + Set_Itype (Ref, Typ); + Append_Freeze_Action (Rec_Type, Ref); + + Ref := Make_Itype_Reference (Loc); + Set_Itype (Ref, Etype (First_Index (Typ))); + Append_Freeze_Action (Rec_Type, Ref); + + Sub_Aggr := First (Expressions (Comp)); + + -- Recurse on nested arrays + + while Present (Sub_Aggr) loop + Collect_Itypes (Sub_Aggr); + Next (Sub_Aggr); + end loop; + end if; + end Collect_Itypes; + + begin + -- If there is a static initialization aggregate for the type, + -- generate itype references for the types of its (sub)components, + -- to prevent out-of-scope errors in the resulting tree. + -- The aggregate may have been rewritten as a Raise node, in which + -- case there are no relevant itypes. + + if Present (Agg) + and then Nkind (Agg) = N_Aggregate + then + Set_Static_Initialization (Proc_Id, Agg); + + declare + Comp : Node_Id; + begin + Comp := First (Component_Associations (Agg)); + while Present (Comp) loop + Collect_Itypes (Expression (Comp)); + Next (Comp); + end loop; + end; + end if; + end; end if; end Build_Record_Init_Proc; @@ -2645,14 +3363,20 @@ package body Exp_Ch3 is -- Generates the following subprogram: -- procedure Assign - -- (Source, Target : Array_Type, - -- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index; - -- Rev : Boolean) + -- (Source, Target : Array_Type, + -- Left_Lo, Left_Hi : Index; + -- Right_Lo, Right_Hi : Index; + -- Rev : Boolean) -- is -- Li1 : Index; -- Ri1 : Index; -- begin + + -- if Left_Hi < Left_Lo then + -- return; + -- end if; + -- if Rev then -- Li1 := Left_Hi; -- Ri1 := Right_Hi; @@ -2662,21 +3386,17 @@ package body Exp_Ch3 is -- end if; -- loop - -- if Rev then - -- exit when Li1 < Left_Lo; - -- else - -- exit when Li1 > Left_Hi; - -- end if; - - -- Target (Li1) := Source (Ri1); - - -- if Rev then - -- Li1 := Index'pred (Li1); - -- Ri1 := Index'pred (Ri1); - -- else - -- Li1 := Index'succ (Li1); - -- Ri1 := Index'succ (Ri1); - -- end if; + -- Target (Li1) := Source (Ri1); + + -- if Rev then + -- exit when Li1 = Left_Lo; + -- Li1 := Index'pred (Li1); + -- Ri1 := Index'pred (Ri1); + -- else + -- exit when Li1 = Left_Hi; + -- Li1 := Index'succ (Li1); + -- Ri1 := Index'succ (Ri1); + -- end if; -- end loop; -- end Assign; @@ -2740,6 +3460,16 @@ package body Exp_Ch3 is Stats := New_List; + -- Build test for empty slice case + + Append_To (Stats, + Make_If_Statement (Loc, + Condition => + Make_Op_Lt (Loc, + Left_Opnd => New_Occurrence_Of (Left_Hi, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)), + Then_Statements => New_List (Make_Simple_Return_Statement (Loc)))); + -- Build initializations for indices declare @@ -2790,7 +3520,7 @@ package body Exp_Ch3 is Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), End_Label => Empty); - -- Build exit condition + -- Build the exit condition and increment/decrement statements declare F_Ass : constant List_Id := New_List; @@ -2800,31 +3530,10 @@ package body Exp_Ch3 is Append_To (F_Ass, Make_Exit_Statement (Loc, Condition => - Make_Op_Gt (Loc, + Make_Op_Eq (Loc, Left_Opnd => New_Occurrence_Of (Lnn, Loc), Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); - Append_To (B_Ass, - Make_Exit_Statement (Loc, - Condition => - Make_Op_Lt (Loc, - Left_Opnd => New_Occurrence_Of (Lnn, Loc), - Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); - - Prepend_To (Statements (Loops), - Make_If_Statement (Loc, - Condition => New_Occurrence_Of (Rev, Loc), - Then_Statements => B_Ass, - Else_Statements => F_Ass)); - end; - - -- Build the increment/decrement statements - - declare - F_Ass : constant List_Id := New_List; - B_Ass : constant List_Id := New_List; - - begin Append_To (F_Ass, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Lnn, Loc), @@ -2848,6 +3557,13 @@ package body Exp_Ch3 is New_Occurrence_Of (Rnn, Loc))))); Append_To (B_Ass, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Lnn, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); + + Append_To (B_Ass, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Lnn, Loc), Expression => @@ -2972,11 +3688,12 @@ package body Exp_Ch3 is -- return False; -- end if; -- end case; + -- return True; -- end _Equality; procedure Build_Variant_Record_Equality (Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (Typ); + Loc : constant Source_Ptr := Sloc (Typ); F : constant Entity_Id := Make_Defining_Identifier (Loc, @@ -2990,9 +3707,9 @@ package body Exp_Ch3 is Make_Defining_Identifier (Loc, Chars => Name_Y); - Def : constant Node_Id := Parent (Typ); - Comps : constant Node_Id := Component_List (Type_Definition (Def)); - Stmts : constant List_Id := New_List; + Def : constant Node_Id := Parent (Typ); + Comps : constant Node_Id := Component_List (Type_Definition (Def)); + Stmts : constant List_Id := New_List; Pspecs : constant List_Id := New_List; begin @@ -3081,7 +3798,7 @@ package body Exp_Ch3 is Left_Opnd => New_Reference_To (A, Loc), Right_Opnd => New_Reference_To (B, Loc)), Then_Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc))))); -- Generate component-by-component comparison. Note that we must @@ -3105,7 +3822,7 @@ package body Exp_Ch3 is end if; Append_To (Stmts, - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc))); Set_TSS (Typ, F); @@ -3302,11 +4019,17 @@ package body Exp_Ch3 is Par_Id : Entity_Id; FN : Node_Id; - begin - if Is_Access_Type (Def_Id) then + procedure Build_Master (Def_Id : Entity_Id); + -- Create the master associated with Def_Id + + ------------------ + -- Build_Master -- + ------------------ + procedure Build_Master (Def_Id : Entity_Id) is + begin -- Anonymous access types are created for the components of the - -- record parameter for an entry declaration. No master is created + -- record parameter for an entry declaration. No master is created -- for such a type. if Has_Task (Designated_Type (Def_Id)) @@ -3316,17 +4039,20 @@ package body Exp_Ch3 is Build_Master_Renaming (Parent (Def_Id), Def_Id); -- Create a class-wide master because a Master_Id must be generated - -- for access-to-limited-class-wide types, whose root may be extended + -- for access-to-limited-class-wide types whose root may be extended -- with task components. + -- Note: This code covers access-to-limited-interfaces because they + -- can be used to reference tasks implementing them. + elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) and then Is_Limited_Type (Designated_Type (Def_Id)) and then Tasking_Allowed - -- Don't create a class-wide master for types whose convention is + -- Do not create a class-wide master for types whose convention is -- Java since these types cannot embed Ada tasks anyway. Note that -- the following test cannot catch the following case: - -- + -- package java.lang.Object is -- type Typ is tagged limited private; -- type Ref is access all Typ'Class; @@ -3334,26 +4060,111 @@ package body Exp_Ch3 is -- type Typ is tagged limited ...; -- pragma Convention (Typ, Java) -- end; - -- + -- Because the convention appears after we have done the -- processing for type Ref. and then Convention (Designated_Type (Def_Id)) /= Convention_Java + and then Convention (Designated_Type (Def_Id)) /= Convention_CIL then Build_Class_Wide_Master (Def_Id); + end if; + end Build_Master; + + -- Start of processing for Expand_N_Full_Type_Declaration + + begin + if Is_Access_Type (Def_Id) then + Build_Master (Def_Id); - elsif Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then + if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then Expand_Access_Protected_Subprogram_Type (N); end if; + elsif Ada_Version >= Ada_05 + and then Is_Array_Type (Def_Id) + and then Is_Access_Type (Component_Type (Def_Id)) + and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type + then + Build_Master (Component_Type (Def_Id)); + elsif Has_Task (Def_Id) then Expand_Previous_Access_Type (Def_Id); - end if; + + elsif Ada_Version >= Ada_05 + and then + (Is_Record_Type (Def_Id) + or else (Is_Array_Type (Def_Id) + and then Is_Record_Type (Component_Type (Def_Id)))) + then + declare + Comp : Entity_Id; + Typ : Entity_Id; + M_Id : Entity_Id; + + begin + -- Look for the first anonymous access type component + + if Is_Array_Type (Def_Id) then + Comp := First_Entity (Component_Type (Def_Id)); + else + Comp := First_Entity (Def_Id); + end if; + + while Present (Comp) loop + Typ := Etype (Comp); + + exit when Is_Access_Type (Typ) + and then Ekind (Typ) = E_Anonymous_Access_Type; + + Next_Entity (Comp); + end loop; + + -- If found we add a renaming declaration of master_id and we + -- associate it to each anonymous access type component. Do + -- nothing if the access type already has a master. This will be + -- the case if the array type is the packed array created for a + -- user-defined array type T, where the master_id is created when + -- expanding the declaration for T. + + if Present (Comp) + and then Ekind (Typ) = E_Anonymous_Access_Type + and then not Restriction_Active (No_Task_Hierarchy) + and then No (Master_Id (Typ)) + + -- Do not consider run-times with no tasking support + + and then RTE_Available (RE_Current_Master) + and then Has_Task (Non_Limited_Designated_Type (Typ)) + then + Build_Master_Entity (Def_Id); + M_Id := Build_Master_Renaming (N, Def_Id); + + if Is_Array_Type (Def_Id) then + Comp := First_Entity (Component_Type (Def_Id)); + else + Comp := First_Entity (Def_Id); + end if; + + while Present (Comp) loop + Typ := Etype (Comp); + + if Is_Access_Type (Typ) + and then Ekind (Typ) = E_Anonymous_Access_Type + then + Set_Master_Id (Typ, M_Id); + end if; + + Next_Entity (Comp); + end loop; + end if; + end; + end if; Par_Id := Etype (B_Id); - -- The parent type is private then we need to inherit - -- any TSS operations from the full view. + -- The parent type is private then we need to inherit any TSS operations + -- from the full view. if Ekind (Par_Id) in Private_Kind and then Present (Full_View (Par_Id)) @@ -3361,26 +4172,25 @@ package body Exp_Ch3 is Par_Id := Base_Type (Full_View (Par_Id)); end if; - if Nkind (Type_Definition (Original_Node (N))) - = N_Derived_Type_Definition + if Nkind (Type_Definition (Original_Node (N))) = + N_Derived_Type_Definition and then not Is_Tagged_Type (Def_Id) and then Present (Freeze_Node (Par_Id)) and then Present (TSS_Elist (Freeze_Node (Par_Id))) then Ensure_Freeze_Node (B_Id); - FN := Freeze_Node (B_Id); + FN := Freeze_Node (B_Id); if No (TSS_Elist (FN)) then Set_TSS_Elist (FN, New_Elmt_List); end if; declare - T_E : constant Elist_Id := TSS_Elist (FN); - Elmt : Elmt_Id; + T_E : constant Elist_Id := TSS_Elist (FN); + Elmt : Elmt_Id; begin - Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); - + Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); while Present (Elmt) loop if Chars (Node (Elmt)) /= Name_uInit then Append_Elmt (Node (Elmt), T_E); @@ -3415,26 +4225,79 @@ package body Exp_Ch3 is -- For all types, we call an initialization procedure if there is one procedure Expand_N_Object_Declaration (N : Node_Id) is - Def_Id : constant Entity_Id := Defining_Identifier (N); - Typ : constant Entity_Id := Etype (Def_Id); - Loc : constant Source_Ptr := Sloc (N); - Expr : constant Node_Id := Expression (N); - New_Ref : Node_Id; - Id_Ref : Node_Id; - Expr_Q : Node_Id; + Def_Id : constant Entity_Id := Defining_Identifier (N); + Expr : constant Node_Id := Expression (N); + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (Def_Id); + Base_Typ : constant Entity_Id := Base_Type (Typ); + Expr_Q : Node_Id; + Id_Ref : Node_Id; + New_Ref : Node_Id; + + Init_After : Node_Id := N; + -- Node after which the init proc call is to be inserted. This is + -- normally N, except for the case of a shared passive variable, in + -- which case the init proc call must be inserted only after the bodies + -- of the shared variable procedures have been seen. + + function Rewrite_As_Renaming return Boolean; + -- Indicate whether to rewrite a declaration with initialization into an + -- object renaming declaration (see below). + + ------------------------- + -- Rewrite_As_Renaming -- + ------------------------- + + function Rewrite_As_Renaming return Boolean is + begin + return not Aliased_Present (N) + and then Is_Entity_Name (Expr_Q) + and then Ekind (Entity (Expr_Q)) = E_Variable + and then OK_To_Rename (Entity (Expr_Q)) + and then Is_Entity_Name (Object_Definition (N)); + end Rewrite_As_Renaming; + + -- Start of processing for Expand_N_Object_Declaration begin - -- Don't do anything for deferred constants. All proper actions will - -- be expanded during the full declaration. + -- Don't do anything for deferred constants. All proper actions will be + -- expanded during the full declaration. if No (Expr) and Constant_Present (N) then return; end if; + -- Force construction of dispatch tables of library level tagged types + + if Tagged_Type_Expansion + and then Static_Dispatch_Tables + and then Is_Library_Level_Entity (Def_Id) + and then Is_Library_Level_Tagged_Type (Base_Typ) + and then (Ekind (Base_Typ) = E_Record_Type + or else Ekind (Base_Typ) = E_Protected_Type + or else Ekind (Base_Typ) = E_Task_Type) + and then not Has_Dispatch_Table (Base_Typ) + then + declare + New_Nodes : List_Id := No_List; + + begin + if Is_Concurrent_Type (Base_Typ) then + New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N); + else + New_Nodes := Make_DT (Base_Typ, N); + end if; + + if not Is_Empty_List (New_Nodes) then + Insert_List_Before (N, New_Nodes); + end if; + end; + end if; + -- Make shared memory routines for shared passive variable if Is_Shared_Passive (Def_Id) then - Make_Shared_Var_Procs (N); + Init_After := Make_Shared_Var_Procs (N); end if; -- If tasks being declared, make sure we have an activation chain @@ -3447,11 +4310,26 @@ package body Exp_Ch3 is Build_Master_Entity (Def_Id); end if; + -- Build a list controller for declarations where the type is anonymous + -- access and the designated type is controlled. Only declarations from + -- source files receive such controllers in order to provide the same + -- lifespan for any potential coextensions that may be associated with + -- the object. Finalization lists of internal controlled anonymous + -- access objects are already handled in Expand_N_Allocator. + + if Comes_From_Source (N) + and then Ekind (Typ) = E_Anonymous_Access_Type + and then Is_Controlled (Directly_Designated_Type (Typ)) + and then No (Associated_Final_Chain (Typ)) + then + Build_Final_List (N, Typ); + end if; + -- Default initialization required, and no expression present if No (Expr) then - -- Expand Initialize call for controlled objects. One may wonder why + -- Expand Initialize call for controlled objects. One may wonder why -- the Initialize Call is not done in the regular Init procedure -- attached to the record type. That's because the init procedure is -- recursively called on each component, including _Parent, thus the @@ -3459,7 +4337,7 @@ package body Exp_Ch3 is -- Initialize call as it is required but one for each ancestor of -- its type. This processing is suppressed if No_Initialization set. - if not Controlled_Type (Typ) + if not Needs_Finalization (Typ) or else No_Initialization (N) then null; @@ -3467,7 +4345,7 @@ package body Exp_Ch3 is elsif not Abort_Allowed or else not Comes_From_Source (N) then - Insert_Actions_After (N, + Insert_Actions_After (Init_After, Make_Init_Call ( Ref => New_Occurrence_Of (Def_Id, Loc), Typ => Base_Type (Typ), @@ -3493,22 +4371,22 @@ package body Exp_Ch3 is declare L : constant List_Id := - Make_Init_Call ( - Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Base_Type (Typ), - Flist_Ref => Find_Final_List (Def_Id), - With_Attach => Make_Integer_Literal (Loc, 1)); + Make_Init_Call + (Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Find_Final_List (Def_Id), + With_Attach => Make_Integer_Literal (Loc, 1)); Blk : constant Node_Id := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, L)); + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, L)); begin Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); Set_At_End_Proc (Handled_Statement_Sequence (Blk), New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); - Insert_Actions_After (N, New_List (Blk)); + Insert_Actions_After (Init_After, New_List (Blk)); Expand_At_End_Handler (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); end; @@ -3517,59 +4395,110 @@ package body Exp_Ch3 is -- Call type initialization procedure if there is one. We build the -- call and put it immediately after the object declaration, so that -- it will be expanded in the usual manner. Note that this will - -- result in proper handling of defaulted discriminants. The call - -- to the Init_Proc is suppressed if No_Initialization is set. + -- result in proper handling of defaulted discriminants. + + -- Need call if there is a base init proc if Has_Non_Null_Base_Init_Proc (Typ) - and then not No_Initialization (N) + + -- Suppress call if No_Initialization set on declaration + + and then not No_Initialization (N) + + -- Suppress call for special case of value type for VM + + and then not Is_Value_Type (Typ) + + -- Suppress call if Suppress_Init_Proc set on the type. This is + -- needed for the derived type case, where Suppress_Initialization + -- may be set for the derived type, even if there is an init proc + -- defined for the root type. + + and then not Suppress_Init_Proc (Typ) then - -- The call to the initialization procedure does NOT freeze - -- the object being initialized. This is because the call is - -- not a source level call. This works fine, because the only - -- possible statements depending on freeze status that can - -- appear after the _Init call are rep clauses which can - -- safely appear after actual references to the object. + -- Return without initializing when No_Default_Initialization + -- applies. Note that the actual restriction check occurs later, + -- when the object is frozen, because we don't know yet whether + -- the object is imported, which is a case where the check does + -- not apply. + + if Restriction_Active (No_Default_Initialization) then + return; + end if; + + -- The call to the initialization procedure does NOT freeze the + -- object being initialized. This is because the call is not a + -- source level call. This works fine, because the only possible + -- statements depending on freeze status that can appear after the + -- Init_Proc call are rep clauses which can safely appear after + -- actual references to the object. Note that this call may + -- subsequently be removed (if a pragma Import is encountered), + -- or moved to the freeze actions for the object (e.g. if an + -- address clause is applied to the object, causing it to get + -- delayed freezing). Id_Ref := New_Reference_To (Def_Id, Loc); Set_Must_Not_Freeze (Id_Ref); Set_Assignment_OK (Id_Ref); - Insert_Actions_After (N, - Build_Initialization_Call (Loc, Id_Ref, Typ)); + declare + Init_Expr : constant Node_Id := + Static_Initialization (Base_Init_Proc (Typ)); + begin + if Present (Init_Expr) then + Set_Expression + (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope)); + return; + else + Initialization_Warning (Id_Ref); + + Insert_Actions_After (Init_After, + Build_Initialization_Call (Loc, Id_Ref, Typ)); + end if; + end; -- If simple initialization is required, then set an appropriate -- simple initialization expression in place. This special - -- initialization is required even though No_Init_Flag is present. + -- initialization is required even though No_Init_Flag is present, + -- but is not needed if there was an explicit initialization. -- An internally generated temporary needs no initialization because - -- it will be assigned subsequently. In particular, there is no - -- point in applying Initialize_Scalars to such a temporary. + -- it will be assigned subsequently. In particular, there is no point + -- in applying Initialize_Scalars to such a temporary. elsif Needs_Simple_Initialization (Typ) - and then not Is_Internal (Def_Id) + and then not Is_Internal (Def_Id) + and then not Has_Init_Expression (N) then Set_No_Initialization (N, False); - Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id))); + Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); Analyze_And_Resolve (Expression (N), Typ); end if; -- Generate attribute for Persistent_BSS if needed - declare - Prag : Node_Id; - begin - if Persistent_BSS_Mode - and then Comes_From_Source (N) - and then Is_Potentially_Persistent_Type (Typ) - and then Is_Library_Level_Entity (Def_Id) - then + if Persistent_BSS_Mode + and then Comes_From_Source (N) + and then Is_Potentially_Persistent_Type (Typ) + and then not Has_Init_Expression (N) + and then Is_Library_Level_Entity (Def_Id) + then + declare + Prag : Node_Id; + begin Prag := Make_Linker_Section_Pragma (Def_Id, Sloc (N), ".persistent.bss"); Insert_After (N, Prag); Analyze (Prag); - end if; - end; + end; + end if; + + -- If access type, then we know it is null if not initialized + + if Is_Access_Type (Typ) then + Set_Is_Known_Null (Def_Id); + end if; -- Explicit initialization present @@ -3582,23 +4511,242 @@ package body Exp_Ch3 is Expr_Q := Expr; end if; - -- When we have the appropriate type of aggregate in the - -- expression (it has been determined during analysis of the - -- aggregate by setting the delay flag), let's perform in - -- place assignment and thus avoid creating a temporary. + -- When we have the appropriate type of aggregate in the expression + -- (it has been determined during analysis of the aggregate by + -- setting the delay flag), let's perform in place assignment and + -- thus avoid creating a temporary. if Is_Delayed_Aggregate (Expr_Q) then Convert_Aggr_In_Object_Decl (N); + -- Ada 2005 (AI-318-02): If the initialization expression is a call + -- to a build-in-place function, then access to the declared object + -- must be passed to the function. Currently we limit such functions + -- to those with constrained limited result subtypes, but eventually + -- plan to expand the allowed forms of functions that are treated as + -- build-in-place. + + elsif Ada_Version >= Ada_05 + and then Is_Build_In_Place_Function_Call (Expr_Q) + then + Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); + + -- The previous call expands the expression initializing the + -- built-in-place object into further code that will be analyzed + -- later. No further expansion needed here. + + return; + + -- Ada 2005 (AI-251): Rewrite the expression that initializes a + -- class-wide object to ensure that we copy the full object, + -- unless we are targetting a VM where interfaces are handled by + -- VM itself. Note that if the root type of Typ is an ancestor + -- of Expr's type, both types share the same dispatch table and + -- there is no need to displace the pointer. + + elsif Comes_From_Source (N) + and then Is_Interface (Typ) + then + pragma Assert (Is_Class_Wide_Type (Typ)); + + -- If the object is a return object of an inherently limited type, + -- which implies build-in-place treatment, bypass the special + -- treatment of class-wide interface initialization below. In this + -- case, the expansion of the return statement will take care of + -- creating the object (via allocator) and initializing it. + + if Is_Return_Object (Def_Id) + and then Is_Inherently_Limited_Type (Typ) + then + null; + + elsif Tagged_Type_Expansion then + declare + Iface : constant Entity_Id := Root_Type (Typ); + Expr_N : Node_Id := Expr; + Expr_Typ : Entity_Id; + + Decl_1 : Node_Id; + Decl_2 : Node_Id; + New_Expr : Node_Id; + + begin + -- If the original node of the expression was a conversion + -- to this specific class-wide interface type then we + -- restore the original node to generate code that + -- statically displaces the pointer to the interface + -- component. + + if not Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Unchecked_Type_Conversion + and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion + and then Etype (Original_Node (Expr_N)) = Typ + then + Rewrite (Expr_N, Original_Node (Expression (N))); + end if; + + -- Avoid expansion of redundant interface conversion + + if Is_Interface (Etype (Expr_N)) + and then Nkind (Expr_N) = N_Type_Conversion + and then Etype (Expr_N) = Typ + then + Expr_N := Expression (Expr_N); + Set_Expression (N, Expr_N); + end if; + + Expr_Typ := Base_Type (Etype (Expr_N)); + + if Is_Class_Wide_Type (Expr_Typ) then + Expr_Typ := Root_Type (Expr_Typ); + end if; + + -- Replace + -- CW : I'Class := Obj; + -- by + -- Tmp : T := Obj; + -- CW : I'Class renames TiC!(Tmp.I_Tag); + + if Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Identifier + and then not Is_Interface (Expr_Typ) + and then (Expr_Typ = Etype (Expr_Typ) + or else not + Is_Variable_Size_Record (Etype (Expr_Typ))) + then + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Object_Definition => + New_Occurrence_Of (Expr_Typ, Loc), + Expression => + Unchecked_Convert_To (Expr_Typ, + Relocate_Node (Expr_N))); + + -- Statically reference the tag associated with the + -- interface + + Decl_2 := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Name => + Unchecked_Convert_To (Typ, + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier (Decl_1), Loc), + Selector_Name => + New_Reference_To + (Find_Interface_Tag (Expr_Typ, Iface), + Loc)))); + + -- General case: + + -- Replace + -- IW : I'Class := Obj; + -- by + -- type Equiv_Record is record ... end record; + -- implicit subtype CW is ; + -- Temp : CW := CW!(Obj'Address); + -- IW : I'Class renames Displace (Temp, I'Tag); + + else + -- Generate the equivalent record type + + Expand_Subtype_From_Expr + (N => N, + Unc_Type => Typ, + Subtype_Indic => Object_Definition (N), + Exp => Expression (N)); + + if not Is_Interface (Etype (Expression (N))) then + New_Expr := Relocate_Node (Expression (N)); + else + New_Expr := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Expression (N)), + Attribute_Name => Name_Address))); + end if; + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Object_Definition => + New_Occurrence_Of + (Etype (Object_Definition (N)), Loc), + Expression => + Unchecked_Convert_To + (Etype (Object_Definition (N)), New_Expr)); + + Decl_2 := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Name => + Unchecked_Convert_To (Typ, + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier (Decl_1), Loc), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Iface))), + Loc)))))))); + end if; + + Insert_Action (N, Decl_1); + Rewrite (N, Decl_2); + Analyze (N); + + -- Replace internal identifier of Decl_2 by the identifier + -- found in the sources. We also have to exchange entities + -- containing their defining identifiers to ensure the + -- correct replacement of the object declaration by this + -- object renaming declaration (because such definings + -- identifier have been previously added by Enter_Name to + -- the current scope). We must preserve the homonym chain + -- of the source entity as well. + + Set_Chars (Defining_Identifier (N), Chars (Def_Id)); + Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); + Exchange_Entities (Defining_Identifier (N), Def_Id); + end; + end if; + + return; + else - -- In most cases, we must check that the initial value meets - -- any constraint imposed by the declared type. However, there - -- is one very important exception to this rule. If the entity - -- has an unconstrained nominal subtype, then it acquired its - -- constraints from the expression in the first place, and not - -- only does this mean that the constraint check is not needed, - -- but an attempt to perform the constraint check can - -- cause order of elaboration problems. + -- In most cases, we must check that the initial value meets any + -- constraint imposed by the declared type. However, there is one + -- very important exception to this rule. If the entity has an + -- unconstrained nominal subtype, then it acquired its constraints + -- from the expression in the first place, and not only does this + -- mean that the constraint check is not needed, but an attempt to + -- perform the constraint check can cause order of elaboration + -- problems. if not Is_Constr_Subt_For_U_Nominal (Typ) then @@ -3612,66 +4760,56 @@ package body Exp_Ch3 is null; else Apply_Constraint_Check (Expr, Typ); - end if; - end if; - - -- If the type is controlled we attach the object to the final - -- list and adjust the target after the copy. This - - if Controlled_Type (Typ) then - declare - Flist : Node_Id; - F : Entity_Id; - - begin - -- Attach the result to a dummy final list which will never - -- be finalized if Delay_Finalize_Attachis set. It is - -- important to attach to a dummy final list rather than - -- not attaching at all in order to reset the pointers - -- coming from the initial value. Equivalent code exists - -- in the sec-stack case in Exp_Ch4.Expand_N_Allocator. - - if Delay_Finalize_Attach (N) then - F := - Make_Defining_Identifier (Loc, New_Internal_Name ('F')); - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => F, - Object_Definition => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); - Flist := New_Reference_To (F, Loc); + -- If the expression has been marked as requiring a range + -- generate it now and reset the flag. - else - Flist := Find_Final_List (Def_Id); + if Do_Range_Check (Expr) then + Set_Do_Range_Check (Expr, False); + Generate_Range_Check (Expr, Typ, CE_Range_Check_Failed); end if; + end if; + end if; - Insert_Actions_After (N, - Make_Adjust_Call ( - Ref => New_Reference_To (Def_Id, Loc), - Typ => Base_Type (Typ), - Flist_Ref => Flist, - With_Attach => Make_Integer_Literal (Loc, 1))); - end; + -- If the type is controlled and not inherently limited, then + -- the target is adjusted after the copy and attached to the + -- finalization list. However, no adjustment is done in the case + -- where the object was initialized by a call to a function whose + -- result is built in place, since no copy occurred. (Eventually + -- we plan to support in-place function results for some cases + -- of nonlimited types. ???) Similarly, no adjustment is required + -- if we are going to rewrite the object declaration into a + -- renaming declaration. + + if Needs_Finalization (Typ) + and then not Is_Inherently_Limited_Type (Typ) + and then not Rewrite_As_Renaming + then + Insert_Actions_After (Init_After, + Make_Adjust_Call ( + Ref => New_Reference_To (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Find_Final_List (Def_Id), + With_Attach => Make_Integer_Literal (Loc, 1))); end if; -- For tagged types, when an init value is given, the tag has to -- be re-initialized separately in order to avoid the propagation -- of a wrong tag coming from a view conversion unless the type - -- is class wide (in this case the tag comes from the init - -- value). Suppress the tag assignment when Java_VM because JVM - -- tags are represented implicitly in objects. Ditto for types - -- that are CPP_CLASS, and for initializations that are - -- aggregates, because they have to have the right tag. + -- is class wide (in this case the tag comes from the init value). + -- Suppress the tag assignment when VM_Target because VM tags are + -- represented implicitly in objects. Ditto for types that are + -- CPP_CLASS, and for initializations that are aggregates, because + -- they have to have the right tag. if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) and then not Is_CPP_Class (Typ) - and then not Java_VM + and then Tagged_Type_Expansion and then Nkind (Expr) /= N_Aggregate then - -- The re-assignment of the tag has to be done even if - -- the object is a constant + -- The re-assignment of the tag has to be done even if the + -- object is a constant. New_Ref := Make_Selected_Component (Loc, @@ -3681,7 +4819,7 @@ package body Exp_Ch3 is Set_Assignment_OK (New_Ref); - Insert_After (N, + Insert_After (Init_After, Make_Assignment_Statement (Loc, Name => New_Ref, Expression => @@ -3692,12 +4830,30 @@ package body Exp_Ch3 is (Access_Disp_Table (Base_Type (Typ)))), Loc)))); + elsif Is_Tagged_Type (Typ) + and then Is_CPP_Constructor_Call (Expr) + then + -- The call to the initialization procedure does NOT freeze the + -- object being initialized. + + Id_Ref := New_Reference_To (Def_Id, Loc); + Set_Must_Not_Freeze (Id_Ref); + Set_Assignment_OK (Id_Ref); + + Insert_Actions_After (Init_After, + Build_Initialization_Call (Loc, Id_Ref, Typ, + Constructor_Ref => Expr)); + + -- We remove here the original call to the constructor + -- to avoid its management in the backend + + Set_Expression (N, Empty); + return; + -- For discrete types, set the Is_Known_Valid flag if the -- initializing value is known to be valid. - elsif Is_Discrete_Type (Typ) - and then Expr_Known_Valid (Expr) - then + elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then Set_Is_Known_Valid (Def_Id); elsif Is_Access_Type (Typ) then @@ -3707,7 +4863,7 @@ package body Exp_Ch3 is -- Can_Never_Be_Null if this is a constant. if Known_Non_Null (Expr) then - Set_Is_Known_Non_Null (Def_Id); + Set_Is_Known_Non_Null (Def_Id, True); if Constant_Present (N) then Set_Can_Never_Be_Null (Def_Id); @@ -3715,29 +4871,34 @@ package body Exp_Ch3 is end if; end if; - -- If validity checking on copies, validate initial expression + -- If validity checking on copies, validate initial expression. + -- But skip this if declaration is for a generic type, since it + -- makes no sense to validate generic types. Not clear if this + -- can happen for legal programs, but it definitely can arise + -- from previous instantiation errors. if Validity_Checks_On - and then Validity_Check_Copies + and then Validity_Check_Copies + and then not Is_Generic_Type (Etype (Def_Id)) then Ensure_Valid (Expr); Set_Is_Known_Valid (Def_Id); end if; end if; - -- Cases where the back end cannot handle the initialization - -- directly. In such cases, we expand an assignment that will - -- be appropriately handled by Expand_N_Assignment_Statement. + -- Cases where the back end cannot handle the initialization directly + -- In such cases, we expand an assignment that will be appropriately + -- handled by Expand_N_Assignment_Statement. - -- The exclusion of the unconstrained case is wrong, but for - -- now it is too much trouble ??? + -- The exclusion of the unconstrained case is wrong, but for now it + -- is too much trouble ??? if (Is_Possibly_Unaligned_Slice (Expr) or else (Is_Possibly_Unaligned_Object (Expr) and then not Represented_As_Scalar (Etype (Expr)))) - -- The exclusion of the unconstrained case is wrong, but for - -- now it is too much trouble ??? + -- The exclusion of the unconstrained case is wrong, but for now + -- it is too much trouble ??? and then not (Is_Array_Type (Etype (Expr)) and then not Is_Constrained (Etype (Expr))) @@ -3752,17 +4913,38 @@ package body Exp_Ch3 is Set_No_Initialization (N); Set_Assignment_OK (Name (Stat)); Set_No_Ctrl_Actions (Stat); - Insert_After (N, Stat); - Analyze (Stat); + Insert_After_And_Analyze (Init_After, Stat); end; end if; - end if; - -- For array type, check for size too large - -- We really need this for record types too??? + -- Final transformation, if the initializing expression is an entity + -- for a variable with OK_To_Rename set, then we transform: + + -- X : typ := expr; + + -- into + + -- X : typ renames expr + + -- provided that X is not aliased. The aliased case has to be + -- excluded in general because Expr will not be aliased in general. + + if Rewrite_As_Renaming then + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Defining_Identifier (N), + Subtype_Mark => Object_Definition (N), + Name => Expr_Q)); + + -- We do not analyze this renaming declaration, because all its + -- components have already been analyzed, and if we were to go + -- ahead and analyze it, we would in effect be trying to generate + -- another declaration of X, which won't do! + + Set_Renamed_Object (Defining_Identifier (N), Expr_Q); + Set_Analyzed (N); + end if; - if Is_Array_Type (Typ) then - Apply_Array_Size_Check (N, Typ); end if; exception @@ -3777,17 +4959,18 @@ package body Exp_Ch3 is -- Add a check on the range of the subtype. The static case is partially -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need -- to check here for the static case in order to avoid generating - -- extraneous expanded code. + -- extraneous expanded code. Also deal with validity checking. procedure Expand_N_Subtype_Indication (N : Node_Id) is Ran : constant Node_Id := Range_Expression (Constraint (N)); Typ : constant Entity_Id := Entity (Subtype_Mark (N)); begin - if Nkind (Parent (N)) = N_Constrained_Array_Definition or else - Nkind (Parent (N)) = N_Slice - then - Resolve (Ran, Typ); + if Nkind (Constraint (N)) = N_Range_Constraint then + Validity_Check_Range (Range_Expression (Constraint (N))); + end if; + + if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then Apply_Range_Check (Ran, Typ); end if; end Expand_N_Subtype_Indication; @@ -3799,10 +4982,9 @@ package body Exp_Ch3 is -- If the last variant does not contain the Others choice, replace it with -- an N_Others_Choice node since Gigi always wants an Others. Note that we -- do not bother to call Analyze on the modified variant part, since it's - -- only effect would be to compute the contents of the - -- Others_Discrete_Choices node laboriously, and of course we already know - -- the list of choices that corresponds to the others choice (it's the - -- list we are replacing!) + -- only effect would be to compute the Others_Discrete_Choices node + -- laboriously, and of course we already know the list of choices that + -- corresponds to the others choice (it's the list we are replacing!) procedure Expand_N_Variant_Part (N : Node_Id) is Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N)); @@ -3825,11 +5007,13 @@ package body Exp_Ch3 is begin -- Find all access types declared in the current scope, whose - -- designated type is Def_Id. + -- designated type is Def_Id. If it does not have a Master_Id, + -- create one now. while Present (T) loop if Is_Access_Type (T) and then Designated_Type (T) = Def_Id + and then No (Master_Id (T)) then Build_Master_Entity (Def_Id); Build_Master_Renaming (Parent (Def_Id), T); @@ -3875,7 +5059,7 @@ package body Exp_Ch3 is Loc := Sloc (First (Component_Items (Comp_List))); end if; - if Is_Return_By_Reference_Type (T) then + if Is_Inherently_Limited_Type (T) then Controller_Type := RTE (RE_Limited_Record_Controller); else Controller_Type := RTE (RE_Record_Controller); @@ -3899,21 +5083,50 @@ package body Exp_Ch3 is else -- The controller cannot be placed before the _Parent field since - -- gigi lays out field in order and _parent must be first to - -- preserve the polymorphism of tagged types. + -- gigi lays out field in order and _parent must be first to preserve + -- the polymorphism of tagged types. First_Comp := First (Component_Items (Comp_List)); - if Chars (Defining_Identifier (First_Comp)) /= Name_uParent - and then Chars (Defining_Identifier (First_Comp)) /= Name_uTag - then + if not Is_Tagged_Type (T) then Insert_Before (First_Comp, Comp_Decl); + + -- if T is a tagged type, place controller declaration after parent + -- field and after eventual tags of interface types. + else - Insert_After (First_Comp, Comp_Decl); + while Present (First_Comp) + and then + (Chars (Defining_Identifier (First_Comp)) = Name_uParent + or else Is_Tag (Defining_Identifier (First_Comp)) + + -- Ada 2005 (AI-251): The following condition covers secondary + -- tags but also the adjacent component containing the offset + -- to the base of the object (component generated if the parent + -- has discriminants --- see Add_Interface_Tag_Components). + -- This is required to avoid the addition of the controller + -- between the secondary tag and its adjacent component. + + or else Present + (Related_Type + (Defining_Identifier (First_Comp)))) + loop + Next (First_Comp); + end loop; + + -- An empty tagged extension might consist only of the parent + -- component. Otherwise insert the controller before the first + -- component that is neither parent nor tag. + + if Present (First_Comp) then + Insert_Before (First_Comp, Comp_Decl); + else + Append (Comp_Decl, Component_Items (Comp_List)); + end if; end if; end if; - New_Scope (T); + Push_Scope (T); Analyze (Comp_Decl); Set_Ekind (Ent, E_Component); Init_Component_Location (Ent); @@ -4006,13 +5219,32 @@ package body Exp_Ch3 is return; end Expand_Tagged_Root; - ----------------------- - -- Freeze_Array_Type -- - ----------------------- + ---------------------- + -- Clean_Task_Names -- + ---------------------- + + procedure Clean_Task_Names + (Typ : Entity_Id; + Proc_Id : Entity_Id) + is + begin + if Has_Task (Typ) + and then not Restriction_Active (No_Implicit_Heap_Allocations) + and then not Global_Discard_Names + and then Tagged_Type_Expansion + then + Set_Uses_Sec_Stack (Proc_Id); + end if; + end Clean_Task_Names; - procedure Freeze_Array_Type (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); - Base : constant Entity_Id := Base_Type (Typ); + ------------------------------ + -- Expand_Freeze_Array_Type -- + ------------------------------ + + procedure Expand_Freeze_Array_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Base : constant Entity_Id := Base_Type (Typ); begin if not Is_Bit_Packed_Array (Typ) then @@ -4022,17 +5254,17 @@ package body Exp_Ch3 is -- been a private type at the point of definition. Same if component -- type is controlled. - Set_Has_Task (Base, Has_Task (Component_Type (Typ))); + Set_Has_Task (Base, Has_Task (Comp_Typ)); Set_Has_Controlled_Component (Base, - Has_Controlled_Component (Component_Type (Typ)) - or else Is_Controlled (Component_Type (Typ))); + Has_Controlled_Component (Comp_Typ) + or else Is_Controlled (Comp_Typ)); if No (Init_Proc (Base)) then -- If this is an anonymous array created for a declaration with -- an initial value, its init_proc will never be called. The - -- initial value itself may have been expanded into assign- - -- ments, in which case the object declaration is carries the + -- initial value itself may have been expanded into assignments, + -- in which case the object declaration is carries the -- No_Initialization flag. if Is_Itype (Base) @@ -4062,32 +5294,43 @@ package body Exp_Ch3 is end if; end if; - if Typ = Base and then Has_Controlled_Component (Base) then - Build_Controlling_Procs (Base); + if Typ = Base then + if Has_Controlled_Component (Base) then + Build_Controlling_Procs (Base); + + if not Is_Limited_Type (Comp_Typ) + and then Number_Dimensions (Typ) = 1 + then + Build_Slice_Assignment (Typ); + end if; - if not Is_Limited_Type (Component_Type (Typ)) - and then Number_Dimensions (Typ) = 1 + elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) then - Build_Slice_Assignment (Typ); + Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ)); end if; end if; - -- For packed case, there is a default initialization, except if the - -- component type is itself a packed structure with an initialization - -- procedure. + -- For packed case, default initialization, except if the component type + -- is itself a packed structure with an initialization procedure, or + -- initialize/normalize scalars active, and we have a base type, or the + -- type is public, because in that case a client might specify + -- Normalize_Scalars and there better be a public Init_Proc for it. - elsif Present (Init_Proc (Component_Type (Base))) - and then No (Base_Init_Proc (Base)) + elsif (Present (Init_Proc (Component_Type (Base))) + and then No (Base_Init_Proc (Base))) + or else (Init_Or_Norm_Scalars and then Base = Typ) + or else Is_Public (Typ) then Build_Array_Init_Proc (Base, N); end if; - end Freeze_Array_Type; + end Expand_Freeze_Array_Type; - ----------------------------- - -- Freeze_Enumeration_Type -- - ----------------------------- + ------------------------------------ + -- Expand_Freeze_Enumeration_Type -- + ------------------------------------ - procedure Freeze_Enumeration_Type (N : Node_Id) is + procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is Typ : constant Entity_Id := Entity (N); Loc : constant Source_Ptr := Sloc (Typ); Ent : Entity_Id; @@ -4104,14 +5347,14 @@ package body Exp_Ch3 is pragma Warnings (Off, Func); begin - -- Various optimization are possible if the given representation is - -- contiguous. + -- Various optimizations possible if given representation is contiguous Is_Contiguous := True; + Ent := First_Literal (Typ); Last_Repval := Enumeration_Rep (Ent); - Next_Literal (Ent); + Next_Literal (Ent); while Present (Ent) loop if Enumeration_Rep (Ent) - Last_Repval /= 1 then Is_Contiguous := False; @@ -4215,6 +5458,8 @@ package body Exp_Ch3 is -- case and there is no obligation to raise Constraint_Error here!) We -- also do this if pragma Restrictions (No_Exceptions) is active. + -- Is this right??? What about No_Exception_Propagation??? + -- Representations are signed if Enumeration_Rep (First_Literal (Typ)) < 0 then @@ -4282,12 +5527,11 @@ package body Exp_Ch3 is Make_Integer_Literal (Loc, Intval => Last_Repval))), Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Pos_Expr)))); else Ent := First_Literal (Typ); - while Present (Ent) loop Append_To (Lst, Make_Case_Statement_Alternative (Loc, @@ -4296,7 +5540,7 @@ package body Exp_Ch3 is Intval => Enumeration_Rep (Ent))), Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, Intval => Enumeration_Pos (Ent)))))); @@ -4307,7 +5551,7 @@ package body Exp_Ch3 is -- In normal mode, add the others clause with the test - if not Restriction_Active (No_Exception_Handlers) then + if not No_Exception_Handlers_Set then Append_To (Lst, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Others_Choice (Loc)), @@ -4315,12 +5559,12 @@ package body Exp_Ch3 is Make_Raise_Constraint_Error (Loc, Condition => Make_Identifier (Loc, Name_uF), Reason => CE_Invalid_Data), - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, -1))))); - -- If Restriction (No_Exceptions_Handlers) is active then we always - -- return -1 (since we cannot usefully raise Constraint_Error in + -- If either of the restrictions No_Exceptions_Handlers/Propagation is + -- active then return -1 (we cannot usefully raise Constraint_Error in -- this case). See description above for further details. else @@ -4328,7 +5572,7 @@ package body Exp_Ch3 is Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, -1))))); end if; @@ -4376,28 +5620,44 @@ package body Exp_Ch3 is exception when RE_Not_Available => return; - end Freeze_Enumeration_Type; + end Expand_Freeze_Enumeration_Type; - ------------------------ - -- Freeze_Record_Type -- - ------------------------ + ------------------------------- + -- Expand_Freeze_Record_Type -- + ------------------------------- + + procedure Expand_Freeze_Record_Type (N : Node_Id) is + Def_Id : constant Node_Id := Entity (N); + Type_Decl : constant Node_Id := Parent (Def_Id); + Comp : Entity_Id; + Comp_Typ : Entity_Id; + Has_Static_DT : Boolean := False; + Predef_List : List_Id; - procedure Freeze_Record_Type (N : Node_Id) is - Comp : Entity_Id; - Def_Id : constant Node_Id := Entity (N); - Predef_List : List_Id; - Type_Decl : constant Node_Id := Parent (Def_Id); + Flist : Entity_Id := Empty; + -- Finalization list allocated for the case of a type with anonymous + -- access components whose designated type is potentially controlled. - Renamed_Eq : Node_Id := Empty; - -- Could use some comments ??? + Renamed_Eq : Node_Id := Empty; + -- Defining unit name for the predefined equality function in the case + -- where the type has a primitive operation that is a renaming of + -- predefined equality (but only if there is also an overriding + -- user-defined equality function). Used to pass this entity from + -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. + + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; + Null_Proc_Decl_List : List_Id := No_List; + + -- Start of processing for Expand_Freeze_Record_Type begin -- Build discriminant checking functions if not a derived type (for - -- derived types that are not tagged types, we always use the - -- discriminant checking functions of the parent type). However, for - -- untagged types the derivation may have taken place before the - -- parent was frozen, so we copy explicitly the discriminant checking - -- functions from the parent into the components of the derived type. + -- derived types that are not tagged types, always use the discriminant + -- checking functions of the parent type). However, for untagged types + -- the derivation may have taken place before the parent was frozen, so + -- we copy explicitly the discriminant checking functions from the + -- parent into the components of the derived type. if not Is_Derived_Type (Def_Id) or else Has_New_Non_Standard_Rep (Def_Id) @@ -4427,7 +5687,7 @@ package body Exp_Ch3 is and then Chars (Comp) = Chars (Old_Comp) then Set_Discriminant_Checking_Func (Comp, - Discriminant_Checking_Func (Old_Comp)); + Discriminant_Checking_Func (Old_Comp)); end if; Next_Component (Old_Comp); @@ -4450,70 +5710,104 @@ package body Exp_Ch3 is Comp := First_Component (Def_Id); while Present (Comp) loop - if Has_Task (Etype (Comp)) then + Comp_Typ := Etype (Comp); + + if Has_Task (Comp_Typ) then Set_Has_Task (Def_Id); - elsif Has_Controlled_Component (Etype (Comp)) - or else (Chars (Comp) /= Name_uParent - and then Is_Controlled (Etype (Comp))) + -- Do not set Has_Controlled_Component on a class-wide equivalent + -- type. See Make_CW_Equivalent_Type. + + elsif not Is_Class_Wide_Equivalent_Type (Def_Id) + and then (Has_Controlled_Component (Comp_Typ) + or else (Chars (Comp) /= Name_uParent + and then Is_Controlled (Comp_Typ))) then Set_Has_Controlled_Component (Def_Id); + + elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) + then + if No (Flist) then + Flist := Add_Final_Chain (Def_Id); + end if; + + Set_Associated_Final_Chain (Comp_Typ, Flist); end if; Next_Component (Comp); end loop; - -- Creation of the Dispatch Table. Note that a Dispatch Table is - -- created for regular tagged types as well as for Ada types deriving - -- from a C++ Class, but not for tagged types directly corresponding to - -- the C++ classes. In the later case we assume that the Vtable is - -- created in the C++ side and we just use it. + -- Handle constructors of non-tagged CPP_Class types + + if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then + Set_CPP_Constructors (Def_Id); + end if; + + -- Creation of the Dispatch Table. Note that a Dispatch Table is built + -- for regular tagged types as well as for Ada types deriving from a C++ + -- Class, but not for tagged types directly corresponding to C++ classes + -- In the later case we assume that it is created in the C++ side and we + -- just use it. if Is_Tagged_Type (Def_Id) then + Has_Static_DT := + Static_Dispatch_Tables + and then Is_Library_Level_Tagged_Type (Def_Id); + + -- Add the _Tag component + + if Underlying_Type (Etype (Def_Id)) = Def_Id then + Expand_Tagged_Root (Def_Id); + end if; if Is_CPP_Class (Def_Id) then Set_All_DT_Position (Def_Id); - Set_Default_Constructor (Def_Id); + Set_CPP_Constructors (Def_Id); + + -- Create the tag entities with a minimum decoration + + if Tagged_Type_Expansion then + Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); + end if; else - -- Usually inherited primitives are not delayed but the first Ada - -- extension of a CPP_Class is an exception since the address of - -- the inherited subprogram has to be inserted in the new Ada - -- Dispatch Table and this is a freezing action (usually the - -- inherited primitive address is inserted in the DT by - -- Inherit_DT) - - -- Similarly, if this is an inherited operation whose parent is - -- not frozen yet, it is not in the DT of the parent, and we - -- generate an explicit freeze node for the inherited operation, - -- so that it is properly inserted in the DT of the current type. + if not Has_Static_DT then - declare - Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id)); - Subp : Entity_Id; + -- Usually inherited primitives are not delayed but the first + -- Ada extension of a CPP_Class is an exception since the + -- address of the inherited subprogram has to be inserted in + -- the new Ada Dispatch Table and this is a freezing action. - begin - while Present (Elmt) loop - Subp := Node (Elmt); + -- Similarly, if this is an inherited operation whose parent is + -- not frozen yet, it is not in the DT of the parent, and we + -- generate an explicit freeze node for the inherited operation + -- so that it is properly inserted in the DT of the current + -- type. + + declare + Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id)); + Subp : Entity_Id; - if Present (Alias (Subp)) then - if Is_CPP_Class (Etype (Def_Id)) then - Set_Has_Delayed_Freeze (Subp); + begin + while Present (Elmt) loop + Subp := Node (Elmt); - elsif Has_Delayed_Freeze (Alias (Subp)) - and then not Is_Frozen (Alias (Subp)) - then - Set_Is_Frozen (Subp, False); - Set_Has_Delayed_Freeze (Subp); - end if; - end if; + if Present (Alias (Subp)) then + if Is_CPP_Class (Etype (Def_Id)) then + Set_Has_Delayed_Freeze (Subp); - Next_Elmt (Elmt); - end loop; - end; + elsif Has_Delayed_Freeze (Alias (Subp)) + and then not Is_Frozen (Alias (Subp)) + then + Set_Is_Frozen (Subp, False); + Set_Has_Delayed_Freeze (Subp); + end if; + end if; - if Underlying_Type (Etype (Def_Id)) = Def_Id then - Expand_Tagged_Root (Def_Id); + Next_Elmt (Elmt); + end loop; + end; end if; -- Unfreeze momentarily the type to add the predefined primitives @@ -4522,73 +5816,98 @@ package body Exp_Ch3 is -- must be before the freeze point). Set_Is_Frozen (Def_Id, False); - Make_Predefined_Primitive_Specs - (Def_Id, Predef_List, Renamed_Eq); - Insert_List_Before_And_Analyze (N, Predef_List); - Set_Is_Frozen (Def_Id, True); - Set_All_DT_Position (Def_Id); + -- Do not add the spec of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. - -- Add the controlled component before the freezing actions - -- referenced in those actions. + if Is_CPP_Class (Root_Type (Def_Id)) + and then Convention (Def_Id) = Convention_CPP + then + null; - if Has_New_Controlled_Component (Def_Id) then - Expand_Record_Controller (Def_Id); - end if; + -- Do not add the spec of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls - -- Suppress creation of a dispatch table when Java_VM because the - -- dispatching mechanism is handled internally by the JVM. + elsif not Restriction_Active (No_Dispatching_Calls) then + Make_Predefined_Primitive_Specs + (Def_Id, Predef_List, Renamed_Eq); + Insert_List_Before_And_Analyze (N, Predef_List); + end if; - if not Java_VM then + -- Ada 2005 (AI-391): For a nonabstract null extension, create + -- wrapper functions for each nonoverridden inherited function + -- with a controlling result of the type. The wrapper for such + -- a function returns an extension aggregate that invokes the + -- the parent function. - -- Ada 2005 (AI-251): Build the secondary dispatch tables + if Ada_Version >= Ada_05 + and then not Is_Abstract_Type (Def_Id) + and then Is_Null_Extension (Def_Id) + then + Make_Controlling_Function_Wrappers + (Def_Id, Wrapper_Decl_List, Wrapper_Body_List); + Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); + end if; - declare - ADT : Elist_Id := Access_Disp_Table (Def_Id); + -- Ada 2005 (AI-251): For a nonabstract type extension, build + -- null procedure declarations for each set of homographic null + -- procedures that are inherited from interface types but not + -- overridden. This is done to ensure that the dispatch table + -- entry associated with such null primitives are properly filled. - procedure Add_Secondary_Tables (Typ : Entity_Id); - -- Comment required ??? + if Ada_Version >= Ada_05 + and then Etype (Def_Id) /= Def_Id + and then not Is_Abstract_Type (Def_Id) + then + Make_Null_Procedure_Specs (Def_Id, Null_Proc_Decl_List); + Insert_Actions (N, Null_Proc_Decl_List); + end if; - -------------------------- - -- Add_Secondary_Tables -- - -------------------------- + Set_Is_Frozen (Def_Id); + Set_All_DT_Position (Def_Id); - procedure Add_Secondary_Tables (Typ : Entity_Id) is - E : Entity_Id; - Result : List_Id; + -- Add the controlled component before the freezing actions + -- referenced in those actions. - begin - if Etype (Typ) /= Typ then - Add_Secondary_Tables (Etype (Typ)); - end if; + if Has_New_Controlled_Component (Def_Id) then + Expand_Record_Controller (Def_Id); + end if; - if Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List - (Abstract_Interfaces (Typ)) - then - E := First_Entity (Typ); - while Present (E) loop - if Is_Tag (E) and then Chars (E) /= Name_uTag then - Make_Abstract_Interface_DT - (AI_Tag => E, - Acc_Disp_Tables => ADT, - Result => Result); - - Append_Freeze_Actions (Def_Id, Result); - end if; + -- Create and decorate the tags. Suppress their creation when + -- VM_Target because the dispatching mechanism is handled + -- internally by the VMs. - Next_Entity (E); - end loop; - end if; - end Add_Secondary_Tables; + if Tagged_Type_Expansion then + Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); - -- Start of processing to build secondary dispatch tables + -- Generate dispatch table of locally defined tagged type. + -- Dispatch tables of library level tagged types are built + -- later (see Analyze_Declarations). - begin - Add_Secondary_Tables (Def_Id); - Set_Access_Disp_Table (Def_Id, ADT); + if not Has_Static_DT then Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); - end; + end if; + end if; + + -- If the type has unknown discriminants, propagate dispatching + -- information to its underlying record view, which does not get + -- its own dispatch table. + + if Is_Derived_Type (Def_Id) + and then Has_Unknown_Discriminants (Def_Id) + and then Present (Underlying_Record_View (Def_Id)) + then + declare + Rep : constant Entity_Id := + Underlying_Record_View (Def_Id); + begin + Set_Access_Disp_Table + (Rep, Access_Disp_Table (Def_Id)); + Set_Dispatch_Table_Wrappers + (Rep, Dispatch_Table_Wrappers (Def_Id)); + Set_Primitive_Operations + (Rep, Primitive_Operations (Def_Id)); + end; end if; -- Make sure that the primitives Initialize, Adjust and Finalize @@ -4611,12 +5930,14 @@ package body Exp_Ch3 is (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id))); end if; - -- Freeze rest of primitive operations + -- Freeze rest of primitive operations. There is no need to handle + -- the predefined primitives if we are compiling under restriction + -- No_Dispatching_Calls - Append_Freeze_Actions - (Def_Id, Predefined_Primitive_Freeze (Def_Id)); - Append_Freeze_Actions - (Def_Id, Init_Predefined_Interface_Primitives (Def_Id)); + if not Restriction_Active (No_Dispatching_Calls) then + Append_Freeze_Actions + (Def_Id, Predefined_Primitive_Freeze (Def_Id)); + end if; end if; -- In the non-tagged case, an equality function is provided only for @@ -4681,30 +6002,73 @@ package body Exp_Ch3 is end if; Adjust_Discriminants (Def_Id); - Build_Record_Init_Proc (Type_Decl, Def_Id); - -- For tagged type, build bodies of primitive operations. Note that we - -- do this after building the record initialization experiment, since - -- the primitive operations may need the initialization routine + if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then - if Is_Tagged_Type (Def_Id) then - Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); - Append_Freeze_Actions (Def_Id, Predef_List); - - -- Populate the two auxiliary tables used for dispatching - -- asynchronous, conditional and timed selects for tagged - -- types that implement a limited interface. - - if Ada_Version >= Ada_05 - and then not Is_Interface (Def_Id) - and then not Is_Abstract (Def_Id) - and then not Is_Controlled (Def_Id) - and then Implements_Limited_Interface (Def_Id) + -- Do not need init for interfaces on e.g. CIL since they're + -- abstract. Helps operation of peverify (the PE Verify tool). + + Build_Record_Init_Proc (Type_Decl, Def_Id); + end if; + + -- For tagged type that are not interfaces, build bodies of primitive + -- operations. Note that we do this after building the record + -- initialization procedure, since the primitive operations may need + -- the initialization routine. There is no need to add predefined + -- primitives of interfaces because all their predefined primitives + -- are abstract. + + if Is_Tagged_Type (Def_Id) + and then not Is_Interface (Def_Id) + then + -- Do not add the body of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Def_Id)) + and then Convention (Def_Id) = Convention_CPP then - Append_Freeze_Actions (Def_Id, Make_Disp_Select_Tables (Def_Id)); + null; + + -- Do not add the body of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls or if we are + -- compiling a CPP tagged type. + + elsif not Restriction_Active (No_Dispatching_Calls) then + Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); + Append_Freeze_Actions (Def_Id, Predef_List); + end if; + + -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden + -- inherited functions, then add their bodies to the freeze actions. + + if Present (Wrapper_Body_List) then + Append_Freeze_Actions (Def_Id, Wrapper_Body_List); end if; + + -- Create extra formals for the primitive operations of the type. + -- This must be done before analyzing the body of the initialization + -- procedure, because a self-referential type might call one of these + -- primitives in the body of the init_proc itself. + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Def_Id)); + while Present (Elmt) loop + Subp := Node (Elmt); + if not Has_Foreign_Convention (Subp) + and then not Is_Predefined_Dispatching_Operation (Subp) + then + Create_Extra_Formals (Subp); + end if; + + Next_Elmt (Elmt); + end loop; + end; end if; - end Freeze_Record_Type; + end Expand_Freeze_Record_Type; ------------------------------ -- Freeze_Stream_Operations -- @@ -4768,6 +6132,7 @@ package body Exp_Ch3 is while Present (E) loop if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then + Validate_RACW_Primitives (Node (E)); RACW_Seen := True; end if; @@ -4787,7 +6152,7 @@ package body Exp_Ch3 is if Is_Record_Type (Def_Id) then if Ekind (Def_Id) = E_Record_Type then - Freeze_Record_Type (N); + Expand_Freeze_Record_Type (N); -- The subtype may have been declared before the type was frozen. If -- the type has controlled components it is necessary to create the @@ -4813,7 +6178,7 @@ package body Exp_Ch3 is New_C := New_Copy (Old_C); Set_Parent (New_C, Parent (Old_C)); - New_Scope (Def_Id); + Push_Scope (Def_Id); Enter_Name (New_C); End_Scope; end if; @@ -4824,7 +6189,7 @@ package body Exp_Ch3 is then -- The freeze node is only used to introduce the controller, -- the back-end has no use for it for a discriminated - -- component. + -- component. Set_Freeze_Node (Def_Id, Empty); Set_Has_Delayed_Freeze (Def_Id, False); @@ -4862,7 +6227,7 @@ package body Exp_Ch3 is -- Freeze processing for array types elsif Is_Array_Type (Def_Id) then - Freeze_Array_Type (N); + Expand_Freeze_Array_Type (N); -- Freeze processing for access types @@ -4887,28 +6252,18 @@ package body Exp_Ch3 is then declare Loc : constant Source_Ptr := Sloc (N); - Desig_Type : constant Entity_Id := Designated_Type (Def_Id); + Desig_Type : constant Entity_Id := Designated_Type (Def_Id); Pool_Object : Entity_Id; - Siz_Exp : Node_Id; Freeze_Action_Typ : Entity_Id; begin - if Has_Storage_Size_Clause (Def_Id) then - Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id))); - else - Siz_Exp := Empty; - end if; - -- Case 1 -- Rep Clause "for Def_Id'Storage_Size use 0;" -- ---> don't use any storage pool - if Has_Storage_Size_Clause (Def_Id) - and then Compile_Time_Known_Value (Siz_Exp) - and then Expr_Value (Siz_Exp) = 0 - then + if No_Pool_Assigned (Def_Id) then null; -- Case 2 @@ -4954,12 +6309,12 @@ package body Exp_Ch3 is Chars => New_External_Name (Chars (Def_Id), 'P')); -- We put the code associated with the pools in the entity - -- that has the later freeze node, usually the acces type + -- that has the later freeze node, usually the access type -- but it can also be the designated_type; because the pool -- code requires both those types to be frozen if Is_Frozen (Desig_Type) - and then (not Present (Freeze_Node (Desig_Type)) + and then (No (Freeze_Node (Desig_Type)) or else Analyzed (Freeze_Node (Desig_Type))) then Freeze_Action_Typ := Def_Id; @@ -5035,8 +6390,9 @@ package body Exp_Ch3 is then null; - elsif (Controlled_Type (Desig_Type) - and then Convention (Desig_Type) /= Convention_Java) + elsif (Needs_Finalization (Desig_Type) + and then Convention (Desig_Type) /= Convention_Java + and then Convention (Desig_Type) /= Convention_CIL) or else (Is_Incomplete_Or_Private_Type (Desig_Type) and then No (Full_View (Desig_Type)) @@ -5058,17 +6414,14 @@ package body Exp_Ch3 is or else (Is_Array_Type (Desig_Type) and then not Is_Frozen (Desig_Type) - and then Controlled_Type (Component_Type (Desig_Type))) + and then Needs_Finalization (Component_Type (Desig_Type))) + + -- The designated type has controlled anonymous access + -- discriminants. + + or else Has_Controlled_Coextensions (Desig_Type) then - Set_Associated_Final_Chain (Def_Id, - Make_Defining_Identifier (Loc, - New_External_Name (Chars (Def_Id), 'L'))); - - Append_Freeze_Action (Def_Id, - Make_Object_Declaration (Loc, - Defining_Identifier => Associated_Final_Chain (Def_Id), - Object_Definition => - New_Reference_To (RTE (RE_List_Controller), Loc))); + Set_Associated_Final_Chain (Def_Id, Add_Final_Chain (Def_Id)); end if; end; @@ -5081,7 +6434,7 @@ package body Exp_Ch3 is -- is not the same as its representation) if Has_Non_Standard_Rep (Def_Id) then - Freeze_Enumeration_Type (N); + Expand_Freeze_Enumeration_Type (N); end if; -- Private types that are completed by a derivation from a private @@ -5121,9 +6474,10 @@ package body Exp_Ch3 is function Get_Simple_Init_Val (T : Entity_Id; - Loc : Source_Ptr; + N : Node_Id; Size : Uint := No_Uint) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); Val : Node_Id; Result : Node_Id; Val_RE : RE_Id; @@ -5132,6 +6486,10 @@ package body Exp_Ch3 is -- This is the size to be used for computation of the appropriate -- initial value for the Normalize_Scalars and Initialize_Scalars case. + IV_Attribute : constant Boolean := + Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Invalid_Value; + Lo_Bound : Uint; Hi_Bound : Uint; -- These are the values computed by the procedure Check_Subtype_Bounds @@ -5208,16 +6566,14 @@ package body Exp_Ch3 is -- an Unchecked_Convert to the private type. if Is_Private_Type (T) then - Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size); + Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size); -- A special case, if the underlying value is null, then qualify it -- with the underlying type, so that the null is properly typed -- Similarly, if it is an aggregate it must be qualified, because an -- unchecked conversion does not provide a context for it. - if Nkind (Val) = N_Null - or else Nkind (Val) = N_Aggregate - then + if Nkind_In (Val, N_Null, N_Aggregate) then Val := Make_Qualified_Expression (Loc, Subtype_Mark => @@ -5237,10 +6593,11 @@ package body Exp_Ch3 is return Result; - -- For scalars, we must have normalize/initialize scalars case + -- For scalars, we must have normalize/initialize scalars case, or + -- if the node N is an 'Invalid_Value attribute node. elsif Is_Scalar_Type (T) then - pragma Assert (Init_Or_Norm_Scalars); + pragma Assert (Init_Or_Norm_Scalars or IV_Attribute); -- Compute size of object. If it is given by the caller, we can use -- it directly, otherwise we use Esize (T) as an estimate. As far as @@ -5265,7 +6622,7 @@ package body Exp_Ch3 is -- Processing for Normalize_Scalars case - if Normalize_Scalars then + if Normalize_Scalars and then not IV_Attribute then -- If zero is invalid, it is a convenient value to use that is -- for sure an appropriate invalid value in all situations. @@ -5281,7 +6638,7 @@ package body Exp_Ch3 is -- For signed integer types that have no negative values, either -- there is room for negative values, or there is not. If there - -- is, then all 1 bits may be interpretecd as minus one, which is + -- is, then all 1 bits may be interpreted as minus one, which is -- certainly invalid. Alternatively it is treated as the largest -- positive value, in which case the observation for modular types -- still applies. @@ -5329,7 +6686,7 @@ package body Exp_Ch3 is end; end if; - -- Here for Initialize_Scalars case + -- Here for Initialize_Scalars case (or Invalid_Value attribute used) else -- For float types, use float values from System.Scalar_Values @@ -5424,7 +6781,7 @@ package body Exp_Ch3 is Make_Others_Choice (Loc)), Expression => Get_Simple_Init_Val - (Component_Type (T), Loc, Esize (Root_Type (T)))))); + (Component_Type (T), N, Esize (Root_Type (T)))))); -- Access type is initialized to null @@ -5475,9 +6832,10 @@ package body Exp_Ch3 is ---------------- function In_Runtime (E : Entity_Id) return Boolean is - S1 : Entity_Id := Scope (E); + S1 : Entity_Id; begin + S1 := Scope (E); while Scope (S1) /= Standard_Standard loop S1 := Scope (S1); end loop; @@ -5485,6 +6843,66 @@ package body Exp_Ch3 is return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; end In_Runtime; + ---------------------------- + -- Initialization_Warning -- + ---------------------------- + + procedure Initialization_Warning (E : Entity_Id) is + Warning_Needed : Boolean; + + begin + Warning_Needed := False; + + if Ekind (Current_Scope) = E_Package + and then Static_Elaboration_Desired (Current_Scope) + then + if Is_Type (E) then + if Is_Record_Type (E) then + if Has_Discriminants (E) + or else Is_Limited_Type (E) + or else Has_Non_Standard_Rep (E) + then + Warning_Needed := True; + + else + -- Verify that at least one component has an initialization + -- expression. No need for a warning on a type if all its + -- components have no initialization. + + declare + Comp : Entity_Id; + + begin + Comp := First_Component (E); + while Present (Comp) loop + if Ekind (Comp) = E_Discriminant + or else + (Nkind (Parent (Comp)) = N_Component_Declaration + and then Present (Expression (Parent (Comp)))) + then + Warning_Needed := True; + exit; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + + if Warning_Needed then + Error_Msg_N + ("Objects of the type cannot be initialized " & + "statically by default?", + Parent (E)); + end if; + end if; + + else + Error_Msg_N ("Object cannot be initialized statically?", E); + end if; + end if; + end Initialization_Warning; + ------------------ -- Init_Formals -- ------------------ @@ -5545,11 +6963,560 @@ package body Exp_Ch3 is return Empty_List; end Init_Formals; + ------------------------- + -- Init_Secondary_Tags -- + ------------------------- + + procedure Init_Secondary_Tags + (Typ : Entity_Id; + Target : Node_Id; + Stmts_List : List_Id; + Fixed_Comps : Boolean := True; + Variable_Comps : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (Target); + + procedure Inherit_CPP_Tag + (Typ : Entity_Id; + Iface : Entity_Id; + Tag_Comp : Entity_Id; + Iface_Tag : Node_Id); + -- Inherit the C++ tag of the secondary dispatch table of Typ associated + -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. + + procedure Initialize_Tag + (Typ : Entity_Id; + Iface : Entity_Id; + Tag_Comp : Entity_Id; + Iface_Tag : Node_Id); + -- Initialize the tag of the secondary dispatch table of Typ associated + -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. + -- Compiling under the CPP full ABI compatibility mode, if the ancestor + -- of Typ CPP tagged type we generate code to inherit the contents of + -- the dispatch table directly from the ancestor. + + --------------------- + -- Inherit_CPP_Tag -- + --------------------- + + procedure Inherit_CPP_Tag + (Typ : Entity_Id; + Iface : Entity_Id; + Tag_Comp : Entity_Id; + Iface_Tag : Node_Id) + is + begin + pragma Assert (Is_CPP_Class (Etype (Typ))); + + Append_To (Stmts_List, + Build_Inherit_Prims (Loc, + Typ => Iface, + Old_Tag_Node => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Reference_To (Tag_Comp, Loc)), + New_Tag_Node => + New_Reference_To (Iface_Tag, Loc), + Num_Prims => + UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface))))); + end Inherit_CPP_Tag; + + -------------------- + -- Initialize_Tag -- + -------------------- + + procedure Initialize_Tag + (Typ : Entity_Id; + Iface : Entity_Id; + Tag_Comp : Entity_Id; + Iface_Tag : Node_Id) + is + Comp_Typ : Entity_Id; + Offset_To_Top_Comp : Entity_Id := Empty; + + begin + -- Initialize the pointer to the secondary DT associated with the + -- interface. + + if not Is_Ancestor (Iface, Typ) then + Append_To (Stmts_List, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Reference_To (Tag_Comp, Loc)), + Expression => + New_Reference_To (Iface_Tag, Loc))); + end if; + + Comp_Typ := Scope (Tag_Comp); + + -- Initialize the entries of the table of interfaces. We generate a + -- different call when the parent of the type has variable size + -- components. + + if Comp_Typ /= Etype (Comp_Typ) + and then Is_Variable_Size_Record (Etype (Comp_Typ)) + and then Chars (Tag_Comp) /= Name_uTag + then + pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp))); + + -- Issue error if Set_Dynamic_Offset_To_Top is not available in a + -- configurable run-time environment. + + if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then + Error_Msg_CRT + ("variable size record with interface types", Typ); + return; + end if; + + -- Generate: + -- Set_Dynamic_Offset_To_Top + -- (This => Init, + -- Interface_T => Iface'Tag, + -- Offset_Value => n, + -- Offset_Func => Fn'Address) + + Append_To (Stmts_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Target), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Iface))), + Loc)), + + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)), + + Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To + (DT_Offset_To_Top_Func (Tag_Comp), Loc), + Attribute_Name => Name_Address))))); + + -- In this case the next component stores the value of the + -- offset to the top. + + Offset_To_Top_Comp := Next_Entity (Tag_Comp); + pragma Assert (Present (Offset_To_Top_Comp)); + + Append_To (Stmts_List, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Reference_To + (Offset_To_Top_Comp, Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position))); + + -- Normal case: No discriminants in the parent type + + else + -- Don't need to set any value if this interface shares + -- the primary dispatch table. + + if not Is_Ancestor (Iface, Typ) then + Append_To (Stmts_List, + Build_Set_Static_Offset_To_Top (Loc, + Iface_Tag => New_Reference_To (Iface_Tag, Loc), + Offset_Value => + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)))); + end if; + + -- Generate: + -- Register_Interface_Offset + -- (This => Init, + -- Interface_T => Iface'Tag, + -- Is_Constant => True, + -- Offset_Value => n, + -- Offset_Func => null); + + if RTE_Available (RE_Register_Interface_Offset) then + Append_To (Stmts_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Register_Interface_Offset), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Target), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)), + + New_Occurrence_Of (Standard_True, Loc), + + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)), + + Make_Null (Loc)))); + end if; + end if; + end Initialize_Tag; + + -- Local variables + + Full_Typ : Entity_Id; + Ifaces_List : Elist_Id; + Ifaces_Comp_List : Elist_Id; + Ifaces_Tag_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface_Comp_Elmt : Elmt_Id; + Iface_Tag_Elmt : Elmt_Id; + Tag_Comp : Node_Id; + In_Variable_Pos : Boolean; + + -- Start of processing for Init_Secondary_Tags + + begin + -- Handle private types + + if Present (Full_View (Typ)) then + Full_Typ := Full_View (Typ); + else + Full_Typ := Typ; + end if; + + Collect_Interfaces_Info + (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); + Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List); + while Present (Iface_Elmt) loop + Tag_Comp := Node (Iface_Comp_Elmt); + + -- If we are compiling under the CPP full ABI compatibility mode and + -- the ancestor is a CPP_Pragma tagged type then we generate code to + -- inherit the contents of the dispatch table directly from the + -- ancestor. + + if Is_CPP_Class (Etype (Full_Typ)) then + Inherit_CPP_Tag (Full_Typ, + Iface => Node (Iface_Elmt), + Tag_Comp => Tag_Comp, + Iface_Tag => Node (Iface_Tag_Elmt)); + + -- Otherwise generate code to initialize the tag + + else + -- Check if the parent of the record type has variable size + -- components. + + In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp)) + and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp))); + + if (In_Variable_Pos and then Variable_Comps) + or else (not In_Variable_Pos and then Fixed_Comps) + then + Initialize_Tag (Full_Typ, + Iface => Node (Iface_Elmt), + Tag_Comp => Tag_Comp, + Iface_Tag => Node (Iface_Tag_Elmt)); + end if; + end if; + + Next_Elmt (Iface_Elmt); + Next_Elmt (Iface_Comp_Elmt); + Next_Elmt (Iface_Tag_Elmt); + end loop; + end Init_Secondary_Tags; + + ----------------------------- + -- Is_Variable_Size_Record -- + ----------------------------- + + function Is_Variable_Size_Record (E : Entity_Id) return Boolean is + Comp : Entity_Id; + Comp_Typ : Entity_Id; + Idx : Node_Id; + + function Is_Constant_Bound (Exp : Node_Id) return Boolean; + -- To simplify handling of array components. Determines whether the + -- given bound is constant (a constant or enumeration literal, or an + -- integer literal) as opposed to per-object, through an expression + -- or a discriminant. + + ----------------------- + -- Is_Constant_Bound -- + ----------------------- + + function Is_Constant_Bound (Exp : Node_Id) return Boolean is + begin + if Nkind (Exp) = N_Integer_Literal then + return True; + else + return + Is_Entity_Name (Exp) + and then Present (Entity (Exp)) + and then + (Ekind (Entity (Exp)) = E_Constant + or else Ekind (Entity (Exp)) = E_Enumeration_Literal); + end if; + end Is_Constant_Bound; + + -- Start of processing for Is_Variable_Sized_Record + + begin + pragma Assert (Is_Record_Type (E)); + + Comp := First_Entity (E); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + if Is_Record_Type (Comp_Typ) then + + -- Recursive call if the record type has discriminants + + if Has_Discriminants (Comp_Typ) + and then Is_Variable_Size_Record (Comp_Typ) + then + return True; + end if; + + elsif Is_Array_Type (Comp_Typ) then + + -- Check if some index is initialized with a non-constant value + + Idx := First_Index (Comp_Typ); + while Present (Idx) loop + if Nkind (Idx) = N_Range then + if not Is_Constant_Bound (Low_Bound (Idx)) + or else + not Is_Constant_Bound (High_Bound (Idx)) + then + return True; + end if; + end if; + + Idx := Next_Index (Idx); + end loop; + end if; + + Next_Entity (Comp); + end loop; + + return False; + end Is_Variable_Size_Record; + + ---------------------------------------- + -- Make_Controlling_Function_Wrappers -- + ---------------------------------------- + + procedure Make_Controlling_Function_Wrappers + (Tag_Typ : Entity_Id; + Decl_List : out List_Id; + Body_List : out List_Id) + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + Actual_List : List_Id; + Formal_List : List_Id; + Formal : Entity_Id; + Par_Formal : Entity_Id; + Formal_Node : Node_Id; + Func_Body : Node_Id; + Func_Decl : Node_Id; + Func_Spec : Node_Id; + Return_Stmt : Node_Id; + + begin + Decl_List := New_List; + Body_List := New_List; + + Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + + while Present (Prim_Elmt) loop + Subp := Node (Prim_Elmt); + + -- If a primitive function with a controlling result of the type has + -- not been overridden by the user, then we must create a wrapper + -- function here that effectively overrides it and invokes the + -- (non-abstract) parent function. This can only occur for a null + -- extension. Note that functions with anonymous controlling access + -- results don't qualify and must be overridden. We also exclude + -- Input attributes, since each type will have its own version of + -- Input constructed by the expander. The test for Comes_From_Source + -- is needed to distinguish inherited operations from renamings + -- (which also have Alias set). + + -- The function may be abstract, or require_Overriding may be set + -- for it, because tests for null extensions may already have reset + -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not + -- set, functions that need wrappers are recognized by having an + -- alias that returns the parent type. + + if Comes_From_Source (Subp) + or else No (Alias (Subp)) + or else Ekind (Subp) /= E_Function + or else not Has_Controlling_Result (Subp) + or else Is_Access_Type (Etype (Subp)) + or else Is_Abstract_Subprogram (Alias (Subp)) + or else Is_TSS (Subp, TSS_Stream_Input) + then + goto Next_Prim; + + elsif Is_Abstract_Subprogram (Subp) + or else Requires_Overriding (Subp) + or else + (Is_Null_Extension (Etype (Subp)) + and then Etype (Alias (Subp)) /= Etype (Subp)) + then + Formal_List := No_List; + Formal := First_Formal (Subp); + + if Present (Formal) then + Formal_List := New_List; + + while Present (Formal) loop + Append + (Make_Parameter_Specification + (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Null_Exclusion_Present => + Null_Exclusion_Present (Parent (Formal)), + Parameter_Type => + New_Reference_To (Etype (Formal), Loc), + Expression => + New_Copy_Tree (Expression (Parent (Formal)))), + Formal_List); + + Next_Formal (Formal); + end loop; + end if; + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Chars (Subp)), + Parameter_Specifications => Formal_List, + Result_Definition => + New_Reference_To (Etype (Subp), Loc)); + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Append_To (Decl_List, Func_Decl); + + -- Build a wrapper body that calls the parent function. The body + -- contains a single return statement that returns an extension + -- aggregate whose ancestor part is a call to the parent function, + -- passing the formals as actuals (with any controlling arguments + -- converted to the types of the corresponding formals of the + -- parent function, which might be anonymous access types), and + -- having a null extension. + + Formal := First_Formal (Subp); + Par_Formal := First_Formal (Alias (Subp)); + Formal_Node := First (Formal_List); + + if Present (Formal) then + Actual_List := New_List; + else + Actual_List := No_List; + end if; + + while Present (Formal) loop + if Is_Controlling_Formal (Formal) then + Append_To (Actual_List, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Par_Formal), Loc), + Expression => + New_Reference_To + (Defining_Identifier (Formal_Node), Loc))); + else + Append_To + (Actual_List, + New_Reference_To + (Defining_Identifier (Formal_Node), Loc)); + end if; + + Next_Formal (Formal); + Next_Formal (Par_Formal); + Next (Formal_Node); + end loop; + + Return_Stmt := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Extension_Aggregate (Loc, + Ancestor_Part => + Make_Function_Call (Loc, + Name => New_Reference_To (Alias (Subp), Loc), + Parameter_Associations => Actual_List), + Null_Record_Present => True)); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => New_Copy_Tree (Func_Spec), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Return_Stmt))); + + Set_Defining_Unit_Name + (Specification (Func_Body), + Make_Defining_Identifier (Loc, Chars (Subp))); + + Append_To (Body_List, Func_Body); + + -- Replace the inherited function with the wrapper function + -- in the primitive operations list. + + Override_Dispatching_Operation + (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec)); + end if; + + <> + Next_Elmt (Prim_Elmt); + end loop; + end Make_Controlling_Function_Wrappers; + ------------------ -- Make_Eq_Case -- ------------------ - -- + -- -- case X.D1 is -- when V1 => on subcomponents -- ... @@ -5649,13 +7616,18 @@ package body Exp_Ch3 is while Present (C) loop Field_Name := Chars (Defining_Identifier (C)); - -- The tags must not be compared they are not part of the value. + -- The tags must not be compared: they are not part of the value. + -- Ditto for the controller component, if present. + -- Note also that in the following, we use Make_Identifier for -- the component names. Use of New_Reference_To to identify the -- components would be incorrect because the wrong entities for -- discriminants could be picked up in the private type case. - if Field_Name /= Name_uTag then + if Field_Name /= Name_uTag + and then + Field_Name /= Name_uController + then Evolve_Or_Else (Cond, Make_Op_Ne (Loc, Left_Opnd => @@ -5682,12 +7654,124 @@ package body Exp_Ch3 is Make_Implicit_If_Statement (E, Condition => Cond, Then_Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc)))); end if; end if; end Make_Eq_If; + ------------------------------- + -- Make_Null_Procedure_Specs -- + ------------------------------- + + procedure Make_Null_Procedure_Specs + (Tag_Typ : Entity_Id; + Decl_List : out List_Id) + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + + Formal : Entity_Id; + Formal_List : List_Id; + New_Param_Spec : Node_Id; + Parent_Subp : Entity_Id; + Prim_Elmt : Elmt_Id; + Proc_Decl : Node_Id; + Subp : Entity_Id; + + function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean; + -- Returns True if E is a null procedure that is an interface primitive + + --------------------------------- + -- Is_Null_Interface_Primitive -- + --------------------------------- + + function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is + begin + return Comes_From_Source (E) + and then Is_Dispatching_Operation (E) + and then Ekind (E) = E_Procedure + and then Null_Present (Parent (E)) + and then Is_Interface (Find_Dispatching_Type (E)); + end Is_Null_Interface_Primitive; + + -- Start of processing for Make_Null_Procedure_Specs + + begin + Decl_List := New_List; + Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim_Elmt) loop + Subp := Node (Prim_Elmt); + + -- If a null procedure inherited from an interface has not been + -- overridden, then we build a null procedure declaration to + -- override the inherited procedure. + + Parent_Subp := Alias (Subp); + + if Present (Parent_Subp) + and then Is_Null_Interface_Primitive (Parent_Subp) + then + Formal_List := No_List; + Formal := First_Formal (Subp); + + if Present (Formal) then + Formal_List := New_List; + + while Present (Formal) loop + + -- Copy the parameter spec including default expressions + + New_Param_Spec := + New_Copy_Tree (Parent (Formal), New_Sloc => Loc); + + -- Generate a new defining identifier for the new formal. + -- required because New_Copy_Tree does not duplicate + -- semantic fields (except itypes). + + Set_Defining_Identifier (New_Param_Spec, + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal))); + + -- For controlling arguments we must change their + -- parameter type to reference the tagged type (instead + -- of the interface type) + + if Is_Controlling_Formal (Formal) then + if Nkind (Parameter_Type (Parent (Formal))) + = N_Identifier + then + Set_Parameter_Type (New_Param_Spec, + New_Occurrence_Of (Tag_Typ, Loc)); + + else pragma Assert + (Nkind (Parameter_Type (Parent (Formal))) + = N_Access_Definition); + Set_Subtype_Mark (Parameter_Type (New_Param_Spec), + New_Occurrence_Of (Tag_Typ, Loc)); + end if; + end if; + + Append (New_Param_Spec, Formal_List); + + Next_Formal (Formal); + end loop; + end if; + + Proc_Decl := + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Subp)), + Parameter_Specifications => Formal_List, + Null_Present => True)); + Append_To (Decl_List, Proc_Decl); + Analyze (Proc_Decl); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end Make_Null_Procedure_Specs; + ------------------------------------- -- Make_Predefined_Primitive_Specs -- ------------------------------------- @@ -5695,7 +7779,7 @@ package body Exp_Ch3 is procedure Make_Predefined_Primitive_Specs (Tag_Typ : Entity_Id; Predef_List : out List_Id; - Renamed_Eq : out Node_Id) + Renamed_Eq : out Entity_Id) is Loc : constant Source_Ptr := Sloc (Tag_Typ); Res : constant List_Id := New_List; @@ -5759,23 +7843,23 @@ package body Exp_Ch3 is TSS_Stream_Write, TSS_Stream_Input, TSS_Stream_Output); + begin for Op in Stream_Op_TSS_Names'Range loop if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then Append_To (Res, - Predef_Stream_Attr_Spec (Loc, Tag_Typ, - Stream_Op_TSS_Names (Op))); + Predef_Stream_Attr_Spec (Loc, Tag_Typ, + Stream_Op_TSS_Names (Op))); end if; end loop; end; - -- Spec of "=" if expanded if the type is not limited and if a + -- Spec of "=" is expanded if the type is not limited and if a -- user defined "=" was not already declared for the non-full -- view of a private extension if not Is_Limited_Type (Tag_Typ) then Eq_Needed := True; - Prim := First_Elmt (Primitive_Operations (Tag_Typ)); while Present (Prim) loop @@ -5791,39 +7875,56 @@ package body Exp_Ch3 is if Is_Predefined_Eq_Renaming (Node (Prim)) then Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); + -- User-defined equality + elsif Chars (Node (Prim)) = Name_Op_Eq - and then (No (Alias (Node (Prim))) - or else Nkind (Unit_Declaration_Node (Node (Prim))) = - N_Subprogram_Renaming_Declaration) and then Etype (First_Formal (Node (Prim))) = Etype (Next_Formal (First_Formal (Node (Prim)))) and then Base_Type (Etype (Node (Prim))) = Standard_Boolean - then - Eq_Needed := False; - exit; + if No (Alias (Node (Prim))) + or else Nkind (Unit_Declaration_Node (Node (Prim))) = + N_Subprogram_Renaming_Declaration + then + Eq_Needed := False; + exit; - -- If the parent equality is abstract, the inherited equality is - -- abstract as well, and no body can be created for for it. + -- If the parent is not an interface type and has an abstract + -- equality function, the inherited equality is abstract as + -- well, and no body can be created for it. - elsif Chars (Node (Prim)) = Name_Op_Eq - and then Present (Alias (Node (Prim))) - and then Is_Abstract (Alias (Node (Prim))) - then - Eq_Needed := False; - exit; + elsif not Is_Interface (Etype (Tag_Typ)) + and then Present (Alias (Node (Prim))) + and then Is_Abstract_Subprogram (Alias (Node (Prim))) + then + Eq_Needed := False; + exit; + + -- If the type has an equality function corresponding with + -- a primitive defined in an interface type, the inherited + -- equality is abstract as well, and no body can be created + -- for it. + + elsif Present (Alias (Node (Prim))) + and then Comes_From_Source (Ultimate_Alias (Node (Prim))) + and then + Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Node (Prim)))) + then + Eq_Needed := False; + exit; + end if; end if; Next_Elmt (Prim); end loop; - -- If a renaming of predefined equality was found - -- but there was no user-defined equality (so Eq_Needed - -- is still true), then set the name back to Name_Op_Eq. - -- But in the case where a user-defined equality was - -- located after such a renaming, then the predefined - -- equality function is still needed, so Eq_Needed must - -- be set back to True. + -- If a renaming of predefined equality was found but there was no + -- user-defined equality (so Eq_Needed is still true), then set the + -- name back to Name_Op_Eq. But in the case where a user-defined + -- equality was located after such a renaming, then the predefined + -- equality function is still needed, so Eq_Needed must be set back + -- to True. if Eq_Name /= Name_Op_Eq then if Eq_Needed then @@ -5856,10 +7957,10 @@ package body Exp_Ch3 is while Present (Prim) loop -- Any renamings of equality that appeared before an - -- overriding equality must be updated to refer to - -- the entity for the predefined equality, otherwise - -- calls via the renaming would get incorrectly - -- resolved to call the user-defined equality function. + -- overriding equality must be updated to refer to the + -- entity for the predefined equality, otherwise calls via + -- the renaming would get incorrectly resolved to call the + -- user-defined equality function. if Is_Predefined_Eq_Renaming (Node (Prim)) then Set_Alias (Node (Prim), Renamed_Eq); @@ -5893,24 +7994,32 @@ package body Exp_Ch3 is Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); end if; - -- Generate the declarations for the following primitive operations: - -- disp_asynchronous_select - -- disp_conditional_select - -- disp_get_prim_op_kind - -- disp_timed_select - -- for limited interfaces and tagged types that implement a limited - -- interface. + -- Ada 2005: Generate declarations for the following primitive + -- operations for limited interfaces and synchronized types that + -- implement a limited interface. + + -- Disp_Asynchronous_Select + -- Disp_Conditional_Select + -- Disp_Get_Prim_Op_Kind + -- Disp_Get_Task_Id + -- Disp_Requeue + -- Disp_Timed_Select + + -- These operations cannot be implemented on VM targets, so we simply + -- disable their generation in this case. Disable the generation of + -- these bodies if No_Dispatching_Calls, Ravenscar or ZFP is active. if Ada_Version >= Ada_05 - and then - ((Is_Interface (Tag_Typ) - and then Is_Limited_Record (Tag_Typ)) - or else - (not Is_Abstract (Tag_Typ) - and then not Is_Controlled (Tag_Typ) - and then Implements_Limited_Interface (Tag_Typ))) + and then Tagged_Type_Expansion + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) + and then RTE_Available (RE_Select_Specific_Data) then - if Is_Interface (Tag_Typ) then + -- These primitives are defined abstract in interface types + + if Is_Interface (Tag_Typ) + and then Is_Limited_Record (Tag_Typ) + then Append_To (Res, Make_Abstract_Subprogram_Declaration (Loc, Specification => @@ -5929,9 +8038,29 @@ package body Exp_Ch3 is Append_To (Res, Make_Abstract_Subprogram_Declaration (Loc, Specification => + Make_Disp_Get_Task_Id_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Requeue_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => Make_Disp_Timed_Select_Spec (Tag_Typ))); - else + -- If the ancestor is an interface type we declare non-abstract + -- primitives to override the abstract primitives of the interface + -- type. + + elsif (not Is_Interface (Tag_Typ) + and then Is_Interface (Etype (Tag_Typ)) + and then Is_Limited_Record (Etype (Tag_Typ))) + or else + (Is_Concurrent_Record_Type (Tag_Typ) + and then Has_Interfaces (Tag_Typ)) + then Append_To (Res, Make_Subprogram_Declaration (Loc, Specification => @@ -5950,17 +8079,26 @@ package body Exp_Ch3 is Append_To (Res, Make_Subprogram_Declaration (Loc, Specification => + Make_Disp_Get_Task_Id_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Requeue_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => Make_Disp_Timed_Select_Spec (Tag_Typ))); end if; end if; - -- Specs for finalization actions that may be required in case a - -- future extension contain a controlled element. We generate those - -- only for root tagged types where they will get dummy bodies or - -- when the type has controlled components and their body must be - -- generated. It is also impossible to provide those for tagged - -- types defined within s-finimp since it would involve circularity - -- problems + -- Specs for finalization actions that may be required in case a future + -- extension contain a controlled element. We generate those only for + -- root tagged types where they will get dummy bodies or when the type + -- has controlled components and their body must be generated. It is + -- also impossible to provide those for tagged types defined within + -- s-finimp since it would involve circularity problems if In_Finalization_Root (Tag_Typ) then null; @@ -5970,7 +8108,28 @@ package body Exp_Ch3 is elsif Restriction_Active (No_Finalization) then null; - elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then + -- Skip these for CIL Value types, where finalization is not available + + elsif Is_Value_Type (Tag_Typ) then + null; + + elsif Etype (Tag_Typ) = Tag_Typ + or else Needs_Finalization (Tag_Typ) + + -- Ada 2005 (AI-251): We must also generate these subprograms if + -- the immediate ancestor is an interface to ensure the correct + -- initialization of its dispatch table. + + or else (not Is_Interface (Tag_Typ) + and then Is_Interface (Etype (Tag_Typ))) + + -- Ada 205 (AI-251): We must also generate these subprograms if + -- the parent of an nonlimited interface is a limited interface + + or else (Is_Interface (Tag_Typ) + and then not Is_Limited_Interface (Tag_Typ) + and then Is_Limited_Interface (Etype (Tag_Typ))) + then if not Is_Limited_Type (Tag_Typ) then Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); @@ -5988,8 +8147,8 @@ package body Exp_Ch3 is function Needs_Simple_Initialization (T : Entity_Id) return Boolean is begin - -- Check for private type, in which case test applies to the - -- underlying type of the private type. + -- Check for private type, in which case test applies to the underlying + -- type of the private type. if Is_Private_Type (T) then declare @@ -6103,12 +8262,11 @@ package body Exp_Ch3 is begin Set_Is_Public (Id, Is_Public (Tag_Typ)); - -- The internal flag is set to mark these declarations because - -- they have specific properties. First they are primitives even - -- if they are not defined in the type scope (the freezing point - -- is not necessarily in the same scope), furthermore the - -- predefined equality can be overridden by a user-defined - -- equality, no body will be generated in this case. + -- The internal flag is set to mark these declarations because they have + -- specific properties. First, they are primitives even if they are not + -- defined in the type scope (the freezing point is not necessarily in + -- the same scope). Second, the predefined equality can be overridden by + -- a user-defined equality, no body will be generated in this case. Set_Is_Internal (Id); @@ -6130,23 +8288,24 @@ package body Exp_Ch3 is New_Reference_To (Ret_Type, Loc)); end if; - -- If body case, return empty subprogram body. Note that this is - -- ill-formed, because there is not even a null statement, and - -- certainly not a return in the function case. The caller is - -- expected to do surgery on the body to add the appropriate stuff. + if Is_Interface (Tag_Typ) then + return Make_Abstract_Subprogram_Declaration (Loc, Spec); + + -- If body case, return empty subprogram body. Note that this is ill- + -- formed, because there is not even a null statement, and certainly not + -- a return in the function case. The caller is expected to do surgery + -- on the body to add the appropriate stuff. - if For_Body then + elsif For_Body then return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); - -- For the case of Input/Output attributes applied to an abstract type, - -- generate abstract specifications. These will never be called, - -- but we need the slots allocated in the dispatching table so - -- that typ'Class'Input and typ'Class'Output will work properly. + -- For the case of an Input attribute predefined for an abstract type, + -- generate an abstract specification. This will never be called, but we + -- need the slot allocated in the dispatching table so that attributes + -- typ'Class'Input and typ'Class'Output will work properly. - elsif (Is_TSS (Name, TSS_Stream_Input) - or else - Is_TSS (Name, TSS_Stream_Output)) - and then Is_Abstract (Tag_Typ) + elsif Is_TSS (Name, TSS_Stream_Input) + and then Is_Abstract_Type (Tag_Typ) then return Make_Abstract_Subprogram_Declaration (Loc, Spec); @@ -6190,7 +8349,7 @@ package body Exp_Ch3 is function Predefined_Primitive_Bodies (Tag_Typ : Entity_Id; - Renamed_Eq : Node_Id) return List_Id + Renamed_Eq : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Tag_Typ); Res : constant List_Id := New_List; @@ -6200,13 +8359,38 @@ package body Exp_Ch3 is Eq_Name : Name_Id; Ent : Entity_Id; + pragma Warnings (Off, Ent); + begin + pragma Assert (not Is_Interface (Tag_Typ)); + -- See if we have a predefined "=" operator if Present (Renamed_Eq) then Eq_Needed := True; Eq_Name := Chars (Renamed_Eq); + -- If the parent is an interface type then it has defined all the + -- predefined primitives abstract and we need to check if the type + -- has some user defined "=" function to avoid generating it. + + elsif Is_Interface (Etype (Tag_Typ)) then + Eq_Needed := True; + Eq_Name := Name_Op_Eq; + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + if Chars (Node (Prim)) = Name_Op_Eq + and then not Is_Internal (Node (Prim)) + then + Eq_Needed := False; + Eq_Name := No_Name; + exit; + end if; + + Next_Elmt (Prim); + end loop; + else Eq_Needed := False; Eq_Name := No_Name; @@ -6218,6 +8402,7 @@ package body Exp_Ch3 is then Eq_Needed := True; Eq_Name := Name_Op_Eq; + exit; end if; Next_Elmt (Prim); @@ -6239,7 +8424,7 @@ package body Exp_Ch3 is Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_X), @@ -6262,7 +8447,7 @@ package body Exp_Ch3 is Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_X), @@ -6288,72 +8473,85 @@ package body Exp_Ch3 is Append_To (Res, Decl); end if; - -- Skip bodies of _Input and _Output for the abstract case, since - -- the corresponding specs are abstract (see Predef_Spec_Or_Body) + -- Skip body of _Input for the abstract case, since the corresponding + -- spec is abstract (see Predef_Spec_Or_Body). - if not Is_Abstract (Tag_Typ) then - if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) - and then No (TSS (Tag_Typ, TSS_Stream_Input)) - then - Build_Record_Or_Elementary_Input_Function - (Loc, Tag_Typ, Decl, Ent); - Append_To (Res, Decl); - end if; + if not Is_Abstract_Type (Tag_Typ) + and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) + and then No (TSS (Tag_Typ, TSS_Stream_Input)) + then + Build_Record_Or_Elementary_Input_Function + (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; - if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) - and then No (TSS (Tag_Typ, TSS_Stream_Output)) - then - Build_Record_Or_Elementary_Output_Procedure - (Loc, Tag_Typ, Decl, Ent); - Append_To (Res, Decl); - end if; + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) + and then No (TSS (Tag_Typ, TSS_Stream_Output)) + then + Build_Record_Or_Elementary_Output_Procedure + (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); end if; - -- Generate the bodies for the following primitive operations: + -- Ada 2005: Generate bodies for the following primitive operations for + -- limited interfaces and synchronized types that implement a limited + -- interface. + -- disp_asynchronous_select -- disp_conditional_select -- disp_get_prim_op_kind + -- disp_get_task_id -- disp_timed_select - -- for tagged types that implement a limited interface. + + -- The interface versions will have null bodies + + -- These operations cannot be implemented on VM targets, so we simply + -- disable their generation in this case. Disable the generation of + -- these bodies if No_Dispatching_Calls, Ravenscar or ZFP is active. if Ada_Version >= Ada_05 - and then not Is_Interface (Tag_Typ) - and then not Is_Abstract (Tag_Typ) - and then not Is_Controlled (Tag_Typ) - and then Implements_Limited_Interface (Tag_Typ) + and then Tagged_Type_Expansion + and then not Is_Interface (Tag_Typ) + and then + ((Is_Interface (Etype (Tag_Typ)) + and then Is_Limited_Record (Etype (Tag_Typ))) + or else (Is_Concurrent_Record_Type (Tag_Typ) + and then Has_Interfaces (Tag_Typ))) + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) + and then RTE_Available (RE_Select_Specific_Data) then - Append_To (Res, - Make_Disp_Asynchronous_Select_Body (Tag_Typ)); - Append_To (Res, - Make_Disp_Conditional_Select_Body (Tag_Typ)); - Append_To (Res, - Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); - Append_To (Res, - Make_Disp_Timed_Select_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); end if; - if not Is_Limited_Type (Tag_Typ) then - + if not Is_Limited_Type (Tag_Typ) + and then not Is_Interface (Tag_Typ) + then -- Body for equality if Eq_Needed then + Decl := + Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Eq_Name, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), - Decl := Predef_Spec_Or_Body (Loc, - Tag_Typ => Tag_Typ, - Name => Eq_Name, - Profile => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_X), - Parameter_Type => New_Reference_To (Tag_Typ, Loc)), - - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Y), - Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), - Ret_Type => Standard_Boolean, - For_Body => True); + Ret_Type => Standard_Boolean, + For_Body => True); declare Def : constant Node_Id := Parent (Tag_Typ); @@ -6381,12 +8579,12 @@ package body Exp_Ch3 is Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def))); Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps)); Append_To (Stmts, - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc))); else Append_To (Stmts, - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Expand_Record_Equality (Tag_Typ, Typ => Tag_Typ, @@ -6403,19 +8601,20 @@ package body Exp_Ch3 is -- Body for dispatching assignment - Decl := Predef_Spec_Or_Body (Loc, - Tag_Typ => Tag_Typ, - Name => Name_uAssign, - Profile => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), - Out_Present => True, - Parameter_Type => New_Reference_To (Tag_Typ, Loc)), - - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), - Parameter_Type => New_Reference_To (Tag_Typ, Loc))), - For_Body => True); + Decl := + Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uAssign, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + For_Body => True); Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( @@ -6440,7 +8639,16 @@ package body Exp_Ch3 is elsif Restriction_Active (No_Finalization) then null; - elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ)) + elsif (Etype (Tag_Typ) = Tag_Typ + or else Is_Controlled (Tag_Typ) + + -- Ada 2005 (AI-251): We must also generate these subprograms + -- if the immediate ancestor of Tag_Typ is an interface to + -- ensure the correct initialization of its dispatch table. + + or else (not Is_Interface (Tag_Typ) + and then + Is_Interface (Etype (Tag_Typ)))) and then not Has_Controlled_Component (Tag_Typ) then if not Is_Limited_Type (Tag_Typ) then @@ -6501,7 +8709,7 @@ package body Exp_Ch3 is begin Prim := First_Elmt (Primitive_Operations (Tag_Typ)); while Present (Prim) loop - if Is_Internal (Node (Prim)) then + if Is_Predefined_Dispatching_Operation (Node (Prim)) then Frnodes := Freeze_Entity (Node (Prim), Loc); if Present (Frnodes) then @@ -6523,27 +8731,94 @@ package body Exp_Ch3 is (Typ : Entity_Id; Operation : TSS_Name_Type) return Boolean is - Has_Inheritable_Stream_Attribute : Boolean := False; + Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False; begin + -- Special case of a limited type extension: a default implementation + -- of the stream attributes Read or Write exists if that attribute + -- has been specified or is available for an ancestor type; a default + -- implementation of the attribute Output (resp. Input) exists if the + -- attribute has been specified or Write (resp. Read) is available for + -- an ancestor type. The last condition only applies under Ada 2005. + if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) - and then Is_Derived_Type (Typ) then - -- Special case of a limited type extension: a default implementation - -- of the stream attributes Read and Write exists if the attribute - -- has been specified for an ancestor type. + if Operation = TSS_Stream_Read then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Read (Typ); + + elsif Operation = TSS_Stream_Write then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Write (Typ); + + elsif Operation = TSS_Stream_Input then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Input (Typ) + or else + (Ada_Version >= Ada_05 + and then Stream_Operation_OK (Typ, TSS_Stream_Read)); + + elsif Operation = TSS_Stream_Output then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Output (Typ) + or else + (Ada_Version >= Ada_05 + and then Stream_Operation_OK (Typ, TSS_Stream_Write)); + end if; + + -- Case of inherited TSS_Stream_Read or TSS_Stream_Write - Has_Inheritable_Stream_Attribute := - Present (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); + if not Has_Predefined_Or_Specified_Stream_Attribute + and then Is_Derived_Type (Typ) + and then (Operation = TSS_Stream_Read + or else Operation = TSS_Stream_Write) + then + Has_Predefined_Or_Specified_Stream_Attribute := + Present + (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); + end if; end if; - return - not (Is_Limited_Type (Typ) - and then not Has_Inheritable_Stream_Attribute) - and then RTE_Available (RE_Tag) - and then RTE_Available (RE_Root_Stream_Type) - and then not Restriction_Active (No_Dispatch) - and then not Restriction_Active (No_Streams); + -- If the type is not limited, or else is limited but the attribute is + -- explicitly specified or is predefined for the type, then return True, + -- unless other conditions prevail, such as restrictions prohibiting + -- streams or dispatching operations. We also return True for limited + -- interfaces, because they may be extended by nonlimited types and + -- permit inheritance in this case (addresses cases where an abstract + -- extension doesn't get 'Input declared, as per comments below, but + -- 'Class'Input must still be allowed). Note that attempts to apply + -- stream attributes to a limited interface or its class-wide type + -- (or limited extensions thereof) will still get properly rejected + -- by Check_Stream_Attribute. + + -- We exclude the Input operation from being a predefined subprogram in + -- the case where the associated type is an abstract extension, because + -- the attribute is not callable in that case, per 13.13.2(49/2). Also, + -- we don't want an abstract version created because types derived from + -- the abstract type may not even have Input available (for example if + -- derived from a private view of the abstract type that doesn't have + -- a visible Input), but a VM such as .NET or the Java VM can treat the + -- operation as inherited anyway, and we don't want an abstract function + -- to be (implicitly) inherited in that case because it can lead to a VM + -- exception. + + return (not Is_Limited_Type (Typ) + or else Is_Interface (Typ) + or else Has_Predefined_Or_Specified_Stream_Attribute) + and then (Operation /= TSS_Stream_Input + or else not Is_Abstract_Type (Typ) + or else not Is_Derived_Type (Typ)) + and then not Has_Unknown_Discriminants (Typ) + and then not (Is_Interface (Typ) + and then (Is_Task_Interface (Typ) + or else Is_Protected_Interface (Typ) + or else Is_Synchronized_Interface (Typ))) + and then not Restriction_Active (No_Streams) + and then not Restriction_Active (No_Dispatch) + and then not No_Run_Time_Mode + and then RTE_Available (RE_Tag) + and then RTE_Available (RE_Root_Stream_Type); end Stream_Operation_OK; + end Exp_Ch3;