-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
-with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
+with Exp_Atag; use Exp_Atag;
with Exp_Ch4; use Exp_Ch4;
+with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Ch11; use Exp_Ch11;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
-with Hostparm; use Hostparm;
with Nlists; use Nlists;
+with Namet; use Namet;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
+with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
+with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Snames; use Snames;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Validsw; use Validsw;
-- Local Subprograms --
-----------------------
+ function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id;
+ -- Add the declaration of a finalization list to the freeze actions for
+ -- Def_Id, and return its defining identifier.
+
procedure Adjust_Discriminants (Rtype : Entity_Id);
-- This is used when freezing a record type. It attempts to construct
-- more restrictive subtypes for discriminants so that the max size of
-- used for attachment of any actions required in its construction.
-- It also supplies the source location used for the procedure.
- procedure Build_Class_Wide_Master (T : Entity_Id);
- -- for access to class-wide limited types we must build a task master
- -- because some subsequent extension may add a task component. To avoid
- -- bringing in the tasking run-time whenever an access-to-class-wide
- -- limited type is used, we use the soft-link mechanism and add a level
- -- of indirection to calls to routines that manipulate Master_Ids.
-
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean) return List_Id;
-- This function uses the discriminants of a type to build a list of
- -- formal parameters, used in the following function. If the flag Use_Dl
- -- is set, the list is built using the already defined discriminals
- -- of the type. Otherwise new identifiers are created, with the source
- -- names of the discriminants.
-
- procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id);
+ -- formal parameters, used in Build_Init_Procedure among other places.
+ -- If the flag Use_Dl is set, the list is built using the already
+ -- defined discriminals of the type, as is the case for concurrent
+ -- types with discriminants. Otherwise new identifiers are created,
+ -- with the source names of the discriminants.
+
+ function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
+ -- This function builds a static aggregate that can serve as the initial
+ -- value for an array type whose bounds are static, and whose component
+ -- type is a composite type that has a static equivalent aggregate.
+ -- The equivalent array aggregate is used both for object initialization
+ -- and for component initialization, when used in the following function.
+
+ function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
+ -- This function builds a static aggregate that can serve as the initial
+ -- value for a record type whose components are scalar and initialized
+ -- with compile-time values, or arrays with similar initialization or
+ -- defaults. When possible, initialization of an object of the type can
+ -- be achieved by using a copy of the aggregate as an initial value, thus
+ -- removing the implicit call that would otherwise constitute elaboration
+ -- code.
+
+ function Build_Master_Renaming
+ (N : Node_Id;
+ T : Entity_Id) return Entity_Id;
-- If the designated type of an access type is a task type or contains
-- tasks, we make sure that a _Master variable is declared in the current
-- scope, and then declare a renaming for it:
--
-- atypeM : Master_Id renames _Master;
--
- -- where atyp is the name of the access type. This declaration is
- -- used when an allocator for the access type is expanded. The node N
- -- is the full declaration of the designated type that contains tasks.
- -- The renaming declaration is inserted before N, and after the Master
- -- declaration.
+ -- where atyp is the name of the access type. This declaration is used when
+ -- an allocator for the access type is expanded. The node is the full
+ -- declaration of the designated type that contains tasks. The renaming
+ -- declaration is inserted before N, and after the Master declaration.
procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id);
-- Build record initialization procedure. N is the type declaration
-- and attach it to the TSS list
procedure Check_Stream_Attributes (Typ : Entity_Id);
- -- Check that if a limited extension has a parent with user-defined
- -- stream attributes, and does not itself have user-definer
- -- stream-attributes, then any limited component of the extension also
- -- has the corresponding user-defined stream attributes.
+ -- Check that if a limited extension has a parent with user-defined stream
+ -- attributes, and does not itself have user-defined stream-attributes,
+ -- then any limited component of the extension also has the corresponding
+ -- user-defined stream attributes.
+
+ procedure Clean_Task_Names
+ (Typ : Entity_Id;
+ Proc_Id : Entity_Id);
+ -- If an initialization procedure includes calls to generate names
+ -- for task subcomponents, indicate that secondary stack cleanup is
+ -- needed after an initialization. Typ is the component type, and Proc_Id
+ -- the initialization procedure for the enclosing composite type.
procedure Expand_Tagged_Root (T : Entity_Id);
-- Add a field _Tag at the beginning of the record. This field carries
-- the value of the access to the Dispatch table. This procedure is only
- -- called on root (non CPP_Class) types, the _Tag field being inherited
- -- by the descendants.
+ -- called on root type, the _Tag field being inherited by the descendants.
procedure Expand_Record_Controller (T : Entity_Id);
-- T must be a record type that Has_Controlled_Component. Add a field
-- _controller of type Record_Controller or Limited_Record_Controller
-- in the record T.
- procedure Freeze_Array_Type (N : Node_Id);
+ procedure Expand_Freeze_Array_Type (N : Node_Id);
-- Freeze an array type. Deals with building the initialization procedure,
-- creating the packed array type for a packed array and also with the
-- creation of the controlling procedures for the controlled case. The
-- argument N is the N_Freeze_Entity node for the type.
- procedure Freeze_Enumeration_Type (N : Node_Id);
+ procedure Expand_Freeze_Enumeration_Type (N : Node_Id);
-- Freeze enumeration type with non-standard representation. Builds the
-- array and function needed to convert between enumeration pos and
-- enumeration representation values. N is the N_Freeze_Entity node
-- for the type.
- procedure Freeze_Record_Type (N : Node_Id);
+ procedure Expand_Freeze_Record_Type (N : Node_Id);
-- Freeze record type. Builds all necessary discriminant checking
-- and other ancillary functions, and builds dispatch tables where
-- needed. The argument N is the N_Freeze_Entity node. This processing
-- 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
-- Check if E is defined in the RTL (in a child of Ada or System). Used
-- to avoid to bring in the overhead of _Input, _Output for tagged types.
+ function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
+ -- Returns true if E has variable size components
+
function Make_Eq_Case
(E : Entity_Id;
CL : Node_Id;
Discr : Entity_Id := Empty) return List_Id;
- -- Building block for variant record equality. Defined to share the
- -- code between the tagged and non-tagged case. Given a Component_List
- -- node CL, it generates an 'if' followed by a 'case' statement that
- -- compares all components of local temporaries named X and Y (that
- -- are declared as formals at some upper level). E provides the Sloc to be
- -- used for the generated code. Discr is used as the case statement switch
- -- in the case of Unchecked_Union equality.
+ -- Building block for variant record equality. Defined to share the code
+ -- between the tagged and non-tagged case. Given a Component_List node CL,
+ -- it generates an 'if' followed by a 'case' statement that compares all
+ -- components of local temporaries named X and Y (that are declared as
+ -- formals at some upper level). E provides the Sloc to be used for the
+ -- generated code. Discr is used as the case statement switch in the case
+ -- of Unchecked_Union equality.
function Make_Eq_If
(E : Entity_Id;
L : List_Id) return Node_Id;
- -- Building block for variant record equality. Defined to share the
- -- code between the tagged and non-tagged case. Given the list of
- -- components (or discriminants) L, it generates a return statement
- -- that compares all components of local temporaries named X and Y
- -- (that are declared as formals at some upper level). E provides the Sloc
- -- to be used for the generated code.
+ -- Building block for variant record equality. Defined to share the code
+ -- between the tagged and non-tagged case. Given the list of components
+ -- (or discriminants) L, it generates a return statement that compares all
+ -- components of local temporaries named X and Y (that are declared as
+ -- formals at some upper level). E provides the Sloc to be used for the
+ -- generated code.
procedure Make_Predefined_Primitive_Specs
(Tag_Typ : Entity_Id;
Predef_List : out List_Id;
- Renamed_Eq : out Node_Id);
+ Renamed_Eq : out Entity_Id);
-- Create a list with the specs of the predefined primitive operations.
+ -- For tagged types that are interfaces all these primitives are defined
+ -- abstract.
+ --
-- The following entries are present for all tagged types, and provide
-- the results of the corresponding attribute applied to the object.
-- Dispatching is required in general, since the result of the attribute
-- typSI provides result of 'Input attribute
-- typSO provides result of 'Output attribute
--
- -- The following entries are additionally present for non-limited
- -- tagged types, and implement additional dispatching operations
- -- for predefined operations:
+ -- The following entries are additionally present for non-limited tagged
+ -- types, and implement additional dispatching operations for predefined
+ -- operations:
--
-- _equality implements "=" operator
-- _assign implements assignment operation
-- typDF implements deep finalization
- -- typDA implements deep adust
+ -- typDA implements deep adjust
--
-- The latter two are empty procedures unless the type contains some
-- controlled components that require finalization actions (the deep
-- in the name refers to the fact that the action applies to components).
--
- -- The list is returned in Predef_List. The Parameter Renamed_Eq
- -- either returns the value Empty, or else the defining unit name
- -- for the predefined equality function in the case where the type
- -- has a primitive operation that is a renaming of predefined equality
- -- (but only if there is also an overriding user-defined equality
- -- function). The returned Renamed_Eq will be passed to the
- -- corresponding parameter of Predefined_Primitive_Bodies.
+ -- The list is returned in Predef_List. The Parameter Renamed_Eq either
+ -- returns the value Empty, or else the defining unit name for the
+ -- predefined equality function in the case where the type has a primitive
+ -- operation that is a renaming of predefined equality (but only if there
+ -- is also an overriding user-defined equality function). The returned
+ -- Renamed_Eq will be passed to the corresponding parameter of
+ -- Predefined_Primitive_Bodies.
function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
- -- returns True if there are representation clauses for type T that
- -- are not inherited. If the result is false, the init_proc and the
- -- discriminant_checking functions of the parent can be reused by
- -- a derived type.
+ -- returns True if there are representation clauses for type T that are not
+ -- inherited. If the result is false, the init_proc and the discriminant
+ -- checking functions of the parent can be reused by a derived type.
+
+ procedure Make_Controlling_Function_Wrappers
+ (Tag_Typ : Entity_Id;
+ Decl_List : out List_Id;
+ Body_List : out List_Id);
+ -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions
+ -- associated with inherited functions with controlling results which
+ -- are not overridden. The body of each wrapper function consists solely
+ -- of a return statement whose expression is an extension aggregate
+ -- invoking the inherited subprogram's parent subprogram and extended
+ -- with a null association list.
+
+ procedure Make_Null_Procedure_Specs
+ (Tag_Typ : Entity_Id;
+ Decl_List : out List_Id);
+ -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
+ -- null procedures inherited from an interface type that have not been
+ -- overridden. Only one null procedure will be created for a given set of
+ -- inherited null procedures with homographic profiles.
function Predef_Spec_Or_Body
(Loc : Source_Ptr;
function Predefined_Primitive_Bodies
(Tag_Typ : Entity_Id;
- Renamed_Eq : Node_Id) return List_Id;
+ Renamed_Eq : Entity_Id) return List_Id;
-- Create the bodies of the predefined primitives that are described in
-- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
-- the defining unit name of the type's predefined equality as returned
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;
-- the generation of these operations, as a useful optimization or for
-- certification purposes.
+ ---------------------
+ -- Add_Final_Chain --
+ ---------------------
+
+ function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id is
+ Loc : constant Source_Ptr := Sloc (Def_Id);
+ Flist : Entity_Id;
+
+ begin
+ Flist :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (Def_Id), 'L'));
+
+ Append_Freeze_Action (Def_Id,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flist,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_List_Controller), Loc)));
+
+ return Flist;
+ end Add_Final_Chain;
+
--------------------------
-- Adjust_Discriminants --
--------------------------
- -- This procedure attempts to define subtypes for discriminants that
- -- are more restrictive than those declared. Such a replacement is
- -- possible if we can demonstrate that values outside the restricted
- -- range would cause constraint errors in any case. The advantage of
- -- restricting the discriminant types in this way is tha the maximum
- -- size of the variant record can be calculated more conservatively.
+ -- This procedure attempts to define subtypes for discriminants that are
+ -- more restrictive than those declared. Such a replacement is possible if
+ -- we can demonstrate that values outside the restricted range would cause
+ -- constraint errors in any case. The advantage of restricting the
+ -- discriminant types in this way is that the maximum size of the variant
+ -- record can be calculated more conservatively.
-- An example of a situation in which we can perform this type of
-- restriction is the following:
---------------------------
procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
- Loc : constant Source_Ptr := Sloc (Nod);
- Comp_Type : constant Entity_Id := Component_Type (A_Type);
- Index_List : List_Id;
- Proc_Id : Entity_Id;
- Body_Stmts : List_Id;
+ Loc : constant Source_Ptr := Sloc (Nod);
+ Comp_Type : constant Entity_Id := Component_Type (A_Type);
+ Index_List : List_Id;
+ Proc_Id : Entity_Id;
+ Body_Stmts : List_Id;
+ Has_Default_Init : Boolean;
function Init_Component return List_Id;
-- Create one statement to initialize one array component, designated
Name => Comp,
Expression =>
Get_Simple_Init_Val
- (Comp_Type, Loc, Component_Size (A_Type))));
+ (Comp_Type, Nod, Component_Size (A_Type))));
else
+ Clean_Task_Names (Comp_Type, Proc_Id);
return
- Build_Initialization_Call (Loc, Comp, Comp_Type, True, A_Type);
+ Build_Initialization_Call
+ (Loc, Comp, Comp_Type,
+ In_Init_Proc => True,
+ Enclos_Type => A_Type);
end if;
end Init_Component;
-- Start of processing for Build_Array_Init_Proc
begin
- if Suppress_Init_Proc (A_Type) then
+ -- Nothing to generate in the following cases:
+
+ -- 1. Initialization is suppressed for the type
+ -- 2. The type is a value type, in the CIL sense.
+ -- 3. The type has CIL/JVM convention.
+ -- 4. An initialization already exists for the base type
+
+ if Suppress_Init_Proc (A_Type)
+ or else Is_Value_Type (Comp_Type)
+ or else Convention (A_Type) = Convention_CIL
+ or else Convention (A_Type) = Convention_Java
+ or else Present (Base_Init_Proc (A_Type))
+ then
return;
end if;
-- 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
-- the issue arises) in a special manner anyway which does not need an
-- init_proc.
- if Has_Non_Null_Base_Init_Proc (Comp_Type)
- or else Needs_Simple_Initialization (Comp_Type)
- or else Has_Task (Comp_Type)
+ Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
+ or else Needs_Simple_Initialization (Comp_Type)
+ or else Has_Task (Comp_Type);
+
+ if Has_Default_Init
or else (not Restriction_Active (No_Initialize_Scalars)
- and then Is_Public (A_Type)
- and then Root_Type (A_Type) /= Standard_String
- and then Root_Type (A_Type) /= Standard_Wide_String
- and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
+ and then Is_Public (A_Type)
+ and then Root_Type (A_Type) /= Standard_String
+ and then Root_Type (A_Type) /= Standard_Wide_String
+ and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
then
Proc_Id :=
- Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type));
+ Make_Defining_Identifier (Loc,
+ Chars => Make_Init_Proc_Name (A_Type));
+
+ -- If No_Default_Initialization restriction is active, then we don't
+ -- want to build an init_proc, but we need to mark that an init_proc
+ -- would be needed if this restriction was not active (so that we can
+ -- detect attempts to call it), so set a dummy init_proc in place.
+ -- This is only done though when actual default initialization is
+ -- needed (and not done when only Is_Public is True), since otherwise
+ -- objects such as arrays of scalars could be wrongly flagged as
+ -- violating the restriction.
+
+ if Restriction_Active (No_Default_Initialization) then
+ if Has_Default_Init then
+ Set_Init_Proc (A_Type, Proc_Id);
+ end if;
+
+ return;
+ end if;
Body_Stmts := Init_One_Dimension (1);
-- Set inlined unless controlled stuff or tasks around, in which
-- case we do not want to inline, because nested stuff may cause
- -- difficulties in interunit inlining, and furthermore there is
+ -- difficulties in inter-unit inlining, and furthermore there is
-- in any case no point in inlining such complex init procs.
if not Has_Task (Proc_Id)
- and then not Controlled_Type (Proc_Id)
+ and then not Needs_Finalization (Proc_Id)
then
Set_Is_Inlined (Proc_Id);
end if;
Set_Init_Proc (A_Type, Proc_Id);
if List_Length (Body_Stmts) = 1
- and then Nkind (First (Body_Stmts)) = N_Null_Statement
+
+ -- We must skip SCIL nodes because they may have been added to this
+ -- list by Insert_Actions.
+
+ and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
then
Set_Is_Null_Init_Proc (Proc_Id);
+
+ else
+ -- Try to build a static aggregate to initialize statically
+ -- objects of the type. This can only be done for constrained
+ -- one-dimensional arrays with static bounds.
+
+ Set_Static_Initialization
+ (Proc_Id,
+ Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
end if;
end if;
end Build_Array_Init_Proc;
M_Id : Entity_Id;
Decl : Node_Id;
P : Node_Id;
+ Par : Node_Id;
begin
-- Nothing to do if there is no task hierarchy
return;
end if;
+ -- Find declaration that created the access type: either a type
+ -- declaration, or an object declaration with an access definition,
+ -- in which case the type is anonymous.
+
+ if Is_Itype (T) then
+ P := Associated_Node_For_Itype (T);
+ else
+ P := Parent (T);
+ end if;
+
-- Nothing to do if we already built a master entity for this scope
if not Has_Master_Entity (Scope (T)) then
- -- first build the master entity
+ -- First build the master entity
-- _Master : constant Master_Id := Current_Master.all;
- -- and insert it just before the current declaration
+ -- and insert it just before the current declaration.
Decl :=
Make_Object_Declaration (Loc,
Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_Current_Master), Loc)));
- P := Parent (T);
- Insert_Before (P, Decl);
+ Insert_Action (P, Decl);
Analyze (Decl);
Set_Has_Master_Entity (Scope (T));
- -- Now mark the containing scope as a task master
+ -- Now mark the containing scope as a task master. Masters
+ -- associated with return statements are already marked at
+ -- this stage (see Analyze_Subprogram_Body).
- while Nkind (P) /= N_Compilation_Unit loop
- P := Parent (P);
+ if Ekind (Current_Scope) /= E_Return_Statement then
+ Par := P;
+ while Nkind (Par) /= N_Compilation_Unit loop
+ Par := Parent (Par);
-- If we fall off the top, we are at the outer level, and the
-- environment task is our effective master, so nothing to mark.
- if Nkind (P) = N_Task_Body
- or else Nkind (P) = N_Block_Statement
- or else Nkind (P) = N_Subprogram_Body
- then
- Set_Is_Task_Master (P, True);
- exit;
- end if;
- end loop;
+ if Nkind_In
+ (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body)
+ then
+ Set_Is_Task_Master (Par, True);
+ exit;
+ end if;
+ end loop;
+ end if;
end if;
-- Now define the renaming of the master_id
Defining_Identifier => M_Id,
Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
Name => Make_Identifier (Loc, Name_uMaster));
- Insert_Before (Parent (T), Decl);
+ Insert_Before (P, Decl);
Analyze (Decl);
Set_Master_Id (T, M_Id);
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)));
end loop;
Return_Node :=
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
else
Return_Node :=
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
New_Reference_To (Standard_False, Loc));
end if;
Set_Discrete_Choices (Case_Alt_Node, Choice_List);
Return_Node :=
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
New_Reference_To (Standard_True, Loc));
Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
Set_Parameter_Specifications (Spec_Node, Parameter_List);
- Set_Subtype_Mark (Spec_Node,
- New_Reference_To (Standard_Boolean, Loc));
+ Set_Result_Definition (Spec_Node,
+ New_Reference_To (Standard_Boolean, Loc));
Set_Specification (Body_Node, Spec_Node);
Set_Declarations (Body_Node, New_List);
Saved_Enclosing_Func_Id : Entity_Id;
begin
- -- Build the discriminant checking function for each variant, label
- -- all components of that variant with the function's name.
+ -- Build the discriminant-checking function for each variant, and
+ -- label all components of that variant with the function's name.
+ -- We only Generate a discriminant-checking function when the
+ -- variant is not empty, to prevent the creation of dead code.
+ -- The exception to that is when Frontend_Layout_On_Target is set,
+ -- because the variant record size function generated in package
+ -- Layout needs to generate calls to all discriminant-checking
+ -- functions, including those for empty variants.
Discr_Name := Entity (Name (Variant_Part_Node));
Variant := First_Non_Pragma (Variants (Variant_Part_Node));
while Present (Variant) loop
- Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
Component_List_Node := Component_List (Variant);
- if not Null_Present (Component_List_Node) then
+ if not Null_Present (Component_List_Node)
+ or else Frontend_Layout_On_Target
+ then
+ Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
Decl :=
First_Non_Pragma (Component_Items (Component_List_Node));
Parameter_List : constant List_Id := New_List;
D : Entity_Id;
Formal : Entity_Id;
+ Formal_Type : Entity_Id;
Param_Spec_Node : Node_Id;
begin
if Use_Dl then
Formal := Discriminal (D);
+ Formal_Type := Etype (Formal);
else
Formal := Make_Defining_Identifier (Loc, Chars (D));
+ Formal_Type := Etype (D);
end if;
Param_Spec_Node :=
Make_Parameter_Specification (Loc,
Defining_Identifier => Formal,
Parameter_Type =>
- New_Reference_To (Etype (D), Loc));
+ New_Reference_To (Formal_Type, Loc));
Append (Param_Spec_Node, Parameter_List);
Next_Discriminant (D);
end loop;
return Parameter_List;
end Build_Discriminant_Formals;
+ --------------------------------------
+ -- Build_Equivalent_Array_Aggregate --
+ --------------------------------------
+
+ function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (T);
+ Comp_Type : constant Entity_Id := Component_Type (T);
+ Index_Type : constant Entity_Id := Etype (First_Index (T));
+ Proc : constant Entity_Id := Base_Init_Proc (T);
+ Lo, Hi : Node_Id;
+ Aggr : Node_Id;
+ Expr : Node_Id;
+
+ begin
+ if not Is_Constrained (T)
+ or else Number_Dimensions (T) > 1
+ or else No (Proc)
+ then
+ Initialization_Warning (T);
+ return Empty;
+ end if;
+
+ Lo := Type_Low_Bound (Index_Type);
+ Hi := Type_High_Bound (Index_Type);
+
+ if not Compile_Time_Known_Value (Lo)
+ or else not Compile_Time_Known_Value (Hi)
+ then
+ Initialization_Warning (T);
+ return Empty;
+ end if;
+
+ if Is_Record_Type (Comp_Type)
+ and then Present (Base_Init_Proc (Comp_Type))
+ then
+ Expr := Static_Initialization (Base_Init_Proc (Comp_Type));
+
+ if No (Expr) then
+ Initialization_Warning (T);
+ return Empty;
+ end if;
+
+ else
+ Initialization_Warning (T);
+ return Empty;
+ end if;
+
+ Aggr := Make_Aggregate (Loc, No_List, New_List);
+ Set_Etype (Aggr, T);
+ Set_Aggregate_Bounds (Aggr,
+ Make_Range (Loc,
+ Low_Bound => New_Copy (Lo),
+ High_Bound => New_Copy (Hi)));
+ Set_Parent (Aggr, Parent (Proc));
+
+ Append_To (Component_Associations (Aggr),
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (
+ Make_Range (Loc,
+ Low_Bound => New_Copy (Lo),
+ High_Bound => New_Copy (Hi))),
+ Expression => Expr));
+
+ if Static_Array_Aggregate (Aggr) then
+ return Aggr;
+ else
+ Initialization_Warning (T);
+ return Empty;
+ end if;
+ end Build_Equivalent_Array_Aggregate;
+
+ ---------------------------------------
+ -- Build_Equivalent_Record_Aggregate --
+ ---------------------------------------
+
+ function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is
+ Agg : Node_Id;
+ Comp : Entity_Id;
+ Comp_Type : Entity_Id;
+
+ -- Start of processing for Build_Equivalent_Record_Aggregate
+
+ begin
+ if not Is_Record_Type (T)
+ or else Has_Discriminants (T)
+ or else Is_Limited_Type (T)
+ or else Has_Non_Standard_Rep (T)
+ then
+ Initialization_Warning (T);
+ return Empty;
+ end if;
+
+ Comp := First_Component (T);
+
+ -- A null record needs no warning
+
+ if No (Comp) then
+ return Empty;
+ end if;
+
+ while Present (Comp) loop
+
+ -- Array components are acceptable if initialized by a positional
+ -- aggregate with static components.
+
+ if Is_Array_Type (Etype (Comp)) then
+ Comp_Type := Component_Type (Etype (Comp));
+
+ if Nkind (Parent (Comp)) /= N_Component_Declaration
+ or else No (Expression (Parent (Comp)))
+ or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
+ then
+ Initialization_Warning (T);
+ return Empty;
+
+ elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
+ and then
+ (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
+ or else
+ not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
+ then
+ Initialization_Warning (T);
+ return Empty;
+
+ elsif
+ not Static_Array_Aggregate (Expression (Parent (Comp)))
+ then
+ Initialization_Warning (T);
+ return Empty;
+ end if;
+
+ elsif Is_Scalar_Type (Etype (Comp)) then
+ Comp_Type := Etype (Comp);
+
+ if Nkind (Parent (Comp)) /= N_Component_Declaration
+ or else No (Expression (Parent (Comp)))
+ or else not Compile_Time_Known_Value (Expression (Parent (Comp)))
+ or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
+ or else not
+ Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
+ then
+ Initialization_Warning (T);
+ return Empty;
+ end if;
+
+ -- For now, other types are excluded
+
+ else
+ Initialization_Warning (T);
+ return Empty;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ -- All components have static initialization. Build positional aggregate
+ -- from the given expressions or defaults.
+
+ Agg := Make_Aggregate (Sloc (T), New_List, New_List);
+ Set_Parent (Agg, Parent (T));
+
+ Comp := First_Component (T);
+ while Present (Comp) loop
+ Append
+ (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg));
+ Next_Component (Comp);
+ end loop;
+
+ Analyze_And_Resolve (Agg, T);
+ return Agg;
+ end Build_Equivalent_Record_Aggregate;
+
-------------------------------
-- Build_Initialization_Call --
-------------------------------
- -- References to a discriminant inside the record type declaration
- -- can appear either in the subtype_indication to constrain a
- -- record or an array, or as part of a larger expression given for
- -- the initial value of a component. In both of these cases N appears
- -- in the record initialization procedure and needs to be replaced by
- -- the formal parameter of the initialization procedure which
- -- corresponds to that discriminant.
+ -- References to a discriminant inside the record type declaration can
+ -- appear either in the subtype_indication to constrain a record or an
+ -- array, or as part of a larger expression given for the initial value
+ -- of a component. In both of these cases N appears in the record
+ -- initialization procedure and needs to be replaced by the formal
+ -- parameter of the initialization procedure which corresponds to that
+ -- discriminant.
-- In the example below, references to discriminants D1 and D2 in proc_1
-- are replaced by references to formals with the same name
-- (discriminals)
- -- A similar replacement is done for calls to any record
- -- initialization procedure for any components that are themselves
- -- of a record type.
+ -- A similar replacement is done for calls to any record initialization
+ -- procedure for any components that are themselves of a record type.
-- type R (D1, D2 : Integer) is record
-- X : Integer := F * D1;
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
- With_Default_Init : Boolean := False) return List_Id
+ With_Default_Init : Boolean := False;
+ Constructor_Ref : Node_Id := Empty) return List_Id
is
- First_Arg : Node_Id;
+ Res : constant List_Id := New_List;
+ Arg : Node_Id;
Args : List_Id;
- Decls : List_Id;
+ Controller_Typ : Entity_Id;
Decl : Node_Id;
+ Decls : List_Id;
Discr : Entity_Id;
- Arg : Node_Id;
- Proc : constant Entity_Id := Base_Init_Proc (Typ);
- Init_Type : constant Entity_Id := Etype (First_Formal (Proc));
- Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type);
- Res : constant List_Id := New_List;
+ First_Arg : Node_Id;
+ Full_Init_Type : Entity_Id;
Full_Type : Entity_Id := Typ;
- Controller_Typ : Entity_Id;
+ Init_Type : Entity_Id;
+ Proc : Entity_Id;
begin
+ pragma Assert (Constructor_Ref = Empty
+ or else Is_CPP_Constructor_Call (Constructor_Ref));
+
+ if No (Constructor_Ref) then
+ Proc := Base_Init_Proc (Typ);
+ else
+ Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
+ end if;
+
+ pragma Assert (Present (Proc));
+ Init_Type := Etype (First_Formal (Proc));
+ Full_Init_Type := Underlying_Type (Init_Type);
+
-- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
-- is active (in which case we make the call anyway, since in the
-- actual compiled client it may be non null).
+ -- Also nothing to do for value types.
- if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
+ if (Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars)
+ or else Is_Value_Type (Typ)
+ or else
+ (Is_Array_Type (Typ) and then Is_Value_Type (Component_Type (Typ)))
+ then
return Empty_List;
end if;
-- honest. Actually it isn't quite type honest, because there can be
-- conflicts of views in the private type case. That is why we set
-- Conversion_OK in the conversion node.
+
if (Is_Record_Type (Typ)
or else Is_Array_Type (Typ)
or else Is_Private_Type (Typ))
-- for the value 3 (should be rtsfindable constant ???)
Append_To (Args, Make_Integer_Literal (Loc, 3));
+
else
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if;
Strval => ""));
else
- Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
+ Decls :=
+ Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
Decl := Last (Decls);
Append_To (Args,
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;
end if;
- -- Ada 2005 (AI-287) In case of default initialized components,
- -- we need to generate the corresponding selected component node
- -- to access the discriminant value. In other cases this is not
- -- required because we are inside the init proc and we use the
- -- corresponding formal.
+ -- Ada 2005 (AI-287): In case of default initialized components,
+ -- if the component is constrained with a discriminant of the
+ -- enclosing type, we need to generate the corresponding selected
+ -- component node to access the discriminant value. In other cases
+ -- this is not required, either because we are inside the init
+ -- proc and we use the corresponding formal, or else because the
+ -- component is constrained by an expression.
if With_Default_Init
and then Nkind (Id_Ref) = N_Selected_Component
+ and then Nkind (Arg) = N_Identifier
+ and then Ekind (Entity (Arg)) = E_Discriminant
then
Append_To (Args,
Make_Selected_Component (Loc,
and then Chars (Selector_Name (Id_Ref)) = Name_uParent
then
Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
+
+ elsif Present (Constructor_Ref) then
+ Append_List_To (Args,
+ New_Copy_List (Parameter_Associations (Constructor_Ref)));
end if;
Append_To (Res,
Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => Args));
- if Controlled_Type (Typ)
+ if Needs_Finalization (Typ)
and then Nkind (Id_Ref) = N_Selected_Component
then
if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
-- 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.
and then Has_New_Controlled_Component (Enclos_Type)
and then Has_Controlled_Component (Typ)
then
- if Is_Return_By_Reference_Type (Typ) then
+ if Is_Inherently_Limited_Type (Typ) then
Controller_Typ := RTE (RE_Limited_Record_Controller);
else
Controller_Typ := RTE (RE_Record_Controller);
-- Build_Master_Renaming --
---------------------------
- procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is
+ function Build_Master_Renaming
+ (N : Node_Id;
+ T : Entity_Id) return Entity_Id
+ is
Loc : constant Source_Ptr := Sloc (N);
M_Id : Entity_Id;
Decl : Node_Id;
-- Nothing to do if there is no task hierarchy
if Restriction_Active (No_Task_Hierarchy) then
- return;
+ return Empty;
end if;
M_Id :=
Name => Make_Identifier (Loc, Name_uMaster));
Insert_Before (N, Decl);
Analyze (Decl);
+ return M_Id;
+
+ exception
+ when RE_Not_Available =>
+ return Empty;
+ end Build_Master_Renaming;
+
+ ---------------------------
+ -- Build_Master_Renaming --
+ ---------------------------
+
+ procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is
+ M_Id : Entity_Id;
+
+ begin
+ -- Nothing to do if there is no task hierarchy
+ if Restriction_Active (No_Task_Hierarchy) then
+ return;
+ end if;
+
+ M_Id := Build_Master_Renaming (N, T);
Set_Master_Id (T, M_Id);
exception
----------------------------
procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is
- Loc : Source_Ptr := Sloc (N);
- Discr_Map : constant Elist_Id := New_Elmt_List;
- Proc_Id : Entity_Id;
- Rec_Type : Entity_Id;
- Set_Tag : Entity_Id := Empty;
-
- ADT : Elmt_Id;
- Aux_N : Node_Id;
- Aux_Comp : Node_Id;
+ Loc : Source_Ptr := Sloc (N);
+ Discr_Map : constant Elist_Id := New_Elmt_List;
+ Proc_Id : Entity_Id;
+ Rec_Type : Entity_Id;
+ Set_Tag : Entity_Id := Empty;
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
- -- Build a assignment statement node which assigns to record
- -- component its default expression if defined. The left hand side
- -- of the assignment is marked Assignment_OK so that initialization
- -- of limited private records works correctly, Return also the
- -- adjustment call for controlled objects
+ -- Build a assignment statement node which assigns to record component
+ -- its default expression if defined. The assignment left hand side is
+ -- marked Assignment_OK so that initialization of limited private
+ -- records works correctly, Return also the adjustment call for
+ -- controlled objects
procedure Build_Discriminant_Assignments (Statement_List : List_Id);
-- If the record has discriminants, adds assignment statements to
-- of the initialization procedure (by calling all the preceding
-- auxiliary routines), and install it as the _init TSS.
+ procedure Build_Offset_To_Top_Functions;
+ -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
+ -- and body of the Offset_To_Top function that is generated when the
+ -- parent of a type with discriminants has secondary dispatch tables.
+
procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
- -- Add range checks to components of disciminated records. S is a
+ -- Add range checks to components of discriminated records. S is a
-- subtype indication of a record component. Check_List is a list
-- to which the check actions are appended.
(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
Attribute_Name => Name_Unrestricted_Access);
end if;
- -- Ada 2005 (AI-231): Generate conversion to the null-excluding
- -- type to force the corresponding run-time check.
+ -- Take a copy of Exp to ensure that later copies of this component
+ -- declaration in derived types see the original tree, not a node
+ -- rewritten during expansion of the init_proc. If the copy contains
+ -- itypes, the scope of the new itypes is the init_proc being built.
- if Ada_Version >= Ada_05
- and then Can_Never_Be_Null (Etype (Id)) -- Lhs
- and then Present (Etype (Exp))
- and then not Can_Never_Be_Null (Etype (Exp))
- then
- Rewrite (Exp, Convert_To (Etype (Id), Relocate_Node (Exp)));
- Analyze_And_Resolve (Exp, Etype (Id));
- 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.
-
- Exp := New_Copy_Tree (Exp);
+ Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
Res := New_List (
Make_Assignment_Statement (Loc,
Set_No_Ctrl_Actions (First (Res));
-- Adjust the tag if tagged (because of possible view conversions).
- -- Suppress the tag adjustment when Java_VM because JVM tags are
+ -- Suppress the tag adjustment when VM_Target because VM tags are
-- represented implicitly in objects.
- if Is_Tagged_Type (Typ) and then not Java_VM then
+ if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
Append_To (Res,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Lhs),
+ Prefix => New_Copy_Tree (Lhs, New_Scope => Proc_Id),
Selector_Name =>
New_Reference_To (First_Tag_Component (Typ), Loc)),
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc))));
end if;
- -- Adjust the component if controlled except if it is an
- -- aggregate that will be expanded inline
+ -- Adjust the component if controlled except if it is an aggregate
+ -- that will be expanded inline.
if Kind = N_Qualified_Expression then
Kind := Nkind (Expression (N));
end if;
- if Controlled_Type (Typ)
- and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate)
+ if Needs_Finalization (Typ)
+ and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
+ and then not Is_Inherently_Limited_Type (Typ)
then
- Append_List_To (Res,
- Make_Adjust_Call (
- Ref => New_Copy_Tree (Lhs),
- Typ => Etype (Id),
- Flist_Ref =>
- Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)),
- With_Attach => Make_Integer_Literal (Loc, 1)));
+ declare
+ Ref : constant Node_Id :=
+ New_Copy_Tree (Lhs, New_Scope => Proc_Id);
+ begin
+ Append_List_To (Res,
+ Make_Adjust_Call (
+ Ref => Ref,
+ Typ => Etype (Id),
+ Flist_Ref => Find_Final_List (Etype (Id), Ref),
+ With_Attach => Make_Integer_Literal (Loc, 1)));
+ end;
end if;
return Res;
D := First_Discriminant (Rec_Type);
while Present (D) loop
+
-- Don't generate the assignment for discriminants in derived
-- tagged types if the discriminant is a renaming of some
- -- ancestor discriminant. This initialization will be done
+ -- ancestor discriminant. This initialization will be done
-- when initializing the _parent field of the derived record.
if Is_Tagged and then
New_Reference_To (Discriminal (Entity (Arg)), Loc));
-- Case of access discriminants. We replace the reference
- -- to the type by a reference to the actual object
+ -- to the type by a reference to the actual object.
--- ??? why is this code deleted without comment
-
--- elsif Nkind (Arg) = N_Attribute_Reference
--- and then Is_Entity_Name (Prefix (Arg))
--- and then Is_Type (Entity (Prefix (Arg)))
--- then
--- Append_To (Args,
--- Make_Attribute_Reference (Loc,
--- Prefix => New_Copy (Prefix (Id_Ref)),
--- Attribute_Name => Name_Unrestricted_Access));
+ -- Is above comment right??? Use of New_Copy below seems mighty
+ -- suspicious ???
else
Append_To (Args, New_Copy (Arg));
return Res;
end Build_Init_Call_Thru;
+ -----------------------------------
+ -- Build_Offset_To_Top_Functions --
+ -----------------------------------
+
+ procedure Build_Offset_To_Top_Functions is
+
+ procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
+ -- Generate:
+ -- function Fxx (O : in Rec_Typ) return Storage_Offset is
+ -- begin
+ -- return O.Iface_Comp'Position;
+ -- end Fxx;
+
+ ----------------------------------
+ -- Build_Offset_To_Top_Function --
+ ----------------------------------
+
+ procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
+ Body_Node : Node_Id;
+ Func_Id : Entity_Id;
+ Spec_Node : Node_Id;
+
+ begin
+ Func_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('F'));
+
+ Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
+
+ -- Generate
+ -- function Fxx (O : in Rec_Typ) return Storage_Offset;
+
+ Spec_Node := New_Node (N_Function_Specification, Loc);
+ Set_Defining_Unit_Name (Spec_Node, Func_Id);
+ Set_Parameter_Specifications (Spec_Node, New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
+ In_Present => True,
+ Parameter_Type => New_Reference_To (Rec_Type, Loc))));
+ Set_Result_Definition (Spec_Node,
+ New_Reference_To (RTE (RE_Storage_Offset), Loc));
+
+ -- Generate
+ -- function Fxx (O : in Rec_Typ) return Storage_Offset is
+ -- begin
+ -- return O.Iface_Comp'Position;
+ -- end Fxx;
+
+ Body_Node := New_Node (N_Subprogram_Body, Loc);
+ Set_Specification (Body_Node, Spec_Node);
+ Set_Declarations (Body_Node, New_List);
+ Set_Handled_Statement_Sequence (Body_Node,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uO),
+ Selector_Name => New_Reference_To
+ (Iface_Comp, Loc)),
+ Attribute_Name => Name_Position)))));
+
+ Set_Ekind (Func_Id, E_Function);
+ Set_Mechanism (Func_Id, Default_Mechanism);
+ Set_Is_Internal (Func_Id, True);
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (Func_Id);
+ end if;
+
+ Analyze (Body_Node);
+
+ Append_Freeze_Action (Rec_Type, Body_Node);
+ end Build_Offset_To_Top_Function;
+
+ -- Local variables
+
+ Ifaces_Comp_List : Elist_Id;
+ Iface_Comp_Elmt : Elmt_Id;
+ Iface_Comp : Node_Id;
+
+ -- Start of processing for Build_Offset_To_Top_Functions
+
+ begin
+ -- Offset_To_Top_Functions are built only for derivations of types
+ -- with discriminants that cover interface types.
+ -- Nothing is needed either in case of virtual machines, since
+ -- interfaces are handled directly by the VM.
+
+ if not Is_Tagged_Type (Rec_Type)
+ or else Etype (Rec_Type) = Rec_Type
+ or else not Has_Discriminants (Etype (Rec_Type))
+ or else not Tagged_Type_Expansion
+ then
+ return;
+ end if;
+
+ Collect_Interface_Components (Rec_Type, Ifaces_Comp_List);
+
+ -- For each interface type with secondary dispatch table we generate
+ -- the Offset_To_Top_Functions (required to displace the pointer in
+ -- interface conversions)
+
+ Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
+ while Present (Iface_Comp_Elmt) loop
+ Iface_Comp := Node (Iface_Comp_Elmt);
+ pragma Assert (Is_Interface (Related_Type (Iface_Comp)));
+
+ -- If the interface is a parent of Rec_Type it shares the primary
+ -- dispatch table and hence there is no need to build the function
+
+ if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type) then
+ Build_Offset_To_Top_Function (Iface_Comp);
+ end if;
+
+ Next_Elmt (Iface_Comp_Elmt);
+ end loop;
+ end Build_Offset_To_Top_Functions;
+
--------------------------
-- Build_Init_Procedure --
--------------------------
Proc_Spec_Node : Node_Id;
Body_Stmts : List_Id;
Record_Extension_Node : Node_Id;
- Init_Tag : Node_Id;
+ Init_Tags_List : List_Id;
begin
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
-
- Proc_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Make_Init_Proc_Name (Rec_Type));
Set_Ekind (Proc_Id, E_Procedure);
Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
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,
if Parent_Subtype_Renaming_Discrims then
-- N is a Derived_Type_Definition that renames the parameters
- -- of the ancestor type. We init it by expanding our discrims
- -- and call the ancestor _init_proc with a type-converted object
+ -- of the ancestor type. We initialize it by expanding our
+ -- discriminants and call the ancestor _init_proc with a
+ -- type-converted object
Append_List_To (Body_Stmts,
Build_Init_Call_Thru (Parameters));
-- Add here the assignment to instantiate the Tag
- -- The assignement corresponds to the code:
+ -- The assignment corresponds to the code:
-- _Init._Tag := Typ'Tag;
- -- Suppress the tag assignment when Java_VM because JVM tags are
- -- represented implicitly in objects.
+ -- Suppress the tag assignment when VM_Target because VM tags are
+ -- represented implicitly in objects. It is also suppressed in case
+ -- of CPP_Class types because in this case the tag is initialized in
+ -- the C++ side.
if Is_Tagged_Type (Rec_Type)
and then not Is_CPP_Class (Rec_Type)
- and then not Java_VM
+ and then Tagged_Type_Expansion
+ and then not No_Run_Time_Mode
then
- Init_Tag :=
+ -- Initialize the primary tag
+
+ Init_Tags_List := New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Expression =>
New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc));
+ (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
+
+ -- Generate the SCIL node associated with the initialization of
+ -- the tag component.
+
+ if Generate_SCIL then
+ declare
+ New_Node : Node_Id;
+
+ begin
+ New_Node :=
+ Make_SCIL_Tag_Init (Sloc (First (Init_Tags_List)));
+ Set_SCIL_Related_Node (New_Node, First (Init_Tags_List));
+ Set_SCIL_Entity (New_Node, Rec_Type);
+ Prepend_To (Init_Tags_List, New_Node);
+ end;
+ end if;
+
+ -- Ada 2005 (AI-251): Initialize the secondary tags components
+ -- located at fixed positions (tags whose position depends on
+ -- variable size components are initialized later ---see below).
+
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Rec_Type)
+ and then Has_Interfaces (Rec_Type)
+ then
+ Init_Secondary_Tags
+ (Typ => Rec_Type,
+ Target => Make_Identifier (Loc, Name_uInit),
+ Stmts_List => Init_Tags_List,
+ Fixed_Comps => True,
+ Variable_Comps => False);
+ end if;
-- The tag must be inserted before the assignments to other
-- components, because the initial value of the component may
- -- depend ot the tag (eg. through a dispatching operation on
+ -- depend on the tag (eg. through a dispatching operation on
-- an access to the current type). The tag assignment is not done
-- when initializing the parent component of a type extension,
-- because in that case the tag is set in the extension.
+
-- Extensions of imported C++ classes add a final complication,
-- because we cannot inhibit tag setting in the constructor for
-- the parent. In that case we insert the tag initialization
-- after the calls to initialize the parent.
- Init_Tag :=
- Make_If_Statement (Loc,
- Condition => New_Occurrence_Of (Set_Tag, Loc),
- Then_Statements => New_List (Init_Tag));
-
- if not Is_CPP_Class (Etype (Rec_Type)) then
- Prepend_To (Body_Stmts, Init_Tag);
-
- -- Ada 2005 (AI-251): Initialization of all the tags
- -- corresponding with abstract interfaces
+ if not Is_CPP_Class (Root_Type (Rec_Type)) then
+ Prepend_To (Body_Stmts,
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Set_Tag, Loc),
+ Then_Statements => Init_Tags_List));
- if Present (First_Tag_Component (Rec_Type)) then
-
- -- Skip the first _Tag, which is the main tag of the
- -- tagged type. Following tags correspond with abstract
- -- interfaces.
-
- Aux_Comp :=
- Next_Tag_Component (First_Tag_Component (Rec_Type));
-
- ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type)));
- while Present (ADT) loop
- Aux_N := Node (ADT);
-
- -- Initialize the pointer to the secondary DT associated
- -- with the interface
-
- Append_To (Body_Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name =>
- New_Reference_To (Aux_Comp, Loc)),
- Expression =>
- New_Reference_To (Aux_N, Loc)));
-
- -- Generate:
- -- Set_Offset_To_Top (DT_Ptr, n);
-
- Append_To (Body_Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Set_Offset_To_Top),
- Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Aux_N, Loc)),
- Unchecked_Convert_To (RTE (RE_Storage_Offset),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc,
- Name_uInit),
- Selector_Name => New_Reference_To
- (Aux_Comp, Loc)),
- Attribute_Name => Name_Position)))));
-
- Aux_Comp := Next_Tag_Component (Aux_Comp);
- Next_Elmt (ADT);
- end loop;
- end if;
+ -- CPP_Class derivation: In this case the dispatch table of the
+ -- parent was built in the C++ side and we copy the table of the
+ -- parent to initialize the new dispatch table.
else
declare
- Nod : Node_Id := First (Body_Stmts);
+ Nod : Node_Id;
begin
-- We assume the first init_proc call is for the parent
+ Nod := First (Body_Stmts);
while Present (Next (Nod))
and then (Nkind (Nod) /= N_Procedure_Call_Statement
or else not Is_Init_Proc (Name (Nod)))
Nod := Next (Nod);
end loop;
- Insert_After (Nod, Init_Tag);
+ -- Generate:
+ -- ancestor_constructor (_init.parent);
+ -- if Arg2 then
+ -- inherit_prim_ops (_init._tag, new_dt, num_prims);
+ -- _init._tag := new_dt;
+ -- end if;
+
+ Prepend_To (Init_Tags_List,
+ Build_Inherit_Prims (Loc,
+ Typ => Rec_Type,
+ Old_Tag_Node =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc,
+ Chars => Name_uInit),
+ Selector_Name =>
+ New_Reference_To
+ (First_Tag_Component (Rec_Type), Loc)),
+ New_Tag_Node =>
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Rec_Type))),
+ Loc),
+ Num_Prims =>
+ UI_To_Int
+ (DT_Entry_Count (First_Tag_Component (Rec_Type)))));
+
+ Insert_After (Nod,
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Set_Tag, Loc),
+ Then_Statements => Init_Tags_List));
+
+ -- We have inherited table of the parent from the CPP side.
+ -- Now we fill the slots associated with Ada primitives.
+ -- This needs more work to avoid its execution each time
+ -- an object is initialized???
+
+ declare
+ E : Elmt_Id;
+ Prim : Node_Id;
+
+ begin
+ E := First_Elmt (Primitive_Operations (Rec_Type));
+ while Present (E) loop
+ Prim := Node (E);
+
+ if not Is_Imported (Prim)
+ and then Convention (Prim) = Convention_CPP
+ and then not Present (Interface_Alias (Prim))
+ then
+ Append_List_To (Init_Tags_List,
+ Register_Primitive (Loc, Prim => Prim));
+ end if;
+
+ Next_Elmt (E);
+ end loop;
+ end;
end;
end if;
+
+ -- Ada 2005 (AI-251): Initialize the secondary tag components
+ -- located at variable positions. We delay the generation of this
+ -- code until here because the value of the attribute 'Position
+ -- applied to variable size components of the parent type that
+ -- depend on discriminants is only safely read at runtime after
+ -- the parent components have been initialized.
+
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Rec_Type)
+ and then Has_Interfaces (Rec_Type)
+ and then Has_Discriminants (Etype (Rec_Type))
+ and then Is_Variable_Size_Record (Etype (Rec_Type))
+ then
+ Init_Tags_List := New_List;
+
+ Init_Secondary_Tags
+ (Typ => Rec_Type,
+ Target => Make_Identifier (Loc, Name_uInit),
+ Stmts_List => Init_Tags_List,
+ Fixed_Comps => False,
+ Variable_Comps => True);
+
+ if Is_Non_Empty_List (Init_Tags_List) then
+ Append_List_To (Body_Stmts, Init_Tags_List);
+ end if;
+ end if;
end if;
Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
Set_Init_Proc (Rec_Type, Proc_Id);
if List_Length (Body_Stmts) = 1
- and then Nkind (First (Body_Stmts)) = N_Null_Statement
+
+ -- We must skip SCIL nodes because they may have been added to this
+ -- list by Insert_Actions.
+
+ and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
+ and then VM_Target = No_VM
then
+ -- Even though the init proc may be null at this time it might get
+ -- some stuff added to it later by the VM backend.
+
Set_Is_Null_Init_Proc (Proc_Id);
end if;
end Build_Init_Procedure;
function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
Check_List : constant List_Id := New_List;
Alt_List : List_Id;
+ Decl : Node_Id;
+ Id : Entity_Id;
+ Names : Node_Id;
Statement_List : List_Id;
Stmts : List_Id;
+ Typ : Entity_Id;
+ Variant : Node_Id;
Per_Object_Constraint_Components : Boolean;
- Decl : Node_Id;
- Variant : Node_Id;
-
- Id : Entity_Id;
- Typ : Entity_Id;
-
function Has_Access_Constraint (E : Entity_Id) return Boolean;
-- Components with access discriminants that depend on the current
-- instance must be initialized after all other components.
Statement_List := New_List;
- -- Loop through components, skipping pragmas, in 2 steps. The first
- -- step deals with regular components. The second step deals with
- -- components have per object constraints, and no explicit initia-
- -- lization.
+ -- Loop through visible declarations of task types and protected
+ -- types moving any expanded code from the spec to the body of the
+ -- init procedure.
- Per_Object_Constraint_Components := False;
+ if Is_Task_Record_Type (Rec_Type)
+ or else Is_Protected_Record_Type (Rec_Type)
+ then
+ declare
+ Decl : constant Node_Id :=
+ Parent (Corresponding_Concurrent_Type (Rec_Type));
+ Def : Node_Id;
+ N1 : Node_Id;
+ N2 : Node_Id;
- -- First step : regular components
+ begin
+ if Is_Task_Record_Type (Rec_Type) then
+ Def := Task_Definition (Decl);
+ else
+ Def := Protected_Definition (Decl);
+ end if;
- Decl := First_Non_Pragma (Component_Items (Comp_List));
- while Present (Decl) loop
+ if Present (Def) then
+ N1 := First (Visible_Declarations (Def));
+ while Present (N1) loop
+ N2 := N1;
+ N1 := Next (N1);
+
+ if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
+ or else Nkind (N2) in N_Raise_xxx_Error
+ or else Nkind (N2) = N_Procedure_Call_Statement
+ then
+ Append_To (Statement_List,
+ New_Copy_Tree (N2, New_Scope => Proc_Id));
+ Rewrite (N2, Make_Null_Statement (Sloc (N2)));
+ Analyze (N2);
+ end if;
+ end loop;
+ end if;
+ end;
+ end if;
+
+ -- Loop through components, skipping pragmas, in 2 steps. The first
+ -- step deals with regular components. The second step deals with
+ -- components have per object constraints, and no explicit initia-
+ -- lization.
+
+ Per_Object_Constraint_Components := False;
+
+ -- First step : regular components
+
+ Decl := First_Non_Pragma (Component_Items (Comp_List));
+ while Present (Decl) loop
Loc := Sloc (Decl);
Build_Record_Checks
(Subtype_Indication (Component_Definition (Decl)), Check_List);
-- Case of explicit initialization
if Present (Expression (Decl)) then
- Stmts := Build_Assignment (Id, Expression (Decl));
+ if Is_CPP_Constructor_Call (Expression (Decl)) then
+ Stmts :=
+ Build_Initialization_Call
+ (Loc,
+ Id_Ref =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Loc)),
+ Typ => Typ,
+ In_Init_Proc => True,
+ Enclos_Type => Rec_Type,
+ Discr_Map => Discr_Map,
+ Constructor_Ref => Expression (Decl));
+ else
+ Stmts := Build_Assignment (Id, Expression (Decl));
+ end if;
-- Case of composite component with its own Init_Proc
- elsif Has_Non_Null_Base_Init_Proc (Typ) then
+ elsif not Is_Interface (Typ)
+ and then Has_Non_Null_Base_Init_Proc (Typ)
+ then
Stmts :=
Build_Initialization_Call
(Loc,
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => New_Occurrence_Of (Id, Loc)),
- Typ,
- True,
- Rec_Type,
- Discr_Map => Discr_Map);
+ Id_Ref =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Loc)),
+ Typ => Typ,
+ In_Init_Proc => True,
+ Enclos_Type => Rec_Type,
+ Discr_Map => Discr_Map);
+
+ Clean_Task_Names (Typ, Proc_Id);
-- Case of component needing simple initialization
elsif Component_Needs_Simple_Initialization (Typ) then
Stmts :=
Build_Assignment
- (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id)));
+ (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)));
-- Nothing needed for this case
-- the _Parent field is attached to it when the attachment
-- can occur. It does not work to simply initialize the
-- controller first: it must be initialized after the parent
- -- if the parent holds discriminants that can be used
- -- to compute the offset of the controller. We assume here
- -- that the last statement of the initialization call is the
- -- attachement of the parent (see Build_Initialization_Call)
+ -- if the parent holds discriminants that can be used to
+ -- compute the offset of the controller. We assume here that
+ -- the last statement of the initialization call is the
+ -- attachment of the parent (see Build_Initialization_Call)
if Chars (Id) = Name_uController
and then Rec_Type /= Etype (Rec_Type)
and then Has_Controlled_Component (Etype (Rec_Type))
and then Has_New_Controlled_Component (Rec_Type)
+ and then Present (Last (Statement_List))
then
Insert_List_Before (Last (Statement_List), Stmts);
else
Next_Non_Pragma (Decl);
end loop;
- if Per_Object_Constraint_Components then
-
- -- Second pass: components with per-object constraints
-
- Decl := First_Non_Pragma (Component_Items (Comp_List));
-
- while Present (Decl) loop
- Loc := Sloc (Decl);
- Id := Defining_Identifier (Decl);
- Typ := Etype (Id);
-
- if Has_Access_Constraint (Id)
- and then No (Expression (Decl))
- then
- if Has_Non_Null_Base_Init_Proc (Typ) then
- Append_List_To (Statement_List,
- Build_Initialization_Call (Loc,
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => New_Occurrence_Of (Id, Loc)),
- Typ, True, Rec_Type, Discr_Map => Discr_Map));
-
- elsif Component_Needs_Simple_Initialization (Typ) then
- Append_List_To (Statement_List,
- Build_Assignment
- (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))));
- end if;
- end if;
-
- Next_Non_Pragma (Decl);
- end loop;
- end if;
-
- -- Process the variant part
-
- if Present (Variant_Part (Comp_List)) then
- Alt_List := New_List;
- Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
-
- while Present (Variant) loop
- Loc := Sloc (Variant);
- Append_To (Alt_List,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices =>
- New_Copy_List (Discrete_Choices (Variant)),
- Statements =>
- Build_Init_Statements (Component_List (Variant))));
-
- Next_Non_Pragma (Variant);
- end loop;
-
- -- The expression of the case statement which is a reference
- -- to one of the discriminants is replaced by the appropriate
- -- formal parameter of the initialization procedure.
-
- Append_To (Statement_List,
- Make_Case_Statement (Loc,
- Expression =>
- New_Reference_To (Discriminal (
- Entity (Name (Variant_Part (Comp_List)))), Loc),
- Alternatives => Alt_List));
- end if;
+ -- Set up tasks and protected object support. This needs to be done
+ -- before any component with a per-object access discriminant
+ -- constraint, or any variant part (which may contain such
+ -- components) is initialized, because the initialization of these
+ -- components may reference the enclosing concurrent object.
-- For a task record type, add the task create call and calls
-- to bind any interrupt (signal) entries.
Append_To (Statement_List, Make_Task_Create_Call (Rec_Type));
+ -- Generate the statements which map a string entry name to a
+ -- task entry index. Note that the task may not have entries.
+
+ if Entry_Names_OK then
+ Names := Build_Entry_Names (Rec_Type);
+
+ if Present (Names) then
+ Append_To (Statement_List, Names);
+ end if;
+ end if;
+
declare
Task_Type : constant Entity_Id :=
Corresponding_Concurrent_Type (Rec_Type);
if Is_Protected_Record_Type (Rec_Type) then
Append_List_To (Statement_List,
Make_Initialize_Protection (Rec_Type));
+
+ -- Generate the statements which map a string entry name to a
+ -- protected entry index. Note that the protected type may not
+ -- have entries.
+
+ if Entry_Names_OK then
+ Names := Build_Entry_Names (Rec_Type);
+
+ if Present (Names) then
+ Append_To (Statement_List, Names);
+ end if;
+ end if;
+ end if;
+
+ if Per_Object_Constraint_Components then
+
+ -- Second pass: components with per-object constraints
+
+ Decl := First_Non_Pragma (Component_Items (Comp_List));
+ while Present (Decl) loop
+ Loc := Sloc (Decl);
+ Id := Defining_Identifier (Decl);
+ Typ := Etype (Id);
+
+ if Has_Access_Constraint (Id)
+ and then No (Expression (Decl))
+ then
+ if Has_Non_Null_Base_Init_Proc (Typ) then
+ Append_List_To (Statement_List,
+ Build_Initialization_Call (Loc,
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Loc)),
+ Typ,
+ In_Init_Proc => True,
+ Enclos_Type => Rec_Type,
+ Discr_Map => Discr_Map));
+
+ Clean_Task_Names (Typ, Proc_Id);
+
+ elsif Component_Needs_Simple_Initialization (Typ) then
+ Append_List_To (Statement_List,
+ Build_Assignment
+ (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
+ end if;
+ end if;
+
+ Next_Non_Pragma (Decl);
+ end loop;
+ end if;
+
+ -- Process the variant part
+
+ if Present (Variant_Part (Comp_List)) then
+ Alt_List := New_List;
+ Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
+ while Present (Variant) loop
+ Loc := Sloc (Variant);
+ Append_To (Alt_List,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices =>
+ New_Copy_List (Discrete_Choices (Variant)),
+ Statements =>
+ Build_Init_Statements (Component_List (Variant))));
+ Next_Non_Pragma (Variant);
+ end loop;
+
+ -- The expression of the case statement which is a reference
+ -- to one of the discriminants is replaced by the appropriate
+ -- formal parameter of the initialization procedure.
+
+ Append_To (Statement_List,
+ Make_Case_Statement (Loc,
+ Expression =>
+ New_Reference_To (Discriminal (
+ Entity (Name (Variant_Part (Comp_List)))), Loc),
+ Alternatives => Alt_List));
end if;
-- If no initializations when generated for component declarations
return
Needs_Simple_Initialization (T)
and then not Is_RTE (T, RE_Tag)
- and then not Is_RTE (T, RE_Vtable_Ptr)
- and then not Is_RTE (T, RE_Interface_Tag); -- Ada 2005 (AI-251)
+
+ -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
+
+ and then not Is_RTE (T, RE_Interface_Tag);
end Component_Needs_Simple_Initialization;
---------------------
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);
return False;
end if;
+ -- If it is a type derived from a type with unknown discriminants,
+ -- we cannot build an initialization procedure for it.
+
+ if Has_Unknown_Discriminants (Rec_Id)
+ or else Has_Unknown_Discriminants (Etype (Rec_Id))
+ then
+ return False;
+ end if;
+
-- Otherwise we need to generate an initialization procedure if
-- Is_CPP_Class is False and at least one of the following applies:
-- since the call is generated, there had better be a routine
-- at the other end of the call, even if it does nothing!)
- -- Note: the reason we exclude the CPP_Class case is ???
+ -- Note: the reason we exclude the CPP_Class case is because in this
+ -- case the initialization is performed in the C++ side.
if Is_CPP_Class (Rec_Id) then
return False;
- elsif not Restriction_Active (No_Initialize_Scalars)
- and then Is_Public (Rec_Id)
- then
- return True;
+ elsif Is_Interface (Rec_Id) then
+ return False;
elsif (Has_Discriminants (Rec_Id)
and then not Is_Unchecked_Union (Rec_Id))
end if;
Id := First_Component (Rec_Id);
-
while Present (Id) loop
Comp_Decl := Parent (Id);
Typ := Etype (Id);
Next_Component (Id);
end loop;
+ -- As explained above, a record initialization procedure is needed
+ -- for public types in case Initialize_Scalars applies to a client.
+ -- However, such a procedure is not needed in the case where either
+ -- of restrictions No_Initialize_Scalars or No_Default_Initialization
+ -- applies. No_Initialize_Scalars excludes the possibility of using
+ -- Initialize_Scalars in any partition, and No_Default_Initialization
+ -- implies that no initialization should ever be done for objects of
+ -- the type, so is incompatible with Initialize_Scalars.
+
+ if not Restriction_Active (No_Initialize_Scalars)
+ and then not Restriction_Active (No_Default_Initialization)
+ and then Is_Public (Rec_Id)
+ then
+ return True;
+ end if;
+
return False;
end Requires_Init_Proc;
-- Start of processing for Build_Record_Init_Proc
begin
+ -- Check for value type, which means no initialization required
+
Rec_Type := Defining_Identifier (N);
+ if Is_Value_Type (Rec_Type) then
+ return;
+ end if;
+
-- This may be full declaration of a private type, in which case
-- the visible entity is a record, and the private entity has been
-- exchanged with it in the private part of the current package.
-- If there are discriminants, build the discriminant map to replace
-- discriminants by their discriminals in complex bound expressions.
- -- These only arise for the corresponding records of protected types.
+ -- These only arise for the corresponding records of synchronized types.
if Is_Concurrent_Record_Type (Rec_Type)
and then Has_Discriminants (Rec_Type)
then
declare
Disc : Entity_Id;
-
begin
Disc := First_Discriminant (Rec_Type);
-
while Present (Disc) loop
Append_Elmt (Disc, Discr_Map);
Append_Elmt (Discriminal (Disc), Discr_Map);
elsif Requires_Init_Proc (Rec_Type)
or else Is_Unchecked_Union (Rec_Type)
then
+ Proc_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_Init_Proc_Name (Rec_Type));
+
+ -- If No_Default_Initialization restriction is active, then we don't
+ -- want to build an init_proc, but we need to mark that an init_proc
+ -- would be needed if this restriction was not active (so that we can
+ -- detect attempts to call it), so set a dummy init_proc in place.
+
+ if Restriction_Active (No_Default_Initialization) then
+ Set_Init_Proc (Rec_Type, Proc_Id);
+ return;
+ end if;
+
+ Build_Offset_To_Top_Functions;
Build_Init_Procedure;
Set_Is_Public (Proc_Id, Is_Public (Pe));
if not Is_Concurrent_Type (Rec_Type)
and then not Has_Task (Rec_Type)
- and then not Controlled_Type (Rec_Type)
+ and then not Needs_Finalization (Rec_Type)
then
Set_Is_Inlined (Proc_Id);
end if;
if not Debug_Generated_Code then
Set_Debug_Info_Off (Proc_Id);
end if;
+
+ declare
+ Agg : constant Node_Id :=
+ Build_Equivalent_Record_Aggregate (Rec_Type);
+
+ procedure Collect_Itypes (Comp : Node_Id);
+ -- Generate references to itypes in the aggregate, because
+ -- the first use of the aggregate may be in a nested scope.
+
+ --------------------
+ -- Collect_Itypes --
+ --------------------
+
+ procedure Collect_Itypes (Comp : Node_Id) is
+ Ref : Node_Id;
+ Sub_Aggr : Node_Id;
+ Typ : constant Entity_Id := Etype (Comp);
+
+ begin
+ if Is_Array_Type (Typ)
+ and then Is_Itype (Typ)
+ then
+ Ref := Make_Itype_Reference (Loc);
+ Set_Itype (Ref, Typ);
+ Append_Freeze_Action (Rec_Type, Ref);
+
+ Ref := Make_Itype_Reference (Loc);
+ Set_Itype (Ref, Etype (First_Index (Typ)));
+ Append_Freeze_Action (Rec_Type, Ref);
+
+ Sub_Aggr := First (Expressions (Comp));
+
+ -- Recurse on nested arrays
+
+ while Present (Sub_Aggr) loop
+ Collect_Itypes (Sub_Aggr);
+ Next (Sub_Aggr);
+ end loop;
+ end if;
+ end Collect_Itypes;
+
+ begin
+ -- If there is a static initialization aggregate for the type,
+ -- generate itype references for the types of its (sub)components,
+ -- to prevent out-of-scope errors in the resulting tree.
+ -- The aggregate may have been rewritten as a Raise node, in which
+ -- case there are no relevant itypes.
+
+ if Present (Agg)
+ and then Nkind (Agg) = N_Aggregate
+ then
+ Set_Static_Initialization (Proc_Id, Agg);
+
+ declare
+ Comp : Node_Id;
+ begin
+ Comp := First (Component_Associations (Agg));
+ while Present (Comp) loop
+ Collect_Itypes (Expression (Comp));
+ Next (Comp);
+ end loop;
+ end;
+ end if;
+ end;
end if;
end Build_Record_Init_Proc;
-- Generates the following subprogram:
-- procedure Assign
- -- (Source, Target : Array_Type,
- -- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index;
- -- Rev : Boolean)
+ -- (Source, Target : Array_Type,
+ -- Left_Lo, Left_Hi : Index;
+ -- Right_Lo, Right_Hi : Index;
+ -- Rev : Boolean)
-- is
-- Li1 : Index;
-- Ri1 : Index;
-- begin
+
+ -- if Left_Hi < Left_Lo then
+ -- return;
+ -- end if;
+
-- if Rev then
-- Li1 := Left_Hi;
-- Ri1 := Right_Hi;
-- end if;
-- loop
- -- if Rev then
- -- exit when Li1 < Left_Lo;
- -- else
- -- exit when Li1 > Left_Hi;
- -- end if;
-
- -- Target (Li1) := Source (Ri1);
-
- -- if Rev then
- -- Li1 := Index'pred (Li1);
- -- Ri1 := Index'pred (Ri1);
- -- else
- -- Li1 := Index'succ (Li1);
- -- Ri1 := Index'succ (Ri1);
- -- end if;
+ -- Target (Li1) := Source (Ri1);
+
+ -- if Rev then
+ -- exit when Li1 = Left_Lo;
+ -- Li1 := Index'pred (Li1);
+ -- Ri1 := Index'pred (Ri1);
+ -- else
+ -- exit when Li1 = Left_Hi;
+ -- Li1 := Index'succ (Li1);
+ -- Ri1 := Index'succ (Ri1);
+ -- end if;
-- end loop;
-- end Assign;
Stats := New_List;
+ -- Build test for empty slice case
+
+ Append_To (Stats,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Lt (Loc,
+ Left_Opnd => New_Occurrence_Of (Left_Hi, Loc),
+ Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
+ Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
+
-- Build initializations for indices
declare
Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
End_Label => Empty);
- -- Build exit condition
+ -- Build the exit condition and increment/decrement statements
declare
F_Ass : constant List_Id := New_List;
Append_To (F_Ass,
Make_Exit_Statement (Loc,
Condition =>
- Make_Op_Gt (Loc,
+ Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
- Append_To (B_Ass,
- Make_Exit_Statement (Loc,
- Condition =>
- Make_Op_Lt (Loc,
- Left_Opnd => New_Occurrence_Of (Lnn, Loc),
- Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
-
- Prepend_To (Statements (Loops),
- Make_If_Statement (Loc,
- Condition => New_Occurrence_Of (Rev, Loc),
- Then_Statements => B_Ass,
- Else_Statements => F_Ass));
- end;
-
- -- Build the increment/decrement statements
-
- declare
- F_Ass : constant List_Id := New_List;
- B_Ass : constant List_Id := New_List;
-
- begin
Append_To (F_Ass,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lnn, Loc),
New_Occurrence_Of (Rnn, Loc)))));
Append_To (B_Ass,
+ Make_Exit_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Occurrence_Of (Lnn, Loc),
+ Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
+
+ Append_To (B_Ass,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lnn, Loc),
Expression =>
-- 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
Make_Function_Specification (Loc,
Defining_Unit_Name => F,
Parameter_Specifications => Pspecs,
- Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
+ Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Left_Opnd => New_Reference_To (A, Loc),
Right_Opnd => New_Reference_To (B, Loc)),
Then_Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc)))));
-- Generate component-by-component comparison. Note that we must
end if;
Append_To (Stmts,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (Standard_True, Loc)));
Set_TSS (Typ, F);
Par_Id : Entity_Id;
FN : Node_Id;
- begin
- if Is_Access_Type (Def_Id) then
+ procedure Build_Master (Def_Id : Entity_Id);
+ -- Create the master associated with Def_Id
+ ------------------
+ -- Build_Master --
+ ------------------
+
+ procedure Build_Master (Def_Id : Entity_Id) is
+ begin
-- Anonymous access types are created for the components of the
- -- record parameter for an entry declaration. No master is created
+ -- record parameter for an entry declaration. No master is created
-- for such a type.
if Has_Task (Designated_Type (Def_Id))
Build_Master_Renaming (Parent (Def_Id), Def_Id);
-- Create a class-wide master because a Master_Id must be generated
- -- for access-to-limited-class-wide types, whose root may be extended
+ -- for access-to-limited-class-wide types whose root may be extended
-- with task components.
+ -- Note: This code covers access-to-limited-interfaces because they
+ -- can be used to reference tasks implementing them.
+
elsif Is_Class_Wide_Type (Designated_Type (Def_Id))
and then Is_Limited_Type (Designated_Type (Def_Id))
and then Tasking_Allowed
- -- Don't create a class-wide master for types whose convention is
+ -- Do not create a class-wide master for types whose convention is
-- Java since these types cannot embed Ada tasks anyway. Note that
-- the following test cannot catch the following case:
- --
+
-- package java.lang.Object is
-- type Typ is tagged limited private;
-- type Ref is access all Typ'Class;
-- type Typ is tagged limited ...;
-- pragma Convention (Typ, Java)
-- end;
- --
+
-- Because the convention appears after we have done the
-- processing for type Ref.
and then Convention (Designated_Type (Def_Id)) /= Convention_Java
+ and then Convention (Designated_Type (Def_Id)) /= Convention_CIL
then
Build_Class_Wide_Master (Def_Id);
+ end if;
+ end Build_Master;
+
+ -- Start of processing for Expand_N_Full_Type_Declaration
+
+ begin
+ if Is_Access_Type (Def_Id) then
+ Build_Master (Def_Id);
- elsif Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
+ if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
Expand_Access_Protected_Subprogram_Type (N);
end if;
+ elsif Ada_Version >= Ada_05
+ and then Is_Array_Type (Def_Id)
+ and then Is_Access_Type (Component_Type (Def_Id))
+ and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
+ then
+ Build_Master (Component_Type (Def_Id));
+
elsif Has_Task (Def_Id) then
Expand_Previous_Access_Type (Def_Id);
+
+ elsif Ada_Version >= Ada_05
+ and then
+ (Is_Record_Type (Def_Id)
+ or else (Is_Array_Type (Def_Id)
+ and then Is_Record_Type (Component_Type (Def_Id))))
+ then
+ declare
+ Comp : Entity_Id;
+ Typ : Entity_Id;
+ M_Id : Entity_Id;
+
+ begin
+ -- Look for the first anonymous access type component
+
+ if Is_Array_Type (Def_Id) then
+ Comp := First_Entity (Component_Type (Def_Id));
+ else
+ Comp := First_Entity (Def_Id);
+ end if;
+
+ while Present (Comp) loop
+ Typ := Etype (Comp);
+
+ exit when Is_Access_Type (Typ)
+ and then Ekind (Typ) = E_Anonymous_Access_Type;
+
+ Next_Entity (Comp);
+ end loop;
+
+ -- If found we add a renaming declaration of master_id and we
+ -- associate it to each anonymous access type component. Do
+ -- nothing if the access type already has a master. This will be
+ -- the case if the array type is the packed array created for a
+ -- user-defined array type T, where the master_id is created when
+ -- expanding the declaration for T.
+
+ if Present (Comp)
+ and then Ekind (Typ) = E_Anonymous_Access_Type
+ and then not Restriction_Active (No_Task_Hierarchy)
+ and then No (Master_Id (Typ))
+
+ -- Do not consider run-times with no tasking support
+
+ and then RTE_Available (RE_Current_Master)
+ and then Has_Task (Non_Limited_Designated_Type (Typ))
+ then
+ Build_Master_Entity (Def_Id);
+ M_Id := Build_Master_Renaming (N, Def_Id);
+
+ if Is_Array_Type (Def_Id) then
+ Comp := First_Entity (Component_Type (Def_Id));
+ else
+ Comp := First_Entity (Def_Id);
+ end if;
+
+ while Present (Comp) loop
+ Typ := Etype (Comp);
+
+ if Is_Access_Type (Typ)
+ and then Ekind (Typ) = E_Anonymous_Access_Type
+ then
+ Set_Master_Id (Typ, M_Id);
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+ end if;
+ end;
end if;
Par_Id := Etype (B_Id);
- -- The parent type is private then we need to inherit
- -- any TSS operations from the full view.
+ -- The parent type is private then we need to inherit any TSS operations
+ -- from the full view.
if Ekind (Par_Id) in Private_Kind
and then Present (Full_View (Par_Id))
Par_Id := Base_Type (Full_View (Par_Id));
end if;
- if Nkind (Type_Definition (Original_Node (N)))
- = N_Derived_Type_Definition
+ if Nkind (Type_Definition (Original_Node (N))) =
+ N_Derived_Type_Definition
and then not Is_Tagged_Type (Def_Id)
and then Present (Freeze_Node (Par_Id))
and then Present (TSS_Elist (Freeze_Node (Par_Id)))
then
Ensure_Freeze_Node (B_Id);
- FN := Freeze_Node (B_Id);
+ FN := Freeze_Node (B_Id);
if No (TSS_Elist (FN)) then
Set_TSS_Elist (FN, New_Elmt_List);
end if;
declare
- T_E : constant Elist_Id := TSS_Elist (FN);
- Elmt : Elmt_Id;
+ T_E : constant Elist_Id := TSS_Elist (FN);
+ Elmt : Elmt_Id;
begin
- Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
-
+ Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
while Present (Elmt) loop
if Chars (Node (Elmt)) /= Name_uInit then
Append_Elmt (Node (Elmt), T_E);
-- For all types, we call an initialization procedure if there is one
procedure Expand_N_Object_Declaration (N : Node_Id) is
- Def_Id : constant Entity_Id := Defining_Identifier (N);
- Typ : constant Entity_Id := Etype (Def_Id);
- Loc : constant Source_Ptr := Sloc (N);
- Expr : constant Node_Id := Expression (N);
- New_Ref : Node_Id;
- Id_Ref : Node_Id;
- Expr_Q : Node_Id;
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ Expr : constant Node_Id := Expression (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (Def_Id);
+ Base_Typ : constant Entity_Id := Base_Type (Typ);
+ Expr_Q : Node_Id;
+ Id_Ref : Node_Id;
+ New_Ref : Node_Id;
+
+ Init_After : Node_Id := N;
+ -- Node after which the init proc call is to be inserted. This is
+ -- normally N, except for the case of a shared passive variable, in
+ -- which case the init proc call must be inserted only after the bodies
+ -- of the shared variable procedures have been seen.
+
+ function Rewrite_As_Renaming return Boolean;
+ -- Indicate whether to rewrite a declaration with initialization into an
+ -- object renaming declaration (see below).
+
+ -------------------------
+ -- Rewrite_As_Renaming --
+ -------------------------
+
+ function Rewrite_As_Renaming return Boolean is
+ begin
+ return not Aliased_Present (N)
+ and then Is_Entity_Name (Expr_Q)
+ and then Ekind (Entity (Expr_Q)) = E_Variable
+ and then OK_To_Rename (Entity (Expr_Q))
+ and then Is_Entity_Name (Object_Definition (N));
+ end Rewrite_As_Renaming;
+
+ -- Start of processing for Expand_N_Object_Declaration
begin
- -- Don't do anything for deferred constants. All proper actions will
- -- be expanded during the full declaration.
+ -- Don't do anything for deferred constants. All proper actions will be
+ -- expanded during the full declaration.
if No (Expr) and Constant_Present (N) then
return;
end if;
+ -- Force construction of dispatch tables of library level tagged types
+
+ if Tagged_Type_Expansion
+ and then Static_Dispatch_Tables
+ and then Is_Library_Level_Entity (Def_Id)
+ and then Is_Library_Level_Tagged_Type (Base_Typ)
+ and then (Ekind (Base_Typ) = E_Record_Type
+ or else Ekind (Base_Typ) = E_Protected_Type
+ or else Ekind (Base_Typ) = E_Task_Type)
+ and then not Has_Dispatch_Table (Base_Typ)
+ then
+ declare
+ New_Nodes : List_Id := No_List;
+
+ begin
+ if Is_Concurrent_Type (Base_Typ) then
+ New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
+ else
+ New_Nodes := Make_DT (Base_Typ, N);
+ end if;
+
+ if not Is_Empty_List (New_Nodes) then
+ Insert_List_Before (N, New_Nodes);
+ end if;
+ end;
+ end if;
+
-- Make shared memory routines for shared passive variable
if Is_Shared_Passive (Def_Id) then
- Make_Shared_Var_Procs (N);
+ Init_After := Make_Shared_Var_Procs (N);
end if;
-- If tasks being declared, make sure we have an activation chain
Build_Master_Entity (Def_Id);
end if;
+ -- Build a list controller for declarations where the type is anonymous
+ -- access and the designated type is controlled. Only declarations from
+ -- source files receive such controllers in order to provide the same
+ -- lifespan for any potential coextensions that may be associated with
+ -- the object. Finalization lists of internal controlled anonymous
+ -- access objects are already handled in Expand_N_Allocator.
+
+ if Comes_From_Source (N)
+ and then Ekind (Typ) = E_Anonymous_Access_Type
+ and then Is_Controlled (Directly_Designated_Type (Typ))
+ and then No (Associated_Final_Chain (Typ))
+ then
+ Build_Final_List (N, Typ);
+ end if;
+
-- Default initialization required, and no expression present
if No (Expr) then
- -- Expand Initialize call for controlled objects. One may wonder why
+ -- Expand Initialize call for controlled objects. One may wonder why
-- the Initialize Call is not done in the regular Init procedure
-- attached to the record type. That's because the init procedure is
-- recursively called on each component, including _Parent, thus the
-- Initialize call as it is required but one for each ancestor of
-- its type. This processing is suppressed if No_Initialization set.
- if not Controlled_Type (Typ)
+ if not Needs_Finalization (Typ)
or else No_Initialization (N)
then
null;
elsif not Abort_Allowed
or else not Comes_From_Source (N)
then
- Insert_Actions_After (N,
+ Insert_Actions_After (Init_After,
Make_Init_Call (
Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Type (Typ),
declare
L : constant List_Id :=
- Make_Init_Call (
- Ref => New_Occurrence_Of (Def_Id, Loc),
- Typ => Base_Type (Typ),
- Flist_Ref => Find_Final_List (Def_Id),
- With_Attach => Make_Integer_Literal (Loc, 1));
+ Make_Init_Call
+ (Ref => New_Occurrence_Of (Def_Id, Loc),
+ Typ => Base_Type (Typ),
+ Flist_Ref => Find_Final_List (Def_Id),
+ With_Attach => Make_Integer_Literal (Loc, 1));
Blk : constant Node_Id :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, L));
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, L));
begin
Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
Set_At_End_Proc (Handled_Statement_Sequence (Blk),
New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
- Insert_Actions_After (N, New_List (Blk));
+ Insert_Actions_After (Init_After, New_List (Blk));
Expand_At_End_Handler
(Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
end;
-- Call type initialization procedure if there is one. We build the
-- call and put it immediately after the object declaration, so that
-- it will be expanded in the usual manner. Note that this will
- -- result in proper handling of defaulted discriminants. The call
- -- to the Init_Proc is suppressed if No_Initialization is set.
+ -- result in proper handling of defaulted discriminants.
+
+ -- Need call if there is a base init proc
if Has_Non_Null_Base_Init_Proc (Typ)
- and then not No_Initialization (N)
+
+ -- Suppress call if No_Initialization set on declaration
+
+ and then not No_Initialization (N)
+
+ -- Suppress call for special case of value type for VM
+
+ and then not Is_Value_Type (Typ)
+
+ -- Suppress call if Suppress_Init_Proc set on the type. This is
+ -- needed for the derived type case, where Suppress_Initialization
+ -- may be set for the derived type, even if there is an init proc
+ -- defined for the root type.
+
+ and then not Suppress_Init_Proc (Typ)
then
- -- The call to the initialization procedure does NOT freeze
- -- the object being initialized. This is because the call is
- -- not a source level call. This works fine, because the only
- -- possible statements depending on freeze status that can
- -- appear after the _Init call are rep clauses which can
- -- safely appear after actual references to the object.
+ -- Return without initializing when No_Default_Initialization
+ -- applies. Note that the actual restriction check occurs later,
+ -- when the object is frozen, because we don't know yet whether
+ -- the object is imported, which is a case where the check does
+ -- not apply.
+
+ if Restriction_Active (No_Default_Initialization) then
+ return;
+ end if;
+
+ -- The call to the initialization procedure does NOT freeze the
+ -- object being initialized. This is because the call is not a
+ -- source level call. This works fine, because the only possible
+ -- statements depending on freeze status that can appear after the
+ -- Init_Proc call are rep clauses which can safely appear after
+ -- actual references to the object. Note that this call may
+ -- subsequently be removed (if a pragma Import is encountered),
+ -- or moved to the freeze actions for the object (e.g. if an
+ -- address clause is applied to the object, causing it to get
+ -- delayed freezing).
Id_Ref := New_Reference_To (Def_Id, Loc);
Set_Must_Not_Freeze (Id_Ref);
Set_Assignment_OK (Id_Ref);
- Insert_Actions_After (N,
- Build_Initialization_Call (Loc, Id_Ref, Typ));
+ declare
+ Init_Expr : constant Node_Id :=
+ Static_Initialization (Base_Init_Proc (Typ));
+ begin
+ if Present (Init_Expr) then
+ Set_Expression
+ (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope));
+ return;
+ else
+ Initialization_Warning (Id_Ref);
+
+ Insert_Actions_After (Init_After,
+ Build_Initialization_Call (Loc, Id_Ref, Typ));
+ end if;
+ end;
-- If simple initialization is required, then set an appropriate
-- simple initialization expression in place. This special
- -- initialization is required even though No_Init_Flag is present.
+ -- initialization is required even though No_Init_Flag is present,
+ -- but is not needed if there was an explicit initialization.
-- An internally generated temporary needs no initialization because
- -- it will be assigned subsequently. In particular, there is no
- -- point in applying Initialize_Scalars to such a temporary.
+ -- it will be assigned subsequently. In particular, there is no point
+ -- in applying Initialize_Scalars to such a temporary.
elsif Needs_Simple_Initialization (Typ)
- and then not Is_Internal (Def_Id)
+ and then not Is_Internal (Def_Id)
+ and then not Has_Init_Expression (N)
then
Set_No_Initialization (N, False);
- Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id)));
+ Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
Analyze_And_Resolve (Expression (N), Typ);
end if;
-- Generate attribute for Persistent_BSS if needed
- declare
- Prag : Node_Id;
- begin
- if Persistent_BSS_Mode
- and then Comes_From_Source (N)
- and then Is_Potentially_Persistent_Type (Typ)
- and then Is_Library_Level_Entity (Def_Id)
- then
+ if Persistent_BSS_Mode
+ and then Comes_From_Source (N)
+ and then Is_Potentially_Persistent_Type (Typ)
+ and then not Has_Init_Expression (N)
+ and then Is_Library_Level_Entity (Def_Id)
+ then
+ declare
+ Prag : Node_Id;
+ begin
Prag :=
Make_Linker_Section_Pragma
(Def_Id, Sloc (N), ".persistent.bss");
Insert_After (N, Prag);
Analyze (Prag);
- end if;
- end;
+ end;
+ end if;
+
+ -- If access type, then we know it is null if not initialized
+
+ if Is_Access_Type (Typ) then
+ Set_Is_Known_Null (Def_Id);
+ end if;
-- Explicit initialization present
Expr_Q := Expr;
end if;
- -- When we have the appropriate type of aggregate in the
- -- expression (it has been determined during analysis of the
- -- aggregate by setting the delay flag), let's perform in
- -- place assignment and thus avoid creating a temporary.
+ -- When we have the appropriate type of aggregate in the expression
+ -- (it has been determined during analysis of the aggregate by
+ -- setting the delay flag), let's perform in place assignment and
+ -- thus avoid creating a temporary.
if Is_Delayed_Aggregate (Expr_Q) then
Convert_Aggr_In_Object_Decl (N);
+ -- Ada 2005 (AI-318-02): If the initialization expression is a call
+ -- to a build-in-place function, then access to the declared object
+ -- must be passed to the function. Currently we limit such functions
+ -- to those with constrained limited result subtypes, but eventually
+ -- plan to expand the allowed forms of functions that are treated as
+ -- build-in-place.
+
+ elsif Ada_Version >= Ada_05
+ and then Is_Build_In_Place_Function_Call (Expr_Q)
+ then
+ Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
+
+ -- The previous call expands the expression initializing the
+ -- built-in-place object into further code that will be analyzed
+ -- later. No further expansion needed here.
+
+ return;
+
+ -- Ada 2005 (AI-251): Rewrite the expression that initializes a
+ -- class-wide object to ensure that we copy the full object,
+ -- unless we are targetting a VM where interfaces are handled by
+ -- VM itself. Note that if the root type of Typ is an ancestor
+ -- of Expr's type, both types share the same dispatch table and
+ -- there is no need to displace the pointer.
+
+ elsif Comes_From_Source (N)
+ and then Is_Interface (Typ)
+ then
+ pragma Assert (Is_Class_Wide_Type (Typ));
+
+ -- If the object is a return object of an inherently limited type,
+ -- which implies build-in-place treatment, bypass the special
+ -- treatment of class-wide interface initialization below. In this
+ -- case, the expansion of the return statement will take care of
+ -- creating the object (via allocator) and initializing it.
+
+ if Is_Return_Object (Def_Id)
+ and then Is_Inherently_Limited_Type (Typ)
+ then
+ null;
+
+ elsif Tagged_Type_Expansion then
+ declare
+ Iface : constant Entity_Id := Root_Type (Typ);
+ Expr_N : Node_Id := Expr;
+ Expr_Typ : Entity_Id;
+
+ Decl_1 : Node_Id;
+ Decl_2 : Node_Id;
+ New_Expr : Node_Id;
+
+ begin
+ -- If the original node of the expression was a conversion
+ -- to this specific class-wide interface type then we
+ -- restore the original node to generate code that
+ -- statically displaces the pointer to the interface
+ -- component.
+
+ if not Comes_From_Source (Expr_N)
+ and then Nkind (Expr_N) = N_Unchecked_Type_Conversion
+ and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
+ and then Etype (Original_Node (Expr_N)) = Typ
+ then
+ Rewrite (Expr_N, Original_Node (Expression (N)));
+ end if;
+
+ -- Avoid expansion of redundant interface conversion
+
+ if Is_Interface (Etype (Expr_N))
+ and then Nkind (Expr_N) = N_Type_Conversion
+ and then Etype (Expr_N) = Typ
+ then
+ Expr_N := Expression (Expr_N);
+ Set_Expression (N, Expr_N);
+ end if;
+
+ Expr_Typ := Base_Type (Etype (Expr_N));
+
+ if Is_Class_Wide_Type (Expr_Typ) then
+ Expr_Typ := Root_Type (Expr_Typ);
+ end if;
+
+ -- Replace
+ -- CW : I'Class := Obj;
+ -- by
+ -- Tmp : T := Obj;
+ -- CW : I'Class renames TiC!(Tmp.I_Tag);
+
+ if Comes_From_Source (Expr_N)
+ and then Nkind (Expr_N) = N_Identifier
+ and then not Is_Interface (Expr_Typ)
+ and then (Expr_Typ = Etype (Expr_Typ)
+ or else not
+ Is_Variable_Size_Record (Etype (Expr_Typ)))
+ then
+ Decl_1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Object_Definition =>
+ New_Occurrence_Of (Expr_Typ, Loc),
+ Expression =>
+ Unchecked_Convert_To (Expr_Typ,
+ Relocate_Node (Expr_N)));
+
+ -- Statically reference the tag associated with the
+ -- interface
+
+ Decl_2 :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Subtype_Mark =>
+ New_Occurrence_Of (Typ, Loc),
+ Name =>
+ Unchecked_Convert_To (Typ,
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Defining_Identifier (Decl_1), Loc),
+ Selector_Name =>
+ New_Reference_To
+ (Find_Interface_Tag (Expr_Typ, Iface),
+ Loc))));
+
+ -- General case:
+
+ -- Replace
+ -- IW : I'Class := Obj;
+ -- by
+ -- type Equiv_Record is record ... end record;
+ -- implicit subtype CW is <Class_Wide_Subtype>;
+ -- Temp : CW := CW!(Obj'Address);
+ -- IW : I'Class renames Displace (Temp, I'Tag);
+
+ else
+ -- Generate the equivalent record type
+
+ Expand_Subtype_From_Expr
+ (N => N,
+ Unc_Type => Typ,
+ Subtype_Indic => Object_Definition (N),
+ Exp => Expression (N));
+
+ if not Is_Interface (Etype (Expression (N))) then
+ New_Expr := Relocate_Node (Expression (N));
+ else
+ New_Expr :=
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Expression (N)),
+ Attribute_Name => Name_Address)));
+ end if;
+
+ Decl_1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Object_Definition =>
+ New_Occurrence_Of
+ (Etype (Object_Definition (N)), Loc),
+ Expression =>
+ Unchecked_Convert_To
+ (Etype (Object_Definition (N)), New_Expr));
+
+ Decl_2 :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Subtype_Mark =>
+ New_Occurrence_Of (Typ, Loc),
+ Name =>
+ Unchecked_Convert_To (Typ,
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Displace), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Defining_Identifier (Decl_1), Loc),
+ Attribute_Name => Name_Address),
+
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Iface))),
+ Loc))))))));
+ end if;
+
+ Insert_Action (N, Decl_1);
+ Rewrite (N, Decl_2);
+ Analyze (N);
+
+ -- Replace internal identifier of Decl_2 by the identifier
+ -- found in the sources. We also have to exchange entities
+ -- containing their defining identifiers to ensure the
+ -- correct replacement of the object declaration by this
+ -- object renaming declaration (because such definings
+ -- identifier have been previously added by Enter_Name to
+ -- the current scope). We must preserve the homonym chain
+ -- of the source entity as well.
+
+ Set_Chars (Defining_Identifier (N), Chars (Def_Id));
+ Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
+ Exchange_Entities (Defining_Identifier (N), Def_Id);
+ end;
+ end if;
+
+ return;
+
else
- -- In most cases, we must check that the initial value meets
- -- any constraint imposed by the declared type. However, there
- -- is one very important exception to this rule. If the entity
- -- has an unconstrained nominal subtype, then it acquired its
- -- constraints from the expression in the first place, and not
- -- only does this mean that the constraint check is not needed,
- -- but an attempt to perform the constraint check can
- -- cause order of elaboration problems.
+ -- In most cases, we must check that the initial value meets any
+ -- constraint imposed by the declared type. However, there is one
+ -- very important exception to this rule. If the entity has an
+ -- unconstrained nominal subtype, then it acquired its constraints
+ -- from the expression in the first place, and not only does this
+ -- mean that the constraint check is not needed, but an attempt to
+ -- perform the constraint check can cause order of elaboration
+ -- problems.
if not Is_Constr_Subt_For_U_Nominal (Typ) then
null;
else
Apply_Constraint_Check (Expr, Typ);
- end if;
- end if;
-
- -- If the type is controlled we attach the object to the final
- -- list and adjust the target after the copy. This
-
- if Controlled_Type (Typ) then
- declare
- Flist : Node_Id;
- F : Entity_Id;
- begin
- -- Attach the result to a dummy final list which will never
- -- be finalized if Delay_Finalize_Attachis set. It is
- -- important to attach to a dummy final list rather than
- -- not attaching at all in order to reset the pointers
- -- coming from the initial value. Equivalent code exists
- -- in the sec-stack case in Exp_Ch4.Expand_N_Allocator.
-
- if Delay_Finalize_Attach (N) then
- F :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => F,
- Object_Definition =>
- New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
+ -- If the expression has been marked as requiring a range
+ -- generate it now and reset the flag.
- Flist := New_Reference_To (F, Loc);
-
- else
- Flist := Find_Final_List (Def_Id);
+ if Do_Range_Check (Expr) then
+ Set_Do_Range_Check (Expr, False);
+ Generate_Range_Check (Expr, Typ, CE_Range_Check_Failed);
end if;
+ end if;
+ end if;
- Insert_Actions_After (N,
- Make_Adjust_Call (
- Ref => New_Reference_To (Def_Id, Loc),
- Typ => Base_Type (Typ),
- Flist_Ref => Flist,
- With_Attach => Make_Integer_Literal (Loc, 1)));
- end;
+ -- If the type is controlled and not inherently limited, then
+ -- the target is adjusted after the copy and attached to the
+ -- finalization list. However, no adjustment is done in the case
+ -- where the object was initialized by a call to a function whose
+ -- result is built in place, since no copy occurred. (Eventually
+ -- we plan to support in-place function results for some cases
+ -- of nonlimited types. ???) Similarly, no adjustment is required
+ -- if we are going to rewrite the object declaration into a
+ -- renaming declaration.
+
+ if Needs_Finalization (Typ)
+ and then not Is_Inherently_Limited_Type (Typ)
+ and then not Rewrite_As_Renaming
+ then
+ Insert_Actions_After (Init_After,
+ Make_Adjust_Call (
+ Ref => New_Reference_To (Def_Id, Loc),
+ Typ => Base_Type (Typ),
+ Flist_Ref => Find_Final_List (Def_Id),
+ With_Attach => Make_Integer_Literal (Loc, 1)));
end if;
-- For tagged types, when an init value is given, the tag has to
-- be re-initialized separately in order to avoid the propagation
-- of a wrong tag coming from a view conversion unless the type
- -- is class wide (in this case the tag comes from the init
- -- value). Suppress the tag assignment when Java_VM because JVM
- -- tags are represented implicitly in objects. Ditto for types
- -- that are CPP_CLASS, and for initializations that are
- -- aggregates, because they have to have the right tag.
+ -- is class wide (in this case the tag comes from the init value).
+ -- Suppress the tag assignment when VM_Target because VM tags are
+ -- represented implicitly in objects. Ditto for types that are
+ -- CPP_CLASS, and for initializations that are aggregates, because
+ -- they have to have the right tag.
if Is_Tagged_Type (Typ)
and then not Is_Class_Wide_Type (Typ)
and then not Is_CPP_Class (Typ)
- and then not Java_VM
+ and then Tagged_Type_Expansion
and then Nkind (Expr) /= N_Aggregate
then
- -- The re-assignment of the tag has to be done even if
- -- the object is a constant
+ -- The re-assignment of the tag has to be done even if the
+ -- object is a constant.
New_Ref :=
Make_Selected_Component (Loc,
Set_Assignment_OK (New_Ref);
- Insert_After (N,
+ Insert_After (Init_After,
Make_Assignment_Statement (Loc,
Name => New_Ref,
Expression =>
(Access_Disp_Table (Base_Type (Typ)))),
Loc))));
+ elsif Is_Tagged_Type (Typ)
+ and then Is_CPP_Constructor_Call (Expr)
+ then
+ -- The call to the initialization procedure does NOT freeze the
+ -- object being initialized.
+
+ Id_Ref := New_Reference_To (Def_Id, Loc);
+ Set_Must_Not_Freeze (Id_Ref);
+ Set_Assignment_OK (Id_Ref);
+
+ Insert_Actions_After (Init_After,
+ Build_Initialization_Call (Loc, Id_Ref, Typ,
+ Constructor_Ref => Expr));
+
+ -- We remove here the original call to the constructor
+ -- to avoid its management in the backend
+
+ Set_Expression (N, Empty);
+ return;
+
-- For discrete types, set the Is_Known_Valid flag if the
-- initializing value is known to be valid.
- elsif Is_Discrete_Type (Typ)
- and then Expr_Known_Valid (Expr)
- then
+ elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then
Set_Is_Known_Valid (Def_Id);
elsif Is_Access_Type (Typ) then
- -- Ada 2005 (AI-231): Generate conversion to the null-excluding
- -- type to force the corresponding run-time check
-
- if Ada_Version >= Ada_05
- and then (Can_Never_Be_Null (Def_Id)
- or else Can_Never_Be_Null (Typ))
- then
- Rewrite
- (Expr_Q,
- Convert_To (Etype (Def_Id), Relocate_Node (Expr_Q)));
- Analyze_And_Resolve (Expr_Q, Etype (Def_Id));
- end if;
-
-- For access types set the Is_Known_Non_Null flag if the
-- initializing value is known to be non-null. We can also set
-- Can_Never_Be_Null if this is a constant.
if Known_Non_Null (Expr) then
- Set_Is_Known_Non_Null (Def_Id);
+ Set_Is_Known_Non_Null (Def_Id, True);
if Constant_Present (N) then
Set_Can_Never_Be_Null (Def_Id);
end if;
end if;
- -- If validity checking on copies, validate initial expression
+ -- If validity checking on copies, validate initial expression.
+ -- But skip this if declaration is for a generic type, since it
+ -- makes no sense to validate generic types. Not clear if this
+ -- can happen for legal programs, but it definitely can arise
+ -- from previous instantiation errors.
if Validity_Checks_On
- and then Validity_Check_Copies
+ and then Validity_Check_Copies
+ and then not Is_Generic_Type (Etype (Def_Id))
then
Ensure_Valid (Expr);
Set_Is_Known_Valid (Def_Id);
end if;
end if;
- -- Cases where the back end cannot handle the initialization
- -- directly. In such cases, we expand an assignment that will
- -- be appropriately handled by Expand_N_Assignment_Statement.
+ -- Cases where the back end cannot handle the initialization directly
+ -- In such cases, we expand an assignment that will be appropriately
+ -- handled by Expand_N_Assignment_Statement.
- -- The exclusion of the unconstrained case is wrong, but for
- -- now it is too much trouble ???
+ -- The exclusion of the unconstrained case is wrong, but for now it
+ -- is too much trouble ???
if (Is_Possibly_Unaligned_Slice (Expr)
or else (Is_Possibly_Unaligned_Object (Expr)
and then not Represented_As_Scalar (Etype (Expr))))
- -- The exclusion of the unconstrained case is wrong, but for
- -- now it is too much trouble ???
+ -- The exclusion of the unconstrained case is wrong, but for now
+ -- it is too much trouble ???
and then not (Is_Array_Type (Etype (Expr))
and then not Is_Constrained (Etype (Expr)))
Set_No_Initialization (N);
Set_Assignment_OK (Name (Stat));
Set_No_Ctrl_Actions (Stat);
- Insert_After (N, Stat);
- Analyze (Stat);
+ Insert_After_And_Analyze (Init_After, Stat);
end;
end if;
- end if;
- -- For array type, check for size too large
- -- We really need this for record types too???
+ -- Final transformation, if the initializing expression is an entity
+ -- for a variable with OK_To_Rename set, then we transform:
+
+ -- X : typ := expr;
+
+ -- into
+
+ -- X : typ renames expr
+
+ -- provided that X is not aliased. The aliased case has to be
+ -- excluded in general because Expr will not be aliased in general.
+
+ if Rewrite_As_Renaming then
+ Rewrite (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Defining_Identifier (N),
+ Subtype_Mark => Object_Definition (N),
+ Name => Expr_Q));
+
+ -- We do not analyze this renaming declaration, because all its
+ -- components have already been analyzed, and if we were to go
+ -- ahead and analyze it, we would in effect be trying to generate
+ -- another declaration of X, which won't do!
+
+ Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
+ Set_Analyzed (N);
+ end if;
- if Is_Array_Type (Typ) then
- Apply_Array_Size_Check (N, Typ);
end if;
exception
-- Add a check on the range of the subtype. The static case is partially
-- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
-- to check here for the static case in order to avoid generating
- -- extraneous expanded code.
+ -- extraneous expanded code. Also deal with validity checking.
procedure Expand_N_Subtype_Indication (N : Node_Id) is
Ran : constant Node_Id := Range_Expression (Constraint (N));
Typ : constant Entity_Id := Entity (Subtype_Mark (N));
begin
- if Nkind (Parent (N)) = N_Constrained_Array_Definition or else
- Nkind (Parent (N)) = N_Slice
- then
- Resolve (Ran, Typ);
+ if Nkind (Constraint (N)) = N_Range_Constraint then
+ Validity_Check_Range (Range_Expression (Constraint (N)));
+ end if;
+
+ if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
Apply_Range_Check (Ran, Typ);
end if;
end Expand_N_Subtype_Indication;
-- If the last variant does not contain the Others choice, replace it with
-- an N_Others_Choice node since Gigi always wants an Others. Note that we
-- do not bother to call Analyze on the modified variant part, since it's
- -- only effect would be to compute the contents of the
- -- Others_Discrete_Choices node laboriously, and of course we already know
- -- the list of choices that corresponds to the others choice (it's the
- -- list we are replacing!)
+ -- only effect would be to compute the Others_Discrete_Choices node
+ -- laboriously, and of course we already know the list of choices that
+ -- corresponds to the others choice (it's the list we are replacing!)
procedure Expand_N_Variant_Part (N : Node_Id) is
Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
begin
-- Find all access types declared in the current scope, whose
- -- designated type is Def_Id.
+ -- designated type is Def_Id. If it does not have a Master_Id,
+ -- create one now.
while Present (T) loop
if Is_Access_Type (T)
and then Designated_Type (T) = Def_Id
+ and then No (Master_Id (T))
then
Build_Master_Entity (Def_Id);
Build_Master_Renaming (Parent (Def_Id), T);
Loc := Sloc (First (Component_Items (Comp_List)));
end if;
- if Is_Return_By_Reference_Type (T) then
+ if Is_Inherently_Limited_Type (T) then
Controller_Type := RTE (RE_Limited_Record_Controller);
else
Controller_Type := RTE (RE_Record_Controller);
else
-- The controller cannot be placed before the _Parent field since
- -- gigi lays out field in order and _parent must be first to
- -- preserve the polymorphism of tagged types.
+ -- gigi lays out field in order and _parent must be first to preserve
+ -- the polymorphism of tagged types.
First_Comp := First (Component_Items (Comp_List));
- if Chars (Defining_Identifier (First_Comp)) /= Name_uParent
- and then Chars (Defining_Identifier (First_Comp)) /= Name_uTag
- then
+ if not Is_Tagged_Type (T) then
Insert_Before (First_Comp, Comp_Decl);
+
+ -- if T is a tagged type, place controller declaration after parent
+ -- field and after eventual tags of interface types.
+
else
- Insert_After (First_Comp, Comp_Decl);
+ while Present (First_Comp)
+ and then
+ (Chars (Defining_Identifier (First_Comp)) = Name_uParent
+ or else Is_Tag (Defining_Identifier (First_Comp))
+
+ -- Ada 2005 (AI-251): The following condition covers secondary
+ -- tags but also the adjacent component containing the offset
+ -- to the base of the object (component generated if the parent
+ -- has discriminants --- see Add_Interface_Tag_Components).
+ -- This is required to avoid the addition of the controller
+ -- between the secondary tag and its adjacent component.
+
+ or else Present
+ (Related_Type
+ (Defining_Identifier (First_Comp))))
+ loop
+ Next (First_Comp);
+ end loop;
+
+ -- An empty tagged extension might consist only of the parent
+ -- component. Otherwise insert the controller before the first
+ -- component that is neither parent nor tag.
+
+ if Present (First_Comp) then
+ Insert_Before (First_Comp, Comp_Decl);
+ else
+ Append (Comp_Decl, Component_Items (Comp_List));
+ end if;
end if;
end if;
- New_Scope (T);
+ Push_Scope (T);
Analyze (Comp_Decl);
Set_Ekind (Ent, E_Component);
Init_Component_Location (Ent);
return;
end Expand_Tagged_Root;
- -----------------------
- -- Freeze_Array_Type --
- -----------------------
+ ----------------------
+ -- Clean_Task_Names --
+ ----------------------
+
+ procedure Clean_Task_Names
+ (Typ : Entity_Id;
+ Proc_Id : Entity_Id)
+ is
+ begin
+ if Has_Task (Typ)
+ and then not Restriction_Active (No_Implicit_Heap_Allocations)
+ and then not Global_Discard_Names
+ and then Tagged_Type_Expansion
+ then
+ Set_Uses_Sec_Stack (Proc_Id);
+ end if;
+ end Clean_Task_Names;
+
+ ------------------------------
+ -- Expand_Freeze_Array_Type --
+ ------------------------------
- procedure Freeze_Array_Type (N : Node_Id) is
- Typ : constant Entity_Id := Entity (N);
- Base : constant Entity_Id := Base_Type (Typ);
+ procedure Expand_Freeze_Array_Type (N : Node_Id) is
+ Typ : constant Entity_Id := Entity (N);
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
+ Base : constant Entity_Id := Base_Type (Typ);
begin
if not Is_Bit_Packed_Array (Typ) then
-- been a private type at the point of definition. Same if component
-- type is controlled.
- Set_Has_Task (Base, Has_Task (Component_Type (Typ)));
+ Set_Has_Task (Base, Has_Task (Comp_Typ));
Set_Has_Controlled_Component (Base,
- Has_Controlled_Component (Component_Type (Typ))
- or else Is_Controlled (Component_Type (Typ)));
+ Has_Controlled_Component (Comp_Typ)
+ or else Is_Controlled (Comp_Typ));
if No (Init_Proc (Base)) then
-- If this is an anonymous array created for a declaration with
-- an initial value, its init_proc will never be called. The
- -- initial value itself may have been expanded into assign-
- -- ments, in which case the object declaration is carries the
+ -- initial value itself may have been expanded into assignments,
+ -- in which case the object declaration is carries the
-- No_Initialization flag.
if Is_Itype (Base)
end if;
end if;
- if Typ = Base and then Has_Controlled_Component (Base) then
- Build_Controlling_Procs (Base);
+ if Typ = Base then
+ if Has_Controlled_Component (Base) then
+ Build_Controlling_Procs (Base);
+
+ if not Is_Limited_Type (Comp_Typ)
+ and then Number_Dimensions (Typ) = 1
+ then
+ Build_Slice_Assignment (Typ);
+ end if;
- if not Is_Limited_Type (Component_Type (Typ))
- and then Number_Dimensions (Typ) = 1
+ elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
+ and then Needs_Finalization (Directly_Designated_Type (Comp_Typ))
then
- Build_Slice_Assignment (Typ);
+ Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ));
end if;
end if;
- -- For packed case, there is a default initialization, except if the
- -- component type is itself a packed structure with an initialization
- -- procedure.
+ -- For packed case, default initialization, except if the component type
+ -- is itself a packed structure with an initialization procedure, or
+ -- initialize/normalize scalars active, and we have a base type, or the
+ -- type is public, because in that case a client might specify
+ -- Normalize_Scalars and there better be a public Init_Proc for it.
- elsif Present (Init_Proc (Component_Type (Base)))
- and then No (Base_Init_Proc (Base))
+ elsif (Present (Init_Proc (Component_Type (Base)))
+ and then No (Base_Init_Proc (Base)))
+ or else (Init_Or_Norm_Scalars and then Base = Typ)
+ or else Is_Public (Typ)
then
Build_Array_Init_Proc (Base, N);
end if;
- end Freeze_Array_Type;
+ end Expand_Freeze_Array_Type;
- -----------------------------
- -- Freeze_Enumeration_Type --
- -----------------------------
+ ------------------------------------
+ -- Expand_Freeze_Enumeration_Type --
+ ------------------------------------
- procedure Freeze_Enumeration_Type (N : Node_Id) is
+ procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
Typ : constant Entity_Id := Entity (N);
Loc : constant Source_Ptr := Sloc (Typ);
Ent : Entity_Id;
pragma Warnings (Off, Func);
begin
- -- Various optimization are possible if the given representation is
- -- contiguous.
+ -- Various optimizations possible if given representation is contiguous
Is_Contiguous := True;
+
Ent := First_Literal (Typ);
Last_Repval := Enumeration_Rep (Ent);
- Next_Literal (Ent);
+ Next_Literal (Ent);
while Present (Ent) loop
if Enumeration_Rep (Ent) - Last_Repval /= 1 then
Is_Contiguous := False;
-- 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
Make_Integer_Literal (Loc, Intval => Last_Repval))),
Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => Pos_Expr))));
else
Ent := First_Literal (Typ);
-
while Present (Ent) loop
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Intval => Enumeration_Rep (Ent))),
Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Integer_Literal (Loc,
Intval => Enumeration_Pos (Ent))))));
-- 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)),
Make_Raise_Constraint_Error (Loc,
Condition => Make_Identifier (Loc, Name_uF),
Reason => CE_Invalid_Data),
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Integer_Literal (Loc, -1)))));
- -- If Restriction (No_Exceptions_Handlers) is active then we always
- -- return -1 (since we cannot usefully raise Constraint_Error in
+ -- If either of the restrictions No_Exceptions_Handlers/Propagation is
+ -- active then return -1 (we cannot usefully raise Constraint_Error in
-- this case). See description above for further details.
else
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Integer_Literal (Loc, -1)))));
end if;
Make_Defining_Identifier (Loc, Name_uF),
Parameter_Type => New_Reference_To (Standard_Boolean, Loc))),
- Subtype_Mark => New_Reference_To (Standard_Integer, Loc)),
+ Result_Definition => New_Reference_To (Standard_Integer, Loc)),
Declarations => Empty_List,
exception
when RE_Not_Available =>
return;
- end Freeze_Enumeration_Type;
+ end Expand_Freeze_Enumeration_Type;
- ------------------------
- -- Freeze_Record_Type --
- ------------------------
+ -------------------------------
+ -- Expand_Freeze_Record_Type --
+ -------------------------------
+
+ procedure Expand_Freeze_Record_Type (N : Node_Id) is
+ Def_Id : constant Node_Id := Entity (N);
+ Type_Decl : constant Node_Id := Parent (Def_Id);
+ Comp : Entity_Id;
+ Comp_Typ : Entity_Id;
+ Has_Static_DT : Boolean := False;
+ Predef_List : List_Id;
+
+ Flist : Entity_Id := Empty;
+ -- Finalization list allocated for the case of a type with anonymous
+ -- access components whose designated type is potentially controlled.
- procedure Freeze_Record_Type (N : Node_Id) is
- Def_Id : constant Node_Id := Entity (N);
- Comp : Entity_Id;
- Type_Decl : constant Node_Id := Parent (Def_Id);
- Predef_List : List_Id;
+ Renamed_Eq : Node_Id := Empty;
+ -- Defining unit name for the predefined equality function in the case
+ -- where the type has a primitive operation that is a renaming of
+ -- predefined equality (but only if there is also an overriding
+ -- user-defined equality function). Used to pass this entity from
+ -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
- Renamed_Eq : Node_Id := Empty;
- -- Could use some comments ???
+ Wrapper_Decl_List : List_Id := No_List;
+ Wrapper_Body_List : List_Id := No_List;
+ Null_Proc_Decl_List : List_Id := No_List;
+
+ -- Start of processing for Expand_Freeze_Record_Type
begin
-- Build discriminant checking functions if not a derived type (for
- -- derived types that are not tagged types, we always use the
- -- discriminant checking functions of the parent type). However, for
- -- untagged types the derivation may have taken place before the
- -- parent was frozen, so we copy explicitly the discriminant checking
- -- functions from the parent into the components of the derived type.
+ -- derived types that are not tagged types, always use the discriminant
+ -- checking functions of the parent type). However, for untagged types
+ -- the derivation may have taken place before the parent was frozen, so
+ -- we copy explicitly the discriminant checking functions from the
+ -- parent into the components of the derived type.
if not Is_Derived_Type (Def_Id)
or else Has_New_Non_Standard_Rep (Def_Id)
and then Chars (Comp) = Chars (Old_Comp)
then
Set_Discriminant_Checking_Func (Comp,
- Discriminant_Checking_Func (Old_Comp));
+ Discriminant_Checking_Func (Old_Comp));
end if;
Next_Component (Old_Comp);
Comp := First_Component (Def_Id);
while Present (Comp) loop
- if Has_Task (Etype (Comp)) then
+ Comp_Typ := Etype (Comp);
+
+ if Has_Task (Comp_Typ) then
Set_Has_Task (Def_Id);
- elsif Has_Controlled_Component (Etype (Comp))
- or else (Chars (Comp) /= Name_uParent
- and then Is_Controlled (Etype (Comp)))
+ -- Do not set Has_Controlled_Component on a class-wide equivalent
+ -- type. See Make_CW_Equivalent_Type.
+
+ elsif not Is_Class_Wide_Equivalent_Type (Def_Id)
+ and then (Has_Controlled_Component (Comp_Typ)
+ or else (Chars (Comp) /= Name_uParent
+ and then Is_Controlled (Comp_Typ)))
then
Set_Has_Controlled_Component (Def_Id);
+
+ elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
+ and then Needs_Finalization (Directly_Designated_Type (Comp_Typ))
+ then
+ if No (Flist) then
+ Flist := Add_Final_Chain (Def_Id);
+ end if;
+
+ Set_Associated_Final_Chain (Comp_Typ, Flist);
end if;
Next_Component (Comp);
end loop;
- -- Creation of the Dispatch Table. Note that a Dispatch Table is
- -- created for regular tagged types as well as for Ada types deriving
- -- from a C++ Class, but not for tagged types directly corresponding to
- -- the C++ classes. In the later case we assume that the Vtable is
- -- created in the C++ side and we just use it.
-
- if Is_Tagged_Type (Def_Id) then
+ -- Handle constructors of non-tagged CPP_Class types
- if Is_CPP_Class (Def_Id) then
- Set_All_DT_Position (Def_Id);
- Set_Default_Constructor (Def_Id);
+ if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then
+ Set_CPP_Constructors (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.
+ -- 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.
- declare
- Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
- Subp : Entity_Id;
+ if Is_Tagged_Type (Def_Id) then
+ Has_Static_DT :=
+ Static_Dispatch_Tables
+ and then Is_Library_Level_Tagged_Type (Def_Id);
- begin
- while Present (Elmt) loop
- Subp := Node (Elmt);
+ -- Add the _Tag component
- if Present (Alias (Subp)) then
- if Is_CPP_Class (Etype (Def_Id)) then
- Set_Has_Delayed_Freeze (Subp);
+ if Underlying_Type (Etype (Def_Id)) = Def_Id then
+ Expand_Tagged_Root (Def_Id);
+ end if;
- elsif Has_Delayed_Freeze (Alias (Subp))
- and then not Is_Frozen (Alias (Subp))
- then
- Set_Is_Frozen (Subp, False);
- Set_Has_Delayed_Freeze (Subp);
- end if;
- end if;
+ if Is_CPP_Class (Def_Id) then
+ Set_All_DT_Position (Def_Id);
+ Set_CPP_Constructors (Def_Id);
- Next_Elmt (Elmt);
- end loop;
- end;
+ -- Create the tag entities with a minimum decoration
- if Underlying_Type (Etype (Def_Id)) = Def_Id then
- Expand_Tagged_Root (Def_Id);
+ if Tagged_Type_Expansion then
+ Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
end if;
- -- Build the secondary tables
+ else
+ if not Has_Static_DT then
+
+ -- 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.
+
+ -- 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 Java_VM
- and then Present (Abstract_Interfaces (Def_Id))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (Def_Id))
- then
declare
- E : Entity_Id;
- Result : List_Id;
- ADT : Elist_Id := Access_Disp_Table (Def_Id);
+ Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
+ Subp : Entity_Id;
begin
- E := First_Entity (Def_Id);
- while Present (E) loop
- if Is_Tag (E) and then Chars (E) /= Name_uTag then
- Make_Abstract_Interface_DT
- (AI_Tag => E,
- Acc_Disp_Tables => ADT,
- Result => Result);
-
- Append_Freeze_Actions (Def_Id, Result);
+ 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;
- Next_Entity (E);
+ Next_Elmt (Elmt);
end loop;
-
- Set_Access_Disp_Table (Def_Id, ADT);
end;
end if;
-- must be before the freeze point).
Set_Is_Frozen (Def_Id, False);
- Make_Predefined_Primitive_Specs
- (Def_Id, Predef_List, Renamed_Eq);
- Insert_List_Before_And_Analyze (N, Predef_List);
- Set_Is_Frozen (Def_Id, True);
+
+ -- Do not add the spec of predefined primitives in case of
+ -- CPP tagged type derivations that have convention CPP.
+
+ if Is_CPP_Class (Root_Type (Def_Id))
+ and then Convention (Def_Id) = Convention_CPP
+ then
+ null;
+
+ -- Do not add the spec of the predefined primitives if we are
+ -- compiling under restriction No_Dispatching_Calls
+
+ elsif not Restriction_Active (No_Dispatching_Calls) then
+ Make_Predefined_Primitive_Specs
+ (Def_Id, Predef_List, Renamed_Eq);
+ Insert_List_Before_And_Analyze (N, Predef_List);
+ end if;
+
+ -- Ada 2005 (AI-391): For a nonabstract null extension, create
+ -- wrapper functions for each nonoverridden inherited function
+ -- with a controlling result of the type. The wrapper for such
+ -- a function returns an extension aggregate that invokes the
+ -- the parent function.
+
+ if Ada_Version >= Ada_05
+ and then not Is_Abstract_Type (Def_Id)
+ and then Is_Null_Extension (Def_Id)
+ then
+ Make_Controlling_Function_Wrappers
+ (Def_Id, Wrapper_Decl_List, Wrapper_Body_List);
+ Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
+ end if;
+
+ -- Ada 2005 (AI-251): For a nonabstract type extension, build
+ -- null procedure declarations for each set of homographic null
+ -- procedures that are inherited from interface types but not
+ -- overridden. This is done to ensure that the dispatch table
+ -- entry associated with such null primitives are properly filled.
+
+ if Ada_Version >= Ada_05
+ and then Etype (Def_Id) /= Def_Id
+ and then not Is_Abstract_Type (Def_Id)
+ then
+ Make_Null_Procedure_Specs (Def_Id, Null_Proc_Decl_List);
+ Insert_Actions (N, Null_Proc_Decl_List);
+ end if;
+
+ 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.
+ -- Create and decorate the tags. Suppress their creation when
+ -- VM_Target because the dispatching mechanism is handled
+ -- internally by the VMs.
+
+ if Tagged_Type_Expansion then
+ Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
- if not Java_VM then
- Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+ -- Generate dispatch table of locally defined tagged type.
+ -- Dispatch tables of library level tagged types are built
+ -- later (see Analyze_Declarations).
+
+ if not Has_Static_DT then
+ Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+ end if;
+ end if;
+
+ -- If the type has unknown discriminants, propagate dispatching
+ -- information to its underlying record view, which does not get
+ -- its own dispatch table.
+
+ if Is_Derived_Type (Def_Id)
+ and then Has_Unknown_Discriminants (Def_Id)
+ and then Present (Underlying_Record_View (Def_Id))
+ then
+ declare
+ Rep : constant Entity_Id :=
+ Underlying_Record_View (Def_Id);
+ begin
+ Set_Access_Disp_Table
+ (Rep, Access_Disp_Table (Def_Id));
+ Set_Dispatch_Table_Wrappers
+ (Rep, Dispatch_Table_Wrappers (Def_Id));
+ Set_Primitive_Operations
+ (Rep, Primitive_Operations (Def_Id));
+ end;
end if;
-- Make sure that the primitives Initialize, Adjust and Finalize
(Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id)));
end if;
- -- Freeze rest of primitive operations
+ -- Freeze rest of primitive operations. There is no need to handle
+ -- the predefined primitives if we are compiling under restriction
+ -- No_Dispatching_Calls
- Append_Freeze_Actions
- (Def_Id, Predefined_Primitive_Freeze (Def_Id));
+ if not Restriction_Active (No_Dispatching_Calls) then
+ Append_Freeze_Actions
+ (Def_Id, Predefined_Primitive_Freeze (Def_Id));
+ end if;
end if;
-- In the non-tagged case, an equality function is provided only for
end if;
Adjust_Discriminants (Def_Id);
- Build_Record_Init_Proc (Type_Decl, Def_Id);
- -- For tagged type, build bodies of primitive operations. Note that we
- -- do this after building the record initialization experiment, since
- -- the primitive operations may need the initialization routine
+ if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then
- if Is_Tagged_Type (Def_Id) then
- Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
- Append_Freeze_Actions (Def_Id, Predef_List);
+ -- 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;
- end Freeze_Record_Type;
+ -- For tagged type that are not interfaces, build bodies of primitive
+ -- operations. Note that we do this after building the record
+ -- initialization procedure, since the primitive operations may need
+ -- the initialization routine. There is no need to add predefined
+ -- primitives of interfaces because all their predefined primitives
+ -- are abstract.
+
+ if Is_Tagged_Type (Def_Id)
+ and then not Is_Interface (Def_Id)
+ then
+ -- Do not add the body of predefined primitives in case of
+ -- CPP tagged type derivations that have convention CPP.
+
+ if Is_CPP_Class (Root_Type (Def_Id))
+ and then Convention (Def_Id) = Convention_CPP
+ then
+ null;
+
+ -- Do not add the body of the predefined primitives if we are
+ -- compiling under restriction No_Dispatching_Calls or if we are
+ -- compiling a CPP tagged type.
+
+ elsif not Restriction_Active (No_Dispatching_Calls) then
+ Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
+ Append_Freeze_Actions (Def_Id, Predef_List);
+ end if;
+
+ -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
+ -- inherited functions, then add their bodies to the freeze actions.
+
+ if Present (Wrapper_Body_List) then
+ Append_Freeze_Actions (Def_Id, Wrapper_Body_List);
+ end if;
+
+ -- Create extra formals for the primitive operations of the type.
+ -- This must be done before analyzing the body of the initialization
+ -- procedure, because a self-referential type might call one of these
+ -- primitives in the body of the init_proc itself.
+
+ declare
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
+
+ begin
+ Elmt := First_Elmt (Primitive_Operations (Def_Id));
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+ if not Has_Foreign_Convention (Subp)
+ and then not Is_Predefined_Dispatching_Operation (Subp)
+ then
+ Create_Extra_Formals (Subp);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+ end Expand_Freeze_Record_Type;
------------------------------
-- Freeze_Stream_Operations --
while Present (E) loop
if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
+ Validate_RACW_Primitives (Node (E));
RACW_Seen := True;
end if;
if Is_Record_Type (Def_Id) then
if Ekind (Def_Id) = E_Record_Type then
- Freeze_Record_Type (N);
+ Expand_Freeze_Record_Type (N);
-- The subtype may have been declared before the type was frozen. If
-- the type has controlled components it is necessary to create the
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;
then
-- The freeze node is only used to introduce the controller,
-- the back-end has no use for it for a discriminated
- -- component.
+ -- component.
Set_Freeze_Node (Def_Id, Empty);
Set_Has_Delayed_Freeze (Def_Id, False);
-- Freeze processing for array types
elsif Is_Array_Type (Def_Id) then
- Freeze_Array_Type (N);
+ Expand_Freeze_Array_Type (N);
-- Freeze processing for access types
then
declare
Loc : constant Source_Ptr := Sloc (N);
- Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
+ Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
Pool_Object : Entity_Id;
- Siz_Exp : Node_Id;
Freeze_Action_Typ : Entity_Id;
begin
- if Has_Storage_Size_Clause (Def_Id) then
- Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id)));
- else
- Siz_Exp := Empty;
- end if;
-
-- Case 1
-- Rep Clause "for Def_Id'Storage_Size use 0;"
-- ---> don't use any storage pool
- if Has_Storage_Size_Clause (Def_Id)
- and then Compile_Time_Known_Value (Siz_Exp)
- and then Expr_Value (Siz_Exp) = 0
- then
+ if No_Pool_Assigned (Def_Id) then
null;
-- Case 2
Chars => New_External_Name (Chars (Def_Id), 'P'));
-- We put the code associated with the pools in the entity
- -- that has the later freeze node, usually the acces type
+ -- that has the later freeze node, usually the access type
-- but it can also be the designated_type; because the pool
-- code requires both those types to be frozen
if Is_Frozen (Desig_Type)
- and then (not Present (Freeze_Node (Desig_Type))
+ and then (No (Freeze_Node (Desig_Type))
or else Analyzed (Freeze_Node (Desig_Type)))
then
Freeze_Action_Typ := Def_Id;
then
null;
- elsif (Controlled_Type (Desig_Type)
- and then Convention (Desig_Type) /= Convention_Java)
+ elsif (Needs_Finalization (Desig_Type)
+ and then Convention (Desig_Type) /= Convention_Java
+ and then Convention (Desig_Type) /= Convention_CIL)
or else
(Is_Incomplete_Or_Private_Type (Desig_Type)
and then No (Full_View (Desig_Type))
or else (Is_Array_Type (Desig_Type)
and then not Is_Frozen (Desig_Type)
- and then Controlled_Type (Component_Type (Desig_Type)))
+ and then Needs_Finalization (Component_Type (Desig_Type)))
+
+ -- The designated type has controlled anonymous access
+ -- discriminants.
+
+ or else Has_Controlled_Coextensions (Desig_Type)
then
- Set_Associated_Final_Chain (Def_Id,
- Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Def_Id), 'L')));
-
- Append_Freeze_Action (Def_Id,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Associated_Final_Chain (Def_Id),
- Object_Definition =>
- New_Reference_To (RTE (RE_List_Controller), Loc)));
+ Set_Associated_Final_Chain (Def_Id, Add_Final_Chain (Def_Id));
end if;
end;
-- is not the same as its representation)
if Has_Non_Standard_Rep (Def_Id) then
- Freeze_Enumeration_Type (N);
+ Expand_Freeze_Enumeration_Type (N);
end if;
-- Private types that are completed by a derivation from a private
function Get_Simple_Init_Val
(T : Entity_Id;
- Loc : Source_Ptr;
+ N : Node_Id;
Size : Uint := No_Uint) return Node_Id
is
+ Loc : constant Source_Ptr := Sloc (N);
Val : Node_Id;
Result : Node_Id;
Val_RE : RE_Id;
-- This is the size to be used for computation of the appropriate
-- initial value for the Normalize_Scalars and Initialize_Scalars case.
+ IV_Attribute : constant Boolean :=
+ Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Invalid_Value;
+
Lo_Bound : Uint;
Hi_Bound : Uint;
-- These are the values computed by the procedure Check_Subtype_Bounds
-- an Unchecked_Convert to the private type.
if Is_Private_Type (T) then
- Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size);
+ Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
-- A special case, if the underlying value is null, then qualify it
-- with the underlying type, so that the null is properly typed
-- Similarly, if it is an aggregate it must be qualified, because an
-- unchecked conversion does not provide a context for it.
- if Nkind (Val) = N_Null
- or else Nkind (Val) = N_Aggregate
- then
+ if Nkind_In (Val, N_Null, N_Aggregate) then
Val :=
Make_Qualified_Expression (Loc,
Subtype_Mark =>
return Result;
- -- For scalars, we must have normalize/initialize scalars case
+ -- For scalars, we must have normalize/initialize scalars case, or
+ -- if the node N is an 'Invalid_Value attribute node.
elsif Is_Scalar_Type (T) then
- pragma Assert (Init_Or_Norm_Scalars);
+ pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
-- Compute size of object. If it is given by the caller, we can use
-- it directly, otherwise we use Esize (T) as an estimate. As far as
-- Processing for Normalize_Scalars case
- if Normalize_Scalars then
+ if Normalize_Scalars and then not IV_Attribute then
-- If zero is invalid, it is a convenient value to use that is
-- for sure an appropriate invalid value in all situations.
-- 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.
end;
end if;
- -- Here for Initialize_Scalars case
+ -- Here for Initialize_Scalars case (or Invalid_Value attribute used)
else
-- For float types, use float values from System.Scalar_Values
Make_Others_Choice (Loc)),
Expression =>
Get_Simple_Init_Val
- (Component_Type (T), Loc, Esize (Root_Type (T))))));
+ (Component_Type (T), N, Esize (Root_Type (T))))));
-- Access type is initialized to null
----------------
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 initialization
+ -- expression. No need for a warning on a type if all its
+ -- components have no initialization.
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (E);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Discriminant
+ or else
+ (Nkind (Parent (Comp)) = N_Component_Declaration
+ and then Present (Expression (Parent (Comp))))
+ then
+ Warning_Needed := True;
+ exit;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
+
+ if Warning_Needed then
+ Error_Msg_N
+ ("Objects of the type cannot be initialized " &
+ "statically by default?",
+ Parent (E));
+ end if;
+ end if;
+
+ else
+ Error_Msg_N ("Object cannot be initialized statically?", E);
+ end if;
+ end if;
+ end Initialization_Warning;
+
------------------
-- Init_Formals --
------------------
return Empty_List;
end Init_Formals;
+ -------------------------
+ -- Init_Secondary_Tags --
+ -------------------------
+
+ procedure Init_Secondary_Tags
+ (Typ : Entity_Id;
+ Target : Node_Id;
+ Stmts_List : List_Id;
+ Fixed_Comps : Boolean := True;
+ Variable_Comps : Boolean := True)
+ is
+ Loc : constant Source_Ptr := Sloc (Target);
+
+ procedure Inherit_CPP_Tag
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ Tag_Comp : Entity_Id;
+ Iface_Tag : Node_Id);
+ -- Inherit the C++ tag of the secondary dispatch table of Typ associated
+ -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
+
+ procedure Initialize_Tag
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ Tag_Comp : Entity_Id;
+ Iface_Tag : Node_Id);
+ -- Initialize the tag of the secondary dispatch table of Typ associated
+ -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
+ -- Compiling under the CPP full ABI compatibility mode, if the ancestor
+ -- of Typ CPP tagged type we generate code to inherit the contents of
+ -- the dispatch table directly from the ancestor.
+
+ ---------------------
+ -- Inherit_CPP_Tag --
+ ---------------------
+
+ procedure Inherit_CPP_Tag
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ Tag_Comp : Entity_Id;
+ Iface_Tag : Node_Id)
+ is
+ begin
+ pragma Assert (Is_CPP_Class (Etype (Typ)));
+
+ Append_To (Stmts_List,
+ Build_Inherit_Prims (Loc,
+ Typ => Iface,
+ Old_Tag_Node =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Reference_To (Tag_Comp, Loc)),
+ New_Tag_Node =>
+ New_Reference_To (Iface_Tag, Loc),
+ Num_Prims =>
+ UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)))));
+ end Inherit_CPP_Tag;
+
+ --------------------
+ -- Initialize_Tag --
+ --------------------
+
+ procedure Initialize_Tag
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ Tag_Comp : Entity_Id;
+ Iface_Tag : Node_Id)
+ is
+ Comp_Typ : Entity_Id;
+ Offset_To_Top_Comp : Entity_Id := Empty;
+
+ begin
+ -- Initialize the pointer to the secondary DT associated with the
+ -- interface.
+
+ if not Is_Ancestor (Iface, Typ) then
+ Append_To (Stmts_List,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Reference_To (Tag_Comp, Loc)),
+ Expression =>
+ New_Reference_To (Iface_Tag, Loc)));
+ end if;
+
+ Comp_Typ := Scope (Tag_Comp);
+
+ -- Initialize the entries of the table of interfaces. We generate a
+ -- different call when the parent of the type has variable size
+ -- components.
+
+ if Comp_Typ /= Etype (Comp_Typ)
+ and then Is_Variable_Size_Record (Etype (Comp_Typ))
+ and then Chars (Tag_Comp) /= Name_uTag
+ then
+ pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
+
+ -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
+ -- configurable run-time environment.
+
+ if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
+ Error_Msg_CRT
+ ("variable size record with interface types", Typ);
+ return;
+ end if;
+
+ -- Generate:
+ -- Set_Dynamic_Offset_To_Top
+ -- (This => Init,
+ -- Interface_T => Iface'Tag,
+ -- Offset_Value => n,
+ -- Offset_Func => Fn'Address)
+
+ Append_To (Stmts_List,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To
+ (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Attribute_Name => Name_Address),
+
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Iface))),
+ Loc)),
+
+ Unchecked_Convert_To
+ (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc)),
+ Attribute_Name => Name_Position)),
+
+ Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To
+ (DT_Offset_To_Top_Func (Tag_Comp), Loc),
+ Attribute_Name => Name_Address)))));
+
+ -- In this case the next component stores the value of the
+ -- offset to the top.
+
+ Offset_To_Top_Comp := Next_Entity (Tag_Comp);
+ pragma Assert (Present (Offset_To_Top_Comp));
+
+ Append_To (Stmts_List,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Reference_To
+ (Offset_To_Top_Comp, Loc)),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc)),
+ Attribute_Name => Name_Position)));
+
+ -- Normal case: No discriminants in the parent type
+
+ else
+ -- Don't need to set any value if this interface shares
+ -- the primary dispatch table.
+
+ if not Is_Ancestor (Iface, Typ) then
+ Append_To (Stmts_List,
+ Build_Set_Static_Offset_To_Top (Loc,
+ Iface_Tag => New_Reference_To (Iface_Tag, Loc),
+ Offset_Value =>
+ Unchecked_Convert_To (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc)),
+ Attribute_Name => Name_Position))));
+ end if;
+
+ -- Generate:
+ -- Register_Interface_Offset
+ -- (This => Init,
+ -- Interface_T => Iface'Tag,
+ -- Is_Constant => True,
+ -- Offset_Value => n,
+ -- Offset_Func => null);
+
+ if RTE_Available (RE_Register_Interface_Offset) then
+ Append_To (Stmts_List,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To
+ (RTE (RE_Register_Interface_Offset), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Attribute_Name => Name_Address),
+
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
+
+ New_Occurrence_Of (Standard_True, Loc),
+
+ Unchecked_Convert_To
+ (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc)),
+ Attribute_Name => Name_Position)),
+
+ Make_Null (Loc))));
+ end if;
+ end if;
+ end Initialize_Tag;
+
+ -- Local variables
+
+ Full_Typ : Entity_Id;
+ Ifaces_List : Elist_Id;
+ Ifaces_Comp_List : Elist_Id;
+ Ifaces_Tag_List : Elist_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Comp_Elmt : Elmt_Id;
+ Iface_Tag_Elmt : Elmt_Id;
+ Tag_Comp : Node_Id;
+ In_Variable_Pos : Boolean;
+
+ -- Start of processing for Init_Secondary_Tags
+
+ begin
+ -- Handle private types
+
+ if Present (Full_View (Typ)) then
+ Full_Typ := Full_View (Typ);
+ else
+ Full_Typ := Typ;
+ end if;
+
+ Collect_Interfaces_Info
+ (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
+ Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List);
+ while Present (Iface_Elmt) loop
+ Tag_Comp := Node (Iface_Comp_Elmt);
+
+ -- If we are compiling under the CPP full ABI compatibility mode and
+ -- the ancestor is a CPP_Pragma tagged type then we generate code to
+ -- inherit the contents of the dispatch table directly from the
+ -- ancestor.
+
+ if Is_CPP_Class (Etype (Full_Typ)) then
+ Inherit_CPP_Tag (Full_Typ,
+ Iface => Node (Iface_Elmt),
+ Tag_Comp => Tag_Comp,
+ Iface_Tag => Node (Iface_Tag_Elmt));
+
+ -- Otherwise generate code to initialize the tag
+
+ else
+ -- Check if the parent of the record type has variable size
+ -- components.
+
+ In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
+ and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
+
+ if (In_Variable_Pos and then Variable_Comps)
+ or else (not In_Variable_Pos and then Fixed_Comps)
+ then
+ Initialize_Tag (Full_Typ,
+ Iface => Node (Iface_Elmt),
+ Tag_Comp => Tag_Comp,
+ Iface_Tag => Node (Iface_Tag_Elmt));
+ end if;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ Next_Elmt (Iface_Comp_Elmt);
+ Next_Elmt (Iface_Tag_Elmt);
+ end loop;
+ end Init_Secondary_Tags;
+
+ -----------------------------
+ -- Is_Variable_Size_Record --
+ -----------------------------
+
+ function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+ Comp_Typ : Entity_Id;
+ Idx : Node_Id;
+
+ function Is_Constant_Bound (Exp : Node_Id) return Boolean;
+ -- To simplify handling of array components. Determines whether the
+ -- given bound is constant (a constant or enumeration literal, or an
+ -- integer literal) as opposed to per-object, through an expression
+ -- or a discriminant.
+
+ -----------------------
+ -- Is_Constant_Bound --
+ -----------------------
+
+ function Is_Constant_Bound (Exp : Node_Id) return Boolean is
+ begin
+ if Nkind (Exp) = N_Integer_Literal then
+ return True;
+ else
+ return
+ Is_Entity_Name (Exp)
+ and then Present (Entity (Exp))
+ and then
+ (Ekind (Entity (Exp)) = E_Constant
+ or else Ekind (Entity (Exp)) = E_Enumeration_Literal);
+ end if;
+ end Is_Constant_Bound;
+
+ -- Start of processing for Is_Variable_Sized_Record
+
+ begin
+ pragma Assert (Is_Record_Type (E));
+
+ Comp := First_Entity (E);
+ while Present (Comp) loop
+ Comp_Typ := Etype (Comp);
+
+ if Is_Record_Type (Comp_Typ) then
+
+ -- Recursive call if the record type has discriminants
+
+ if Has_Discriminants (Comp_Typ)
+ and then Is_Variable_Size_Record (Comp_Typ)
+ then
+ return True;
+ end if;
+
+ elsif Is_Array_Type (Comp_Typ) then
+
+ -- Check if some index is initialized with a non-constant value
+
+ Idx := First_Index (Comp_Typ);
+ while Present (Idx) loop
+ if Nkind (Idx) = N_Range then
+ if not Is_Constant_Bound (Low_Bound (Idx))
+ or else
+ not Is_Constant_Bound (High_Bound (Idx))
+ then
+ return True;
+ end if;
+ end if;
+
+ Idx := Next_Index (Idx);
+ end loop;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ return False;
+ end Is_Variable_Size_Record;
+
+ ----------------------------------------
+ -- Make_Controlling_Function_Wrappers --
+ ----------------------------------------
+
+ procedure Make_Controlling_Function_Wrappers
+ (Tag_Typ : Entity_Id;
+ Decl_List : out List_Id;
+ Body_List : out List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Tag_Typ);
+ Prim_Elmt : Elmt_Id;
+ Subp : Entity_Id;
+ Actual_List : List_Id;
+ Formal_List : List_Id;
+ Formal : Entity_Id;
+ Par_Formal : Entity_Id;
+ Formal_Node : Node_Id;
+ Func_Body : Node_Id;
+ Func_Decl : Node_Id;
+ Func_Spec : Node_Id;
+ Return_Stmt : Node_Id;
+
+ begin
+ Decl_List := New_List;
+ Body_List := New_List;
+
+ Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+
+ while Present (Prim_Elmt) loop
+ Subp := Node (Prim_Elmt);
+
+ -- If a primitive function with a controlling result of the type has
+ -- not been overridden by the user, then we must create a wrapper
+ -- function here that effectively overrides it and invokes the
+ -- (non-abstract) parent function. This can only occur for a null
+ -- extension. Note that functions with anonymous controlling access
+ -- results don't qualify and must be overridden. We also exclude
+ -- Input attributes, since each type will have its own version of
+ -- Input constructed by the expander. The test for Comes_From_Source
+ -- is needed to distinguish inherited operations from renamings
+ -- (which also have Alias set).
+
+ -- The function may be abstract, or require_Overriding may be set
+ -- for it, because tests for null extensions may already have reset
+ -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
+ -- set, functions that need wrappers are recognized by having an
+ -- alias that returns the parent type.
+
+ if Comes_From_Source (Subp)
+ or else No (Alias (Subp))
+ or else Ekind (Subp) /= E_Function
+ or else not Has_Controlling_Result (Subp)
+ or else Is_Access_Type (Etype (Subp))
+ or else Is_Abstract_Subprogram (Alias (Subp))
+ or else Is_TSS (Subp, TSS_Stream_Input)
+ then
+ goto Next_Prim;
+
+ elsif Is_Abstract_Subprogram (Subp)
+ or else Requires_Overriding (Subp)
+ or else
+ (Is_Null_Extension (Etype (Subp))
+ and then Etype (Alias (Subp)) /= Etype (Subp))
+ then
+ Formal_List := No_List;
+ Formal := First_Formal (Subp);
+
+ if Present (Formal) then
+ Formal_List := New_List;
+
+ while Present (Formal) loop
+ Append
+ (Make_Parameter_Specification
+ (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Sloc (Formal),
+ Chars => Chars (Formal)),
+ In_Present => In_Present (Parent (Formal)),
+ Out_Present => Out_Present (Parent (Formal)),
+ Null_Exclusion_Present =>
+ Null_Exclusion_Present (Parent (Formal)),
+ Parameter_Type =>
+ New_Reference_To (Etype (Formal), Loc),
+ Expression =>
+ New_Copy_Tree (Expression (Parent (Formal)))),
+ Formal_List);
+
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ Func_Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Subp)),
+ Parameter_Specifications => Formal_List,
+ Result_Definition =>
+ New_Reference_To (Etype (Subp), Loc));
+
+ Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
+ Append_To (Decl_List, Func_Decl);
+
+ -- Build a wrapper body that calls the parent function. The body
+ -- contains a single return statement that returns an extension
+ -- aggregate whose ancestor part is a call to the parent function,
+ -- passing the formals as actuals (with any controlling arguments
+ -- converted to the types of the corresponding formals of the
+ -- parent function, which might be anonymous access types), and
+ -- having a null extension.
+
+ Formal := First_Formal (Subp);
+ Par_Formal := First_Formal (Alias (Subp));
+ Formal_Node := First (Formal_List);
+
+ if Present (Formal) then
+ Actual_List := New_List;
+ else
+ Actual_List := No_List;
+ end if;
+
+ while Present (Formal) loop
+ if Is_Controlling_Formal (Formal) then
+ Append_To (Actual_List,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Par_Formal), Loc),
+ Expression =>
+ New_Reference_To
+ (Defining_Identifier (Formal_Node), Loc)));
+ else
+ Append_To
+ (Actual_List,
+ New_Reference_To
+ (Defining_Identifier (Formal_Node), Loc));
+ end if;
+
+ Next_Formal (Formal);
+ Next_Formal (Par_Formal);
+ Next (Formal_Node);
+ end loop;
+
+ Return_Stmt :=
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Extension_Aggregate (Loc,
+ Ancestor_Part =>
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Alias (Subp), Loc),
+ Parameter_Associations => Actual_List),
+ Null_Record_Present => True));
+
+ Func_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification => New_Copy_Tree (Func_Spec),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Return_Stmt)));
+
+ Set_Defining_Unit_Name
+ (Specification (Func_Body),
+ Make_Defining_Identifier (Loc, Chars (Subp)));
+
+ Append_To (Body_List, Func_Body);
+
+ -- Replace the inherited function with the wrapper function
+ -- in the primitive operations list.
+
+ Override_Dispatching_Operation
+ (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec));
+ end if;
+
+ <<Next_Prim>>
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end Make_Controlling_Function_Wrappers;
+
------------------
-- Make_Eq_Case --
------------------
- -- <Make_Eq_if shared components>
+ -- <Make_Eq_If shared components>
-- case X.D1 is
-- when V1 => <Make_Eq_Case> on subcomponents
-- ...
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 =>
Make_Implicit_If_Statement (E,
Condition => Cond,
Then_Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))));
end if;
end if;
end Make_Eq_If;
+ -------------------------------
+ -- Make_Null_Procedure_Specs --
+ -------------------------------
+
+ procedure Make_Null_Procedure_Specs
+ (Tag_Typ : Entity_Id;
+ Decl_List : out List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Tag_Typ);
+
+ Formal : Entity_Id;
+ Formal_List : List_Id;
+ New_Param_Spec : Node_Id;
+ Parent_Subp : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Proc_Decl : Node_Id;
+ Subp : Entity_Id;
+
+ function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean;
+ -- Returns True if E is a null procedure that is an interface primitive
+
+ ---------------------------------
+ -- Is_Null_Interface_Primitive --
+ ---------------------------------
+
+ function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
+ begin
+ return Comes_From_Source (E)
+ and then Is_Dispatching_Operation (E)
+ and then Ekind (E) = E_Procedure
+ and then Null_Present (Parent (E))
+ and then Is_Interface (Find_Dispatching_Type (E));
+ end Is_Null_Interface_Primitive;
+
+ -- Start of processing for Make_Null_Procedure_Specs
+
+ begin
+ Decl_List := New_List;
+ Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+ while Present (Prim_Elmt) loop
+ Subp := Node (Prim_Elmt);
+
+ -- If a null procedure inherited from an interface has not been
+ -- overridden, then we build a null procedure declaration to
+ -- override the inherited procedure.
+
+ Parent_Subp := Alias (Subp);
+
+ if Present (Parent_Subp)
+ and then Is_Null_Interface_Primitive (Parent_Subp)
+ then
+ Formal_List := No_List;
+ Formal := First_Formal (Subp);
+
+ if Present (Formal) then
+ Formal_List := New_List;
+
+ while Present (Formal) loop
+
+ -- Copy the parameter spec including default expressions
+
+ New_Param_Spec :=
+ New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
+
+ -- Generate a new defining identifier for the new formal.
+ -- required because New_Copy_Tree does not duplicate
+ -- semantic fields (except itypes).
+
+ Set_Defining_Identifier (New_Param_Spec,
+ Make_Defining_Identifier (Sloc (Formal),
+ Chars => Chars (Formal)));
+
+ -- For controlling arguments we must change their
+ -- parameter type to reference the tagged type (instead
+ -- of the interface type)
+
+ if Is_Controlling_Formal (Formal) then
+ if Nkind (Parameter_Type (Parent (Formal)))
+ = N_Identifier
+ then
+ Set_Parameter_Type (New_Param_Spec,
+ New_Occurrence_Of (Tag_Typ, Loc));
+
+ else pragma Assert
+ (Nkind (Parameter_Type (Parent (Formal)))
+ = N_Access_Definition);
+ Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
+ New_Occurrence_Of (Tag_Typ, Loc));
+ end if;
+ end if;
+
+ Append (New_Param_Spec, Formal_List);
+
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ Proc_Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Subp)),
+ Parameter_Specifications => Formal_List,
+ Null_Present => True));
+ Append_To (Decl_List, Proc_Decl);
+ Analyze (Proc_Decl);
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end Make_Null_Procedure_Specs;
+
-------------------------------------
-- Make_Predefined_Primitive_Specs --
-------------------------------------
procedure Make_Predefined_Primitive_Specs
(Tag_Typ : Entity_Id;
Predef_List : out List_Id;
- Renamed_Eq : out Node_Id)
+ Renamed_Eq : out Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : constant List_Id := New_List;
Ret_Type => Standard_Integer));
- -- Specs for dispatching stream attributes.
+ -- Specs for dispatching stream attributes
declare
Stream_Op_TSS_Names :
TSS_Stream_Write,
TSS_Stream_Input,
TSS_Stream_Output);
+
begin
for Op in Stream_Op_TSS_Names'Range loop
if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
Append_To (Res,
- Predef_Stream_Attr_Spec (Loc, Tag_Typ,
- Stream_Op_TSS_Names (Op)));
+ Predef_Stream_Attr_Spec (Loc, Tag_Typ,
+ Stream_Op_TSS_Names (Op)));
end if;
end loop;
end;
- -- Spec of "=" if expanded if the type is not limited and if a
+ -- Spec of "=" is expanded if the type is not limited and if a
-- user defined "=" was not already declared for the non-full
-- view of a private extension
if not Is_Limited_Type (Tag_Typ) then
Eq_Needed := True;
-
Prim := First_Elmt (Primitive_Operations (Tag_Typ));
while Present (Prim) loop
if Is_Predefined_Eq_Renaming (Node (Prim)) then
Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
+ -- User-defined equality
+
elsif Chars (Node (Prim)) = Name_Op_Eq
- and then (No (Alias (Node (Prim)))
- or else Nkind (Unit_Declaration_Node (Node (Prim))) =
- N_Subprogram_Renaming_Declaration)
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
and then Base_Type (Etype (Node (Prim))) = Standard_Boolean
-
then
- Eq_Needed := False;
- exit;
+ if No (Alias (Node (Prim)))
+ or else Nkind (Unit_Declaration_Node (Node (Prim))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ Eq_Needed := False;
+ exit;
- -- If the parent equality is abstract, the inherited equality is
- -- abstract as well, and no body can be created for for it.
+ -- If the parent is not an interface type and has an abstract
+ -- equality function, the inherited equality is abstract as
+ -- well, and no body can be created for it.
- elsif Chars (Node (Prim)) = Name_Op_Eq
- and then Present (Alias (Node (Prim)))
- and then Is_Abstract (Alias (Node (Prim)))
- then
- Eq_Needed := False;
- exit;
+ elsif not Is_Interface (Etype (Tag_Typ))
+ and then Present (Alias (Node (Prim)))
+ and then Is_Abstract_Subprogram (Alias (Node (Prim)))
+ then
+ Eq_Needed := False;
+ exit;
+
+ -- If the type has an equality function corresponding with
+ -- a primitive defined in an interface type, the inherited
+ -- equality is abstract as well, and no body can be created
+ -- for it.
+
+ elsif Present (Alias (Node (Prim)))
+ and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
+ and then
+ Is_Interface
+ (Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
+ then
+ Eq_Needed := False;
+ exit;
+ end if;
end if;
Next_Elmt (Prim);
end loop;
- -- If a renaming of predefined equality was found
- -- but there was no user-defined equality (so Eq_Needed
- -- is still true), then set the name back to Name_Op_Eq.
- -- But in the case where a user-defined equality was
- -- located after such a renaming, then the predefined
- -- equality function is still needed, so Eq_Needed must
- -- be set back to True.
+ -- If a renaming of predefined equality was found but there was no
+ -- user-defined equality (so Eq_Needed is still true), then set the
+ -- name back to Name_Op_Eq. But in the case where a user-defined
+ -- equality was located after such a renaming, then the predefined
+ -- equality function is still needed, so Eq_Needed must be set back
+ -- to True.
if Eq_Name /= Name_Op_Eq then
if Eq_Needed then
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;
- -- 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
+ -- Ada 2005: Generate declarations for the following primitive
+ -- operations for limited interfaces and synchronized types that
+ -- implement a limited interface.
+
+ -- Disp_Asynchronous_Select
+ -- Disp_Conditional_Select
+ -- Disp_Get_Prim_Op_Kind
+ -- Disp_Get_Task_Id
+ -- Disp_Requeue
+ -- Disp_Timed_Select
+
+ -- These operations cannot be implemented on VM targets, so we simply
+ -- disable their generation in this case. Disable the generation of
+ -- these bodies if No_Dispatching_Calls, Ravenscar or ZFP is active.
+
+ if Ada_Version >= Ada_05
+ and then Tagged_Type_Expansion
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
+ and then RTE_Available (RE_Select_Specific_Data)
+ then
+ -- These primitives are defined abstract in interface types
+
+ if Is_Interface (Tag_Typ)
+ and then Is_Limited_Record (Tag_Typ)
+ then
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Requeue_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Tag_Typ)));
+
+ -- If the ancestor is an interface type we declare non-abstract
+ -- primitives to override the abstract primitives of the interface
+ -- type.
+
+ elsif (not Is_Interface (Tag_Typ)
+ and then Is_Interface (Etype (Tag_Typ))
+ and then Is_Limited_Record (Etype (Tag_Typ)))
+ or else
+ (Is_Concurrent_Record_Type (Tag_Typ)
+ and then Has_Interfaces (Tag_Typ))
+ then
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Requeue_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Tag_Typ)));
+ end if;
+ end if;
+
+ -- Specs for finalization actions that may be required in case a future
+ -- extension contain a controlled element. We generate those only for
+ -- root tagged types where they will get dummy bodies or when the type
+ -- has controlled components and their body must be generated. It is
+ -- also impossible to provide those for tagged types defined within
+ -- s-finimp since it would involve circularity problems
if In_Finalization_Root (Tag_Typ) then
null;
elsif Restriction_Active (No_Finalization) then
null;
- elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then
+ -- Skip these for CIL Value types, where finalization is not available
+
+ elsif Is_Value_Type (Tag_Typ) then
+ null;
+
+ elsif Etype (Tag_Typ) = Tag_Typ
+ or else Needs_Finalization (Tag_Typ)
+
+ -- Ada 2005 (AI-251): We must also generate these subprograms if
+ -- the immediate ancestor is an interface to ensure the correct
+ -- initialization of its dispatch table.
+
+ or else (not Is_Interface (Tag_Typ)
+ and then Is_Interface (Etype (Tag_Typ)))
+
+ -- Ada 205 (AI-251): We must also generate these subprograms if
+ -- the parent of an nonlimited interface is a limited interface
+
+ or else (Is_Interface (Tag_Typ)
+ and then not Is_Limited_Interface (Tag_Typ)
+ and then Is_Limited_Interface (Etype (Tag_Typ)))
+ then
if not Is_Limited_Type (Tag_Typ) then
Append_To (Res,
Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
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);
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => Profile,
- Subtype_Mark =>
+ Result_Definition =>
New_Reference_To (Ret_Type, Loc));
end if;
- -- If body case, return empty subprogram body. Note that this is
- -- ill-formed, because there is not even a null statement, and
- -- certainly not a return in the function case. The caller is
- -- expected to do surgery on the body to add the appropriate stuff.
+ if Is_Interface (Tag_Typ) then
+ return Make_Abstract_Subprogram_Declaration (Loc, Spec);
+
+ -- If body case, return empty subprogram body. Note that this is ill-
+ -- formed, because there is not even a null statement, and certainly not
+ -- a return in the function case. The caller is expected to do surgery
+ -- on the body to add the appropriate stuff.
- if For_Body then
+ elsif For_Body then
return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
- -- For the case of Input/Output attributes applied to an abstract type,
- -- generate abstract specifications. These will never be called,
- -- but we need the slots allocated in the dispatching table so
- -- that typ'Class'Input and typ'Class'Output will work properly.
+ -- For the case of an Input attribute predefined for an abstract type,
+ -- generate an abstract specification. This will never be called, but we
+ -- need the slot allocated in the dispatching table so that attributes
+ -- typ'Class'Input and typ'Class'Output will work properly.
- elsif (Is_TSS (Name, TSS_Stream_Input)
- or else
- Is_TSS (Name, TSS_Stream_Output))
- and then Is_Abstract (Tag_Typ)
+ elsif Is_TSS (Name, TSS_Stream_Input)
+ and then Is_Abstract_Type (Tag_Typ)
then
return Make_Abstract_Subprogram_Declaration (Loc, Spec);
function Predefined_Primitive_Bodies
(Tag_Typ : Entity_Id;
- Renamed_Eq : Node_Id) return List_Id
+ Renamed_Eq : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : constant List_Id := New_List;
Eq_Name : Name_Id;
Ent : Entity_Id;
+ pragma Warnings (Off, Ent);
+
begin
+ pragma Assert (not Is_Interface (Tag_Typ));
+
-- See if we have a predefined "=" operator
if Present (Renamed_Eq) then
Eq_Needed := True;
Eq_Name := Chars (Renamed_Eq);
+ -- If the parent is an interface type then it has defined all the
+ -- predefined primitives abstract and we need to check if the type
+ -- has some user defined "=" function to avoid generating it.
+
+ elsif Is_Interface (Etype (Tag_Typ)) then
+ Eq_Needed := True;
+ Eq_Name := Name_Op_Eq;
+
+ Prim := First_Elmt (Primitive_Operations (Tag_Typ));
+ while Present (Prim) loop
+ if Chars (Node (Prim)) = Name_Op_Eq
+ and then not Is_Internal (Node (Prim))
+ then
+ Eq_Needed := False;
+ Eq_Name := No_Name;
+ exit;
+ end if;
+
+ Next_Elmt (Prim);
+ end loop;
+
else
Eq_Needed := False;
Eq_Name := No_Name;
then
Eq_Needed := True;
Eq_Name := Name_Op_Eq;
+ exit;
end if;
Next_Elmt (Prim);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_X),
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_X),
Append_To (Res, Decl);
end if;
- -- Skip bodies of _Input and _Output for the abstract case, since
- -- the corresponding specs are abstract (see Predef_Spec_Or_Body)
+ -- Skip body of _Input for the abstract case, since the corresponding
+ -- spec is abstract (see Predef_Spec_Or_Body).
- if not Is_Abstract (Tag_Typ) then
- if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
- and then No (TSS (Tag_Typ, TSS_Stream_Input))
- then
- Build_Record_Or_Elementary_Input_Function
- (Loc, Tag_Typ, Decl, Ent);
- Append_To (Res, Decl);
- end if;
+ if not Is_Abstract_Type (Tag_Typ)
+ and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
+ and then No (TSS (Tag_Typ, TSS_Stream_Input))
+ then
+ Build_Record_Or_Elementary_Input_Function
+ (Loc, Tag_Typ, Decl, Ent);
+ Append_To (Res, Decl);
+ end if;
- if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
- and then No (TSS (Tag_Typ, TSS_Stream_Output))
- then
- Build_Record_Or_Elementary_Output_Procedure
- (Loc, Tag_Typ, Decl, Ent);
- Append_To (Res, Decl);
- end if;
+ if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
+ and then No (TSS (Tag_Typ, TSS_Stream_Output))
+ then
+ Build_Record_Or_Elementary_Output_Procedure
+ (Loc, Tag_Typ, Decl, Ent);
+ Append_To (Res, Decl);
end if;
- if not Is_Limited_Type (Tag_Typ) then
+ -- Ada 2005: Generate bodies for the following primitive operations for
+ -- limited interfaces and synchronized types that implement a limited
+ -- interface.
+
+ -- disp_asynchronous_select
+ -- disp_conditional_select
+ -- disp_get_prim_op_kind
+ -- disp_get_task_id
+ -- disp_timed_select
+
+ -- The interface versions will have null bodies
+
+ -- These operations cannot be implemented on VM targets, so we simply
+ -- disable their generation in this case. Disable the generation of
+ -- these bodies if No_Dispatching_Calls, Ravenscar or ZFP is active.
+
+ if Ada_Version >= Ada_05
+ and then Tagged_Type_Expansion
+ and then not Is_Interface (Tag_Typ)
+ and then
+ ((Is_Interface (Etype (Tag_Typ))
+ and then Is_Limited_Record (Etype (Tag_Typ)))
+ or else (Is_Concurrent_Record_Type (Tag_Typ)
+ and then Has_Interfaces (Tag_Typ)))
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
+ and then RTE_Available (RE_Select_Specific_Data)
+ then
+ Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
+ Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
+ Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
+ Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ));
+ Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ));
+ Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
+ end if;
+ if not Is_Limited_Type (Tag_Typ)
+ and then not Is_Interface (Tag_Typ)
+ then
-- Body for equality
if Eq_Needed then
+ Decl :=
+ Predef_Spec_Or_Body (Loc,
+ Tag_Typ => Tag_Typ,
+ Name => Eq_Name,
+ Profile => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_X),
+ Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
- Decl := Predef_Spec_Or_Body (Loc,
- Tag_Typ => Tag_Typ,
- Name => Eq_Name,
- Profile => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_X),
- Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Y),
- Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Y),
+ Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
- Ret_Type => Standard_Boolean,
- For_Body => True);
+ Ret_Type => Standard_Boolean,
+ For_Body => True);
declare
Def : constant Node_Id := Parent (Tag_Typ);
Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def)));
Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps));
Append_To (Stmts,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (Standard_True, Loc)));
else
Append_To (Stmts,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Expand_Record_Equality (Tag_Typ,
Typ => Tag_Typ,
-- Body for dispatching assignment
- Decl := Predef_Spec_Or_Body (Loc,
- Tag_Typ => Tag_Typ,
- Name => Name_uAssign,
- Profile => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
- Out_Present => True,
- Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
- Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
- For_Body => True);
+ Decl :=
+ Predef_Spec_Or_Body (Loc,
+ Tag_Typ => Tag_Typ,
+ Name => Name_uAssign,
+ Profile => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
+ Out_Present => True,
+ Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
+ Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
+ For_Body => True);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List (
elsif Restriction_Active (No_Finalization) then
null;
- elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ))
+ elsif (Etype (Tag_Typ) = Tag_Typ
+ or else Is_Controlled (Tag_Typ)
+
+ -- Ada 2005 (AI-251): We must also generate these subprograms
+ -- if the immediate ancestor of Tag_Typ is an interface to
+ -- ensure the correct initialization of its dispatch table.
+
+ or else (not Is_Interface (Tag_Typ)
+ and then
+ Is_Interface (Etype (Tag_Typ))))
and then not Has_Controlled_Component (Tag_Typ)
then
if not Is_Limited_Type (Tag_Typ) then
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
(Typ : Entity_Id;
Operation : TSS_Name_Type) return Boolean
is
- Has_Inheritable_Stream_Attribute : Boolean := False;
+ Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
begin
+ -- Special case of a limited type extension: a default implementation
+ -- of the stream attributes Read or Write exists if that attribute
+ -- has been specified or is available for an ancestor type; a default
+ -- implementation of the attribute Output (resp. Input) exists if the
+ -- attribute has been specified or Write (resp. Read) is available for
+ -- an ancestor type. The last condition only applies under Ada 2005.
+
if Is_Limited_Type (Typ)
and then Is_Tagged_Type (Typ)
- and then Is_Derived_Type (Typ)
then
- -- Special case of a limited type extension: a default implementation
- -- of the stream attributes Read and Write exists if the attribute
- -- has been specified for an ancestor type.
+ if Operation = TSS_Stream_Read then
+ Has_Predefined_Or_Specified_Stream_Attribute :=
+ Has_Specified_Stream_Read (Typ);
+
+ elsif Operation = TSS_Stream_Write then
+ Has_Predefined_Or_Specified_Stream_Attribute :=
+ Has_Specified_Stream_Write (Typ);
+
+ elsif Operation = TSS_Stream_Input then
+ Has_Predefined_Or_Specified_Stream_Attribute :=
+ Has_Specified_Stream_Input (Typ)
+ or else
+ (Ada_Version >= Ada_05
+ and then Stream_Operation_OK (Typ, TSS_Stream_Read));
+
+ elsif Operation = TSS_Stream_Output then
+ Has_Predefined_Or_Specified_Stream_Attribute :=
+ Has_Specified_Stream_Output (Typ)
+ or else
+ (Ada_Version >= Ada_05
+ and then Stream_Operation_OK (Typ, TSS_Stream_Write));
+ end if;
+
+ -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
- Has_Inheritable_Stream_Attribute :=
- Present (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
+ if not Has_Predefined_Or_Specified_Stream_Attribute
+ and then Is_Derived_Type (Typ)
+ and then (Operation = TSS_Stream_Read
+ or else Operation = TSS_Stream_Write)
+ then
+ Has_Predefined_Or_Specified_Stream_Attribute :=
+ Present
+ (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
+ end if;
end if;
- return
- not (Is_Limited_Type (Typ)
- and then not Has_Inheritable_Stream_Attribute)
- and then RTE_Available (RE_Tag)
- and then RTE_Available (RE_Root_Stream_Type)
- and then not Restriction_Active (No_Dispatch)
- and then not Restriction_Active (No_Streams);
+ -- If the type is not limited, or else is limited but the attribute is
+ -- explicitly specified or is predefined for the type, then return True,
+ -- unless other conditions prevail, such as restrictions prohibiting
+ -- streams or dispatching operations. We also return True for limited
+ -- interfaces, because they may be extended by nonlimited types and
+ -- permit inheritance in this case (addresses cases where an abstract
+ -- extension doesn't get 'Input declared, as per comments below, but
+ -- 'Class'Input must still be allowed). Note that attempts to apply
+ -- stream attributes to a limited interface or its class-wide type
+ -- (or limited extensions thereof) will still get properly rejected
+ -- by Check_Stream_Attribute.
+
+ -- We exclude the Input operation from being a predefined subprogram in
+ -- the case where the associated type is an abstract extension, because
+ -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
+ -- we don't want an abstract version created because types derived from
+ -- the abstract type may not even have Input available (for example if
+ -- derived from a private view of the abstract type that doesn't have
+ -- a visible Input), but a VM such as .NET or the Java VM can treat the
+ -- operation as inherited anyway, and we don't want an abstract function
+ -- to be (implicitly) inherited in that case because it can lead to a VM
+ -- exception.
+
+ return (not Is_Limited_Type (Typ)
+ or else Is_Interface (Typ)
+ or else Has_Predefined_Or_Specified_Stream_Attribute)
+ and then (Operation /= TSS_Stream_Input
+ or else not Is_Abstract_Type (Typ)
+ or else not Is_Derived_Type (Typ))
+ and then not Has_Unknown_Discriminants (Typ)
+ and then not (Is_Interface (Typ)
+ and then (Is_Task_Interface (Typ)
+ or else Is_Protected_Interface (Typ)
+ or else Is_Synchronized_Interface (Typ)))
+ and then not Restriction_Active (No_Streams)
+ and then not Restriction_Active (No_Dispatch)
+ and then not No_Run_Time_Mode
+ and then RTE_Available (RE_Tag)
+ and then RTE_Available (RE_Root_Stream_Type);
end Stream_Operation_OK;
+
end Exp_Ch3;
OSDN Git Service
