diff options
| author | Ed Schonberg <schonberg@adacore.com> | 2007-06-06 12:24:57 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2007-06-06 12:24:57 +0200 |
| commit | 47cc8d6bfdf64ccaaa6df4bdd02fcf732583ca71 (patch) | |
| tree | be0d685205befdc6dd3b45e1cfa7a24b241c39c6 /gcc/ada/exp_ch3.adb | |
| parent | 822033ebf3b7ac6a0da5c6cde4a9e1f68b2d5a56 (diff) | |
| download | gcc-47cc8d6bfdf64ccaaa6df4bdd02fcf732583ca71.tar.gz | |
exp_ch3.adb (Make_Controlling_Function_Wrappers): generate wrapper a wrapper when the full view of the controlling type of an...
2007-04-20 Ed Schonberg <schonberg@adacore.com>
Javier Miranda <miranda@adacore.com>
Robert Dewar <dewar@adacore.com>
* exp_ch3.adb (Make_Controlling_Function_Wrappers): generate wrapper a
wrapper when the full view of the controlling type of an inherited
function that dispatches on result implements interfaces.
(Expand_N_Object_Declaration): In cases where the type of the
declaration is anonymous access, create finalization list for it.
(Expand_N_Object_Declaration): Generate a persistent_bss directive only
if the object has no explicit initialization, to match description of
functionality of pragam Persistent_BSS.
(Build_Equivalent_Array_Aggregate, Build_Equivalent_Record_Aggregate):
new function to build static aggregates, to replace initialization call
when static initialization is desired.
(Freeze_Type): Generate a list controller for an access type whenever
its designated type has controlled anonymous access discriminants.
(Build_Equivalent_Aggregate): New procedure to compute a static
aggregate to be used as default initialization for composite types,
instead of a generating a call to the initialization procedure for the
type.
(Build_Initialization_Call): When available, replace a call to the
initialization procedure with a copy of the equivalent static aggregate
for the type.
(Expand_N_Object_Declaration): Use New_Occurrence_Of in generated
declarations for objects of a class-wide interface type, rather than
just identifiers, to prevent visibility problems.
(Expand_N_Object_Declaration): When expanding the declaration for an
object of a class-wide interface type, preserve the homonym chain of
the original entity before exchanging it with that of the generated
renaming declaration.
(Freeze_Enumeration_Type): Don't raise CE if No_Exception_Propagation
active, because there is no way to handle the exception.
(Freeze_Record_Type): In case of CPP_Class types add a call to Make_DT
to do a minimum decoration of the Access_Disp_Table list.
(Expand_Record_Controller): Avoid the addition of the controller between
the component containing the tag of a secondary dispatch table and its
adjacent component that stores the offset to the base of the object.
This latter component is only generated when the parent type has
discriminants ---documented in Add_Interface_Tag_Components).
(Apply_Array_Size_Check): Removed, no longer needed.
(Expand_N_Full_Type_Declaration): If the type has anonymous access
components, create a Master_Entity for it only if it contains tasks.
(Build_Init_Procedure): Suppress the tag assignment compiling under
no run-time mode.
(Freeze_Record_Type): Remove code associated with creation of dispatch
table.
(Init_Secondary_Tags): Update type of actuals when generating calls to
Ada.Tags.Set_Offset_To_Top
(Stream_Operation_OK): Disable use of streams compiling under no
run-time mode
(Expand_N_Object_Declaration): Don't do Initialize_Scalars initalization
if Has_Init_Expression set.
(Build_Init_Procedure): Replace call to Fill_DT_Entry by call to
Register_Primitive, which provides the same functionality.
(Requires_Init_Proc): Return false in case of interface types.
(Add_Secondary_Tables): Use the new attribute Related_Interface to
cleanup the code.
(Predefined_Primitive_Freeze): Do not assume that an internal entity
is always associated with a predefined primitive because the internal
entities associated with interface types are not predefined primitives.
Therefore, the call to Is_Internal is replaced by a call to the
function Is_Predefined_Dispatching_Operation.
(Make_Eq_If): When generating the list of comparisons for the
components of a given variant, omit the controller component that is
present if the variant has controlled components.
From-SVN: r125396
Diffstat (limited to 'gcc/ada/exp_ch3.adb')
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 1089 |
1 files changed, 677 insertions, 412 deletions
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 8c84a2df697..9f2a60b7375 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -42,8 +42,8 @@ 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; @@ -62,6 +62,7 @@ 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; @@ -92,6 +93,22 @@ package body Exp_Ch3 is -- of the type. 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 similarc 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; @@ -121,10 +138,10 @@ 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; @@ -167,6 +184,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 @@ -187,23 +210,23 @@ package body Exp_Ch3 is (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; @@ -222,32 +245,31 @@ 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; @@ -308,7 +330,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; @@ -323,12 +345,12 @@ package body Exp_Ch3 is -- 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: @@ -581,7 +603,7 @@ package body Exp_Ch3 is -- Start of processing for Build_Array_Init_Proc begin - if Suppress_Init_Proc (A_Type) then + if Suppress_Init_Proc (A_Type) or else Is_Value_Type (Comp_Type) then return; end if; @@ -592,7 +614,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 @@ -644,7 +666,7 @@ 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) @@ -666,6 +688,15 @@ package body Exp_Ch3 is and then Nkind (First (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; @@ -688,9 +719,9 @@ 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. + -- 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); @@ -702,9 +733,9 @@ package body Exp_Ch3 is 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, @@ -716,7 +747,7 @@ package body Exp_Ch3 is Make_Explicit_Dereference (Loc, New_Reference_To (RTE (RE_Current_Master), Loc))); - Insert_Before (P, Decl); + Insert_Action (P, Decl); Analyze (Decl); Set_Has_Master_Entity (Scope (T)); @@ -775,12 +806,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; @@ -811,8 +842,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))); @@ -1054,25 +1085,194 @@ 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; + + -- 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 + declare + Comp_Type : constant Entity_Id := Component_Type (Etype (Comp)); + + begin + 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; + end; + + elsif Is_Scalar_Type (Etype (Comp)) then + if Nkind (Parent (Comp)) /= N_Component_Declaration + or else No (Expression (Parent (Comp))) + or else not Compile_Time_Known_Value (Expression (Parent (Comp))) + 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; @@ -1113,8 +1313,12 @@ package body Exp_Ch3 is -- 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_Value_Type (Component_Type (Typ)) + then return Empty_List; end if; @@ -1199,9 +1403,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; @@ -1248,11 +1452,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 := @@ -1263,9 +1466,9 @@ 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; @@ -1324,6 +1527,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. @@ -1428,11 +1632,11 @@ package body Exp_Ch3 is 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 @@ -1472,7 +1676,7 @@ package body Exp_Ch3 is -- 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. @@ -1480,10 +1684,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; @@ -1497,12 +1701,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 @@ -1570,9 +1774,9 @@ package body Exp_Ch3 is 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. Exp := New_Copy_Tree (Exp); @@ -1584,10 +1788,10 @@ 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 VM_Target = No_VM then Append_To (Res, Make_Assignment_Statement (Loc, Name => @@ -1602,8 +1806,8 @@ 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)); @@ -1611,6 +1815,7 @@ package body Exp_Ch3 is if Controlled_Type (Typ) and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) + and then not Is_Inherently_Limited_Type (Typ) then Append_List_To (Res, Make_Adjust_Call ( @@ -1839,8 +2044,9 @@ package body Exp_Ch3 is if Typ = Rec_Type then Body_Node := New_Node (N_Subprogram_Body, Loc); - Func_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('F')); + Func_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('F')); Set_DT_Offset_To_Top_Func (E, Func_Id); @@ -1908,9 +2114,8 @@ package body Exp_Ch3 is return; end if; - -- Skip the first _Tag, which is the main tag of the - -- tagged type. Following tags correspond with abstract - -- interfaces. + -- Skip the first _Tag, which is the main tag of the tagged type. + -- Following tags correspond with abstract interfaces. ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type))); @@ -1961,7 +2166,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, @@ -2021,18 +2227,19 @@ 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. It is also suppressed in - -- case of CPP_Class types because in this case the tag is - -- initialized in the C++ side. + -- 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 VM_Target = No_VM + and then not No_Run_Time_Mode then Init_Tag := Make_Assignment_Statement (Loc, @@ -2048,10 +2255,11 @@ package body Exp_Ch3 is -- 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 @@ -2065,6 +2273,10 @@ package body Exp_Ch3 is Prepend_To (Body_Stmts, Init_Tag); + -- CPP_Class: 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); @@ -2110,12 +2322,10 @@ package body Exp_Ch3 is Insert_After (Nod, Init_Tag); - -- We have inherited the whole contents of the DT table - -- from the CPP side. Therefore all our previous initia- - -- lization has been lost and we must refill entries - -- associated with Ada primitives. This needs more work - -- to avoid its execution each time an object is - -- initialized??? + -- 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; @@ -2131,8 +2341,9 @@ package body Exp_Ch3 is and then not Present (Abstract_Interface_Alias (Prim)) then - Insert_After (Init_Tag, - Fill_DT_Entry (Loc, Prim)); + Register_Primitive (Loc, + Prim => Prim, + Ins_Nod => Init_Tag); end if; Next_Elmt (E); @@ -2141,11 +2352,13 @@ package body Exp_Ch3 is end; end if; - -- Ada 2005 (AI-251): Initialization of all the tags - -- corresponding with abstract interfaces + -- Ada 2005 (AI-251): Initialization of all the tags corresponding + -- with abstract interfaces - if Ada_Version >= Ada_05 + if VM_Target = No_VM + and then Ada_Version >= Ada_05 and then not Is_Interface (Rec_Type) + and then Has_Abstract_Interfaces (Rec_Type) then Init_Secondary_Tags (Typ => Rec_Type, @@ -2174,7 +2387,12 @@ package body Exp_Ch3 is if List_Length (Body_Stmts) = 1 and then Nkind (First (Body_Stmts)) = N_Null_Statement + and then VM_Target /= CLI_Target then + -- Even though the init proc may be null at this time it might get + -- some stuff added to it later by the CIL backend, so always keep + -- it when VM_Target = CLI_Target. + Set_Is_Null_Init_Proc (Proc_Id); end if; end Build_Init_Procedure; @@ -2309,15 +2527,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 + -- 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 @@ -2334,7 +2553,6 @@ package body Exp_Ch3 is -- 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); @@ -2372,7 +2590,6 @@ package body Exp_Ch3 is 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, @@ -2381,7 +2598,6 @@ package body Exp_Ch3 is New_Copy_List (Discrete_Choices (Variant)), Statements => Build_Init_Statements (Component_List (Variant)))); - Next_Non_Pragma (Variant); end loop; @@ -2623,7 +2839,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); @@ -2711,6 +2927,9 @@ package body Exp_Ch3 is if Is_CPP_Class (Rec_Id) then return False; + elsif Is_Interface (Rec_Id) then + return False; + elsif not Restriction_Active (No_Initialize_Scalars) and then Is_Public (Rec_Id) then @@ -2749,6 +2968,10 @@ package body Exp_Ch3 is begin 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. @@ -2824,6 +3047,9 @@ package body Exp_Ch3 is if not Debug_Generated_Code then Set_Debug_Info_Off (Proc_Id); end if; + + Set_Static_Initialization + (Proc_Id, Build_Equivalent_Record_Aggregate (Rec_Type)); end if; end Build_Record_Init_Proc; @@ -2834,9 +3060,10 @@ 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; @@ -2851,21 +3078,21 @@ 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; + -- 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; -- end loop; -- end Assign; @@ -3161,11 +3388,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, @@ -3179,9 +3407,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 @@ -3539,6 +3767,7 @@ package body Exp_Ch3 is -- 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; @@ -3593,7 +3822,7 @@ package body Exp_Ch3 is Next_Entity (Comp); end loop; - -- If found we add a renaming reclaration of master_id and we + -- 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 @@ -3601,8 +3830,14 @@ package body Exp_Ch3 is -- 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); @@ -3692,13 +3927,14 @@ 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); - Expr : constant Node_Id := Expression (N); - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (Def_Id); - Expr_Q : Node_Id; - Id_Ref : Node_Id; - New_Ref : 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); + Expr_Q : Node_Id; + Id_Ref : Node_Id; + New_Ref : Node_Id; + BIP_Call : Boolean := False; begin -- Don't do anything for deferred constants. All proper actions will @@ -3724,6 +3960,16 @@ package body Exp_Ch3 is Build_Master_Entity (Def_Id); end if; + -- Build a list controller for declarations of the form + -- Obj : access Some_Type [:= Expression]; + + if 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 @@ -3799,6 +4045,7 @@ package body Exp_Ch3 is if Has_Non_Null_Base_Init_Proc (Typ) and then not No_Initialization (N) + and then not Is_Value_Type (Typ) then -- The call to the initialization procedure does NOT freeze the -- object being initialized. This is because the call is not a @@ -3811,19 +4058,34 @@ package body Exp_Ch3 is 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 (N, + 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. 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))); @@ -3835,6 +4097,7 @@ package body Exp_Ch3 is 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 @@ -3878,13 +4141,14 @@ package body Exp_Ch3 is -- 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 we plan to expand the allowed forms of funtions + -- but eventually we plan to expand the allowed forms of functions -- that are treated as build-in-place. if 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); + BIP_Call := True; end if; -- In most cases, we must check that the initial value meets any @@ -3937,8 +4201,9 @@ package body Exp_Ch3 is Object_Definition => Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, - Chars (Root_Type (Etype (Def_Id)))), + Prefix => + New_Occurrence_Of + (Root_Type (Etype (Def_Id)), Loc), Attribute_Name => Name_Class), Expression => @@ -3966,8 +4231,8 @@ package body Exp_Ch3 is Subtype_Mark => Make_Attribute_Reference (Loc, Prefix => - Make_Identifier (Loc, - Chars => Chars (Root_Type (Etype (Def_Id)))), + New_Occurrence_Of + (Root_Type (Etype (Def_Id)), Loc), Attribute_Name => Name_Class), Name => @@ -4003,66 +4268,41 @@ package body Exp_Ch3 is -- 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). + -- 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); return; end; end if; - -- If the type is controlled we attach the object to the final - -- list and adjust the target after the copy. This - -- ??? incomplete sentence - - 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); - - else - Flist := Find_Final_List (Def_Id); - end if; + -- If the type is controlled and not 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. (We eventually plan to support + -- in-place function results for some nonlimited types. ???) - -- Adjustment is only needed when the controlled type is not - -- limited. - - if not Is_Limited_Type (Typ) then - 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; - end; + if Controlled_Type (Typ) + and then not Is_Limited_Type (Typ) + and then not BIP_Call + then + Insert_Actions_After (N, + 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 + -- 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. @@ -4070,7 +4310,7 @@ package body Exp_Ch3 is 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 VM_Target = No_VM and then Nkind (Expr) /= N_Aggregate then -- The re-assignment of the tag has to be done even if the @@ -4159,13 +4399,6 @@ package body Exp_Ch3 is end if; end if; - -- For array type, check for size too large - -- We really need this for record types too??? - - if Is_Array_Type (Typ) then - Apply_Array_Size_Check (N, Typ); - end if; - exception when RE_Not_Available => return; @@ -4311,15 +4544,25 @@ package body Exp_Ch3 is 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 implemented - -- interfaces, if present. + -- if T is a tagged type, place controller declaration after parent + -- field and after eventual tags of interface types. else while Present (First_Comp) and then (Chars (Defining_Identifier (First_Comp)) = Name_uParent - or else Is_Tag (Defining_Identifier (First_Comp))) + or else Is_Tag (Defining_Identifier (First_Comp)) + + -- Ada 2005 (AI-251): The following condition covers secondary + -- tags but also the adjacent component contanining 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_Interface + (Defining_Identifier (First_Comp)))) loop Next (First_Comp); end loop; @@ -4336,7 +4579,7 @@ package body Exp_Ch3 is end if; end if; - New_Scope (T); + Push_Scope (T); Analyze (Comp_Decl); Set_Ekind (Ent, E_Component); Init_Component_Location (Ent); @@ -4441,6 +4684,7 @@ package body Exp_Ch3 is if Has_Task (Typ) and then not Restriction_Active (No_Implicit_Heap_Allocations) and then not Global_Discard_Names + and then VM_Target = No_VM then Set_Uses_Sec_Stack (Proc_Id); end if; @@ -4471,8 +4715,8 @@ package body Exp_Ch3 is -- 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) @@ -4655,6 +4899,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 @@ -4727,7 +4973,6 @@ package body Exp_Ch3 is else Ent := First_Literal (Typ); - while Present (Ent) loop Append_To (Lst, Make_Case_Statement_Alternative (Loc, @@ -4747,7 +4992,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)), @@ -4759,8 +5004,8 @@ package body Exp_Ch3 is 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 @@ -4907,18 +5152,18 @@ package body Exp_Ch3 is 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. + -- 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 if Is_CPP_Class (Def_Id) then -- Because of the new C++ ABI compatibility we now allow the - -- programer to use the Ada tag (and in this case we must do + -- programmer to use the Ada tag (and in this case we must do -- the normal expansion of the tag) if Etype (First_Component (Def_Id)) = RTE (RE_Tag) @@ -4930,42 +5175,51 @@ package body Exp_Ch3 is Set_All_DT_Position (Def_Id); Set_Default_Constructor (Def_Id); + -- With CPP_Class types Make_DT does a minimum decoration of the + -- Access_Disp_Table list. + + if VM_Target = No_VM then + Append_Freeze_Actions (Def_Id, Make_DT (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 Static_Dispatch_Tables 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); - - if Present (Alias (Subp)) then - if Is_CPP_Class (Etype (Def_Id)) then - Set_Has_Delayed_Freeze (Subp); - - elsif Has_Delayed_Freeze (Alias (Subp)) - and then not Is_Frozen (Alias (Subp)) - then - Set_Is_Frozen (Subp, False); - Set_Has_Delayed_Freeze (Subp); + -- 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; + + begin + while Present (Elmt) loop + Subp := Node (Elmt); + + if Present (Alias (Subp)) then + if Is_CPP_Class (Etype (Def_Id)) then + Set_Has_Delayed_Freeze (Subp); + + 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; - end if; - Next_Elmt (Elmt); - end loop; - end; + Next_Elmt (Elmt); + end loop; + end; + end if; if Underlying_Type (Etype (Def_Id)) = Def_Id then Expand_Tagged_Root (Def_Id); @@ -5016,7 +5270,7 @@ package body Exp_Ch3 is Insert_Actions (N, Null_Proc_Decl_List); end if; - Set_Is_Frozen (Def_Id, True); + Set_Is_Frozen (Def_Id); Set_All_DT_Position (Def_Id); -- Add the controlled component before the freezing actions @@ -5026,90 +5280,12 @@ package body Exp_Ch3 is Expand_Record_Controller (Def_Id); end if; - -- Suppress creation of a dispatch table when Java_VM because the - -- dispatching mechanism is handled internally by the JVM. - - if not Java_VM then - - -- Ada 2005 (AI-251): Build the secondary dispatch tables - - declare - ADT : Elist_Id := Access_Disp_Table (Def_Id); - - procedure Add_Secondary_Tables (Typ : Entity_Id); - -- Internal subprogram, recursively climb to the ancestors - - -------------------------- - -- Add_Secondary_Tables -- - -------------------------- - - procedure Add_Secondary_Tables (Typ : Entity_Id) is - E : Entity_Id; - Iface : Elmt_Id; - Result : List_Id; - Suffix_Index : Int; - - begin - -- Climb to the ancestor (if any) handling private types - - if Is_Concurrent_Record_Type (Typ) then - if Present (Abstract_Interface_List (Typ)) then - Add_Secondary_Tables - (Etype (First (Abstract_Interface_List (Typ)))); - end if; - - elsif Present (Full_View (Etype (Typ))) then - if Full_View (Etype (Typ)) /= Typ then - Add_Secondary_Tables (Full_View (Etype (Typ))); - end if; - - elsif Etype (Typ) /= Typ then - Add_Secondary_Tables (Etype (Typ)); - end if; - - if Present (Abstract_Interfaces (Typ)) - and then - not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) - then - Iface := First_Elmt (Abstract_Interfaces (Typ)); - Suffix_Index := 0; - - E := First_Entity (Typ); - while Present (E) loop - if Is_Tag (E) and then Chars (E) /= Name_uTag then - Make_Secondary_DT - (Typ => Def_Id, - Ancestor_Typ => Typ, - Suffix_Index => Suffix_Index, - Iface => Node (Iface), - AI_Tag => E, - Acc_Disp_Tables => ADT, - Result => Result); - - Append_Freeze_Actions (Def_Id, Result); - Suffix_Index := Suffix_Index + 1; - Next_Elmt (Iface); - end if; - - Next_Entity (E); - end loop; - end if; - end Add_Secondary_Tables; - - -- Start of processing to build secondary dispatch tables - - begin - -- Handle private types - - if Present (Full_View (Def_Id)) then - Add_Secondary_Tables (Full_View (Def_Id)); - else - Add_Secondary_Tables (Def_Id); - end if; + -- Build the dispatch table. Suppress its creation when VM_Target + -- because the dispatching mechanism is handled internally by the + -- VMs. - Set_Access_Disp_Table (Def_Id, ADT); - Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); - end; + if VM_Target = No_VM then + Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); end if; -- Make sure that the primitives Initialize, Adjust and Finalize @@ -5204,7 +5380,14 @@ package body Exp_Ch3 is end if; Adjust_Discriminants (Def_Id); - Build_Record_Init_Proc (Type_Decl, Def_Id); + + if VM_Target = No_VM or else not Is_Interface (Def_Id) then + + -- 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, build bodies of primitive operations. Note that we -- do this after building the record initialization experiment, since @@ -5350,7 +5533,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; @@ -5491,7 +5674,7 @@ 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 @@ -5573,7 +5756,8 @@ package body Exp_Ch3 is null; elsif (Controlled_Type (Desig_Type) - and then Convention (Desig_Type) /= Convention_Java) + 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)) @@ -5596,6 +5780,11 @@ 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))) + + -- 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, @@ -5818,7 +6007,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. @@ -6012,9 +6201,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; @@ -6022,6 +6212,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 initializtion + -- 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 -- ------------------ @@ -6218,7 +6468,7 @@ package body Exp_Ch3 is New_Reference_To (Tag_Comp, Loc)), Attribute_Name => Name_Position)), - Unchecked_Convert_To (RTE (RE_Address), + 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), @@ -6284,8 +6534,7 @@ package body Exp_Ch3 is New_Reference_To (Tag_Comp, Loc)), Attribute_Name => Name_Position)), - New_Reference_To - (RTE (RE_Null_Address), Loc)))); + Make_Null (Loc)))); end if; end if; end Initialize_Tag; @@ -6342,7 +6591,7 @@ package body Exp_Ch3 is Loc)), New_Occurrence_Of (Standard_True, Loc), Make_Integer_Literal (Loc, Uint_0), - New_Reference_To (RTE (RE_Null_Address), Loc)))); + Make_Null (Loc)))); end if; if Present (Abstract_Interfaces (Typ)) @@ -6435,8 +6684,12 @@ package body Exp_Ch3 is -- 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 Is_Abstract_Subprogram (Subp) + if (Is_Abstract_Subprogram (Subp) + or else Requires_Overriding (Subp)) and then Present (Alias (Subp)) and then not Is_Abstract_Subprogram (Alias (Subp)) and then not Comes_From_Source (Subp) @@ -6660,13 +6913,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 => @@ -6918,13 +7176,12 @@ package body Exp_Ch3 is 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 @@ -6957,10 +7214,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); @@ -6994,7 +7251,9 @@ package body Exp_Ch3 is Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); end if; - -- Generate the declarations for the following primitive operations: + -- 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 @@ -7002,14 +7261,16 @@ package body Exp_Ch3 is -- disp_get_task_id -- disp_timed_select - -- for limited interfaces and synchronized types that implement a - -- limited interface. + -- These operations cannot be implemented on VM targets, so we simply + -- disable their generation in this case. We also disable generation + -- of these bodies if No_Dispatching_Calls is active. if Ada_Version >= Ada_05 + and then VM_Target = No_VM and then ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) or else (Is_Concurrent_Record_Type (Tag_Typ) - and then Has_Abstract_Interfaces (Tag_Typ))) + and then Has_Abstract_Interfaces (Tag_Typ))) then Append_To (Res, Make_Subprogram_Declaration (Loc, @@ -7037,13 +7298,12 @@ package body Exp_Ch3 is Make_Disp_Timed_Select_Spec (Tag_Typ))); 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; @@ -7081,8 +7341,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 @@ -7196,12 +7456,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); @@ -7223,18 +7482,18 @@ 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 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 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. + -- generate abstract specifications. These will never be called, but we + -- need the slots 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 @@ -7381,8 +7640,8 @@ 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 bodies of _Input and _Output for the abstract case, since the + -- corresponding specs are abstract (see Predef_Spec_Or_Body). if not Is_Abstract_Type (Tag_Typ) then if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) @@ -7402,7 +7661,9 @@ package body Exp_Ch3 is end if; 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 @@ -7410,12 +7671,15 @@ package body Exp_Ch3 is -- disp_get_task_id -- disp_timed_select - -- for limited interfaces and synchronized types that implement a - -- limited interface. The interface versions will have null bodies. + -- The interface versions will have null bodies + + -- These operations cannot be implemented on VM targets, so we simply + -- disable their generation in this case. We also disable generation + -- of these bodies if No_Dispatching_Calls is active. if Ada_Version >= Ada_05 - and then - not Restriction_Active (No_Dispatching_Calls) + and then VM_Target = No_VM + and then not Restriction_Active (No_Dispatching_Calls) and then ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) or else (Is_Concurrent_Record_Type (Tag_Typ) @@ -7607,7 +7871,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 @@ -7654,6 +7918,7 @@ package body Exp_Ch3 is 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; |