-- --
-- 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- --
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 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;
-- 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;
-- 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;
-- 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
(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;
-- 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;
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;
-- 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:
-- 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;
-- 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
-- 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 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;
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);
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,
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));
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;
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)));
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;
-- 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;
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;
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 :=
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;
-- 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.
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
-- 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.
(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;
(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
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);
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 =>
(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));
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 (
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);
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)));
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,
-- 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,
-- 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
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);
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;
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);
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,
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;
-- 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
-- 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);
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,
New_Copy_List (Discrete_Choices (Variant)),
Statements =>
Build_Init_Statements (Component_List (Variant))));
-
Next_Non_Pragma (Variant);
end loop;
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);
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
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.
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;
-- 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;
-- 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;
-- 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,
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
-- 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;
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
-- 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);
-- 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
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
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
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)));
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
-- 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
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 =>
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 =>
-- 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.
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
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;
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;
end if;
end if;
- New_Scope (T);
+ Push_Scope (T);
Analyze (Comp_Decl);
Set_Ekind (Ent, E_Component);
Init_Component_Location (Ent);
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;
-- 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)
-- 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
else
Ent := First_Literal (Typ);
-
while Present (Ent) loop
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
-- 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)),
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
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)
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);
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
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
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
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;
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
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))
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,
-- 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.
----------------
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;
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 --
------------------
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),
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;
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))
-- 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)
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 =>
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
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);
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
-- 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,
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;
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
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);
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
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)
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
-- 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)
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
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;
projects / gcc.git / commitdiff