Google Git
Sign in
gnu / gcc / 926d9947847a0683cf34de6fc231209747576088 / . / gcc / ada / exp_ch3.adb
blob: 0baa3f68edc59ff9b3cd36b471d74010291e2b00 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 3 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Atag; use Exp_Atag;
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Smem; use Exp_Smem;
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Ghost; use Ghost;
with Inline; use Inline;
with Namet; use Namet;
with Nlists; use Nlists;
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_Ch13; use Sem_Ch13;
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;
package body Exp_Ch3 is
-----------------------
-- Local Subprograms --
-----------------------
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
-- the record can be calculated more accurately. See the body of this
-- procedure for details.
procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
-- Build initialization procedure for given array type. Nod is a node
-- used for attachment of any actions required in its construction.
-- It also supplies the source location used for the procedure.
function Build_Array_Invariant_Proc
(A_Type : Entity_Id;
Nod : Node_Id) return Node_Id;
-- If the component of type of array type has invariants, build procedure
-- that checks invariant on all components of the array. Ada 2012 specifies
-- that an invariant on some type T must be applied to in-out parameters
-- and return values that include a part of type T. If the array type has
-- an otherwise specified invariant, the component check procedure is
-- called from within the user-specified invariant. Otherwise this becomes
-- the invariant procedure for the array type.
function Build_Record_Invariant_Proc
(R_Type : Entity_Id;
Nod : Node_Id) return Node_Id;
-- Ditto for record types.
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 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.
procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id);
-- Build record initialization procedure. N is the type declaration
-- node, and Rec_Ent is the corresponding entity for the record type.
procedure Build_Slice_Assignment (Typ : Entity_Id);
-- Build assignment procedure for one-dimensional arrays of controlled
-- types. Other array and slice assignments are expanded in-line, but
-- the code expansion for controlled components (when control actions
-- are active) can lead to very large blocks that GCC3 handles poorly.
procedure Build_Untagged_Equality (Typ : Entity_Id);
-- AI05-0123: Equality on untagged records composes. This procedure
-- builds the equality routine for an untagged record that has components
-- of a record type that has user-defined primitive equality operations.
-- The resulting operation is a TSS subprogram.
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
-- Create An Equality function for the untagged variant record Typ 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-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_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 Expand_Freeze_Class_Wide_Type (N : Node_Id);
-- Freeze a class-wide type. Build routine Finalize_Address for the purpose
-- of finalizing controlled derivations from the class-wide's root type.
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 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
-- applies only to E_Record_Type entities, not to class wide types,
-- record subtypes, or private types.
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 type, the _Tag field being inherited by the descendants.
procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
-- Treat user-defined stream operations as renaming_as_body if the
-- subprogram they rename is not frozen when the type is frozen.
procedure Insert_Component_Invariant_Checks
(N : Node_Id;
Typ : Entity_Id;
Proc : Node_Id);
-- If a composite type has invariants and also has components with defined
-- invariants. the component invariant procedure is inserted into the user-
-- defined invariant procedure and added to the checks to be performed.
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
-- record types and types containing tasks, three additional formals are
-- added:
--
-- _Master : Master_Id
-- _Chain : in out Activation_Chain
-- _Task_Name : String
--
-- The caller must append additional entries for discriminants if required.
function In_Runtime (E : Entity_Id) return Boolean;
-- 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_User_Defined_Equality (Prim : Node_Id) return Boolean;
-- Returns true if Prim is a user defined equality function
function Make_Eq_Body
(Typ : Entity_Id;
Eq_Name : Name_Id) return Node_Id;
-- Build the body of a primitive equality operation for a tagged record
-- type, or in Ada 2012 for any record type that has components with a
-- user-defined equality. Factored out of Predefined_Primitive_Bodies.
function Make_Eq_Case
(E : Entity_Id;
CL : Node_Id;
Discrs : Elist_Id := New_Elmt_List) return List_Id;
-- Building block for variant record equality. Defined to share the code
-- between the tagged and untagged 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.
--
-- IF E is an unchecked_union, Discrs is the list of formals created for
-- the inferred discriminants of one operand. These formals are used in
-- the generated case statements for each variant of the unchecked union.
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 untagged 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.
function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id;
-- Search for a renaming of the inequality dispatching primitive of
-- this tagged type. If found then build and return the corresponding
-- rename-as-body inequality subprogram; otherwise return Empty.
procedure Make_Predefined_Primitive_Specs
(Tag_Typ : Entity_Id;
Predef_List : out List_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
-- will vary with the actual object subtype.
--
-- _size provides result of 'Size attribute
-- typSR provides result of 'Read attribute
-- typSW provides result of 'Write 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:
--
-- _equality implements "=" operator
-- _assign implements assignment operation
-- typDF implements deep finalization
-- 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.
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.
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.
function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return 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;
Tag_Typ : Entity_Id;
Name : Name_Id;
Profile : List_Id;
Ret_Type : Entity_Id := Empty;
For_Body : Boolean := False) return Node_Id;
-- This function generates the appropriate expansion for a predefined
-- primitive operation specified by its name, parameter profile and
-- return type (Empty means this is a procedure). If For_Body is false,
-- then the returned node is a subprogram declaration. If For_Body is
-- true, then the returned node is a empty subprogram body containing
-- no declarations and no statements.
function Predef_Stream_Attr_Spec
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : TSS_Name_Type;
For_Body : Boolean := False) return Node_Id;
-- Specialized version of Predef_Spec_Or_Body that apply to read, write,
-- input and output attribute whose specs are constructed in Exp_Strm.
function Predef_Deep_Spec
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : TSS_Name_Type;
For_Body : Boolean := False) return Node_Id;
-- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
-- and _deep_finalize
function Predefined_Primitive_Bodies
(Tag_Typ : Entity_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
-- by Make_Predefined_Primitive_Specs.
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 freezing.
function Stream_Operation_OK
(Typ : Entity_Id;
Operation : TSS_Name_Type) return Boolean;
-- Check whether the named stream operation must be emitted for a given
-- type. The rules for inheritance of stream attributes by type extensions
-- are enforced by this function. Furthermore, various restrictions prevent
-- the generation of these operations, as a useful optimization or for
-- certification purposes and to save unnecessary generated code.
--------------------------
-- 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 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:
-- subtype B is range 1 .. 10;
-- type Q is array (B range <>) of Integer;
-- type V (N : Natural) is record
-- C : Q (1 .. N);
-- end record;
-- In this situation, we can restrict the upper bound of N to 10, since
-- any larger value would cause a constraint error in any case.
-- There are many situations in which such restriction is possible, but
-- for now, we just look for cases like the above, where the component
-- in question is a one dimensional array whose upper bound is one of
-- the record discriminants. Also the component must not be part of
-- any variant part, since then the component does not always exist.
procedure Adjust_Discriminants (Rtype : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Rtype);
Comp : Entity_Id;
Ctyp : Entity_Id;
Ityp : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
P : Node_Id;
Loval : Uint;
Discr : Entity_Id;
Dtyp : Entity_Id;
Dhi : Node_Id;
Dhiv : Uint;
Ahi : Node_Id;
Ahiv : Uint;
Tnn : Entity_Id;
begin
Comp := First_Component (Rtype);
while Present (Comp) loop
-- If our parent is a variant, quit, we do not look at components
-- that are in variant parts, because they may not always exist.
P := Parent (Comp); -- component declaration
P := Parent (P); -- component list
exit when Nkind (Parent (P)) = N_Variant;
-- We are looking for a one dimensional array type
Ctyp := Etype (Comp);
if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then
goto Continue;
end if;
-- The lower bound must be constant, and the upper bound is a
-- discriminant (which is a discriminant of the current record).
Ityp := Etype (First_Index (Ctyp));
Lo := Type_Low_Bound (Ityp);
Hi := Type_High_Bound (Ityp);
if not Compile_Time_Known_Value (Lo)
or else Nkind (Hi) /= N_Identifier
or else No (Entity (Hi))
or else Ekind (Entity (Hi)) /= E_Discriminant
then
goto Continue;
end if;
-- We have an array with appropriate bounds
Loval := Expr_Value (Lo);
Discr := Entity (Hi);
Dtyp := Etype (Discr);
-- See if the discriminant has a known upper bound
Dhi := Type_High_Bound (Dtyp);
if not Compile_Time_Known_Value (Dhi) then
goto Continue;
end if;
Dhiv := Expr_Value (Dhi);
-- See if base type of component array has known upper bound
Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
if not Compile_Time_Known_Value (Ahi) then
goto Continue;
end if;
Ahiv := Expr_Value (Ahi);
-- The condition for doing the restriction is that the high bound
-- of the discriminant is greater than the low bound of the array,
-- and is also greater than the high bound of the base type index.
if Dhiv > Loval and then Dhiv > Ahiv then
-- We can reset the upper bound of the discriminant type to
-- whichever is larger, the low bound of the component, or
-- the high bound of the base type array index.
-- We build a subtype that is declared as
-- subtype Tnn is discr_type range discr_type'First .. max;
-- And insert this declaration into the tree. The type of the
-- discriminant is then reset to this more restricted subtype.
Tnn := Make_Temporary (Loc, 'T');
Insert_Action (Declaration_Node (Rtype),
Make_Subtype_Declaration (Loc,
Defining_Identifier => Tnn,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
Constraint =>
Make_Range_Constraint (Loc,
Range_Expression =>
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix => New_Occurrence_Of (Dtyp, Loc)),
High_Bound =>
Make_Integer_Literal (Loc,
Intval => UI_Max (Loval, Ahiv)))))));
Set_Etype (Discr, Tnn);
end if;
<<Continue>>
Next_Component (Comp);
end loop;
end Adjust_Discriminants;
---------------------------
-- Build_Array_Init_Proc --
---------------------------
procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
Comp_Type : constant Entity_Id := Component_Type (A_Type);
Body_Stmts : List_Id;
Has_Default_Init : Boolean;
Index_List : List_Id;
Loc : Source_Ptr;
Proc_Id : Entity_Id;
function Init_Component return List_Id;
-- Create one statement to initialize one array component, designated
-- by a full set of indexes.
function Init_One_Dimension (N : Int) return List_Id;
-- Create loop to initialize one dimension of the array. The single
-- statement in the loop body initializes the inner dimensions if any,
-- or else the single component. Note that this procedure is called
-- recursively, with N being the dimension to be initialized. A call
-- with N greater than the number of dimensions simply generates the
-- component initialization, terminating the recursion.
--------------------
-- Init_Component --
--------------------
function Init_Component return List_Id is
Comp : Node_Id;
begin
Comp :=
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Expressions => Index_List);
if Has_Default_Aspect (A_Type) then
Set_Assignment_OK (Comp);
return New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Expression =>
Convert_To (Comp_Type,
Default_Aspect_Component_Value (First_Subtype (A_Type)))));
elsif Needs_Simple_Initialization (Comp_Type) then
Set_Assignment_OK (Comp);
return New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Expression =>
Get_Simple_Init_Val
(Comp_Type, Nod, Component_Size (A_Type))));
else
Clean_Task_Names (Comp_Type, Proc_Id);
return
Build_Initialization_Call
(Loc, Comp, Comp_Type,
In_Init_Proc => True,
Enclos_Type => A_Type);
end if;
end Init_Component;
------------------------
-- Init_One_Dimension --
------------------------
function Init_One_Dimension (N : Int) return List_Id is
Index : Entity_Id;
begin
-- If the component does not need initializing, then there is nothing
-- to do here, so we return a null body. This occurs when generating
-- the dummy Init_Proc needed for Initialize_Scalars processing.
if not Has_Non_Null_Base_Init_Proc (Comp_Type)
and then not Needs_Simple_Initialization (Comp_Type)
and then not Has_Task (Comp_Type)
and then not Has_Default_Aspect (A_Type)
then
return New_List (Make_Null_Statement (Loc));
-- If all dimensions dealt with, we simply initialize the component
elsif N > Number_Dimensions (A_Type) then
return Init_Component;
-- Here we generate the required loop
else
Index :=
Make_Defining_Identifier (Loc, New_External_Name ('J', N));
Append (New_Occurrence_Of (Index, Loc), Index_List);
return New_List (
Make_Implicit_Loop_Statement (Nod,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Index,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix =>
Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, N))))),
Statements => Init_One_Dimension (N + 1)));
end if;
end Init_One_Dimension;
-- Start of processing for Build_Array_Init_Proc
begin
-- The init proc is created when analyzing the freeze node for the type,
-- but it properly belongs with the array type declaration. However, if
-- the freeze node is for a subtype of a type declared in another unit
-- it seems preferable to use the freeze node as the source location of
-- the init proc. In any case this is preferable for gcov usage, and
-- the Sloc is not otherwise used by the compiler.
if In_Open_Scopes (Scope (A_Type)) then
Loc := Sloc (A_Type);
else
Loc := Sloc (Nod);
end if;
-- 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 Initialization_Suppressed (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;
Index_List := New_List;
-- We need an initialization procedure if any of the following is true:
-- 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 public entity
-- 5. The array type has a Default_Component_Value aspect
-- 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
-- not in the declaring package, this means the client will make a call
-- to the initialization procedure (because one of conditions 1-3 must
-- apply in this case), and we must generate a procedure (even if it is
-- null) to satisfy the call in this case.
-- Exception: do not build an array init_proc for a type whose root
-- type is Standard.String or Standard.Wide_[Wide_]String, since there
-- is no place to put the code, and in any case we handle initialization
-- of such types (in the Initialize_Scalars case, that's the only time
-- the issue arises) in a special manner anyway which does not need an
-- init_proc.
Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
or else Needs_Simple_Initialization (Comp_Type)
or else Has_Task (Comp_Type)
or else Has_Default_Aspect (A_Type);
if Has_Default_Init
or else (not Restriction_Active (No_Initialize_Scalars)
and then Is_Public (A_Type)
and then not Is_Standard_String_Type (A_Type))
then
Proc_Id :=
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);
Discard_Node (
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
Parameter_Specifications => Init_Formals (A_Type)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Body_Stmts)));
Set_Ekind (Proc_Id, E_Procedure);
Set_Is_Public (Proc_Id, Is_Public (A_Type));
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Proc_Id);
end if;
-- Set inlined unless controlled stuff or tasks around, in which
-- case we do not want to inline, because nested stuff may cause
-- 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 Needs_Finalization (Proc_Id)
then
Set_Is_Inlined (Proc_Id);
end if;
-- Associate Init_Proc with type, and determine if the procedure
-- is null (happens because of the Initialize_Scalars pragma case,
-- where we have to generate a null procedure in case it is called
-- by a client with Initialize_Scalars set). Such procedures have
-- to be generated, but do not have to be called, so we mark them
-- as null to suppress the call.
Set_Init_Proc (A_Type, Proc_Id);
if List_Length (Body_Stmts) = 1
-- 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 statically initialize
-- 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;
--------------------------------
-- Build_Array_Invariant_Proc --
--------------------------------
function Build_Array_Invariant_Proc
(A_Type : Entity_Id;
Nod : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of invariant procedure
Object_Entity : constant Node_Id :=
Make_Defining_Identifier (Loc, Object_Name);
-- The procedure declaration entity for the argument
Body_Stmts : List_Id;
Index_List : List_Id;
Proc_Id : Entity_Id;
Proc_Body : Node_Id;
function Build_Component_Invariant_Call return Node_Id;
-- Create one statement to verify invariant on one array component,
-- designated by a full set of indexes.
function Check_One_Dimension (N : Int) return List_Id;
-- Create loop to check on one dimension of the array. The single
-- statement in the loop body checks the inner dimensions if any, or
-- else a single component. This procedure is called recursively, with
-- N being the dimension to be initialized. A call with N greater than
-- the number of dimensions generates the component initialization
-- and terminates the recursion.
------------------------------------
-- Build_Component_Invariant_Call --
------------------------------------
function Build_Component_Invariant_Call return Node_Id is
Comp : Node_Id;
begin
Comp :=
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (Object_Entity, Loc),
Expressions => Index_List);
return
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(Invariant_Procedure (Component_Type (A_Type)), Loc),
Parameter_Associations => New_List (Comp));
end Build_Component_Invariant_Call;
-------------------------
-- Check_One_Dimension --
-------------------------
function Check_One_Dimension (N : Int) return List_Id is
Index : Entity_Id;
begin
-- If all dimensions dealt with, we simply check invariant of the
-- component.
if N > Number_Dimensions (A_Type) then
return New_List (Build_Component_Invariant_Call);
-- Else generate one loop and recurse
else
Index :=
Make_Defining_Identifier (Loc, New_External_Name ('J', N));
Append (New_Occurrence_Of (Index, Loc), Index_List);
return New_List (
Make_Implicit_Loop_Statement (Nod,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Index,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Object_Entity, Loc),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, N))))),
Statements => Check_One_Dimension (N + 1)));
end if;
end Check_One_Dimension;
-- Start of processing for Build_Array_Invariant_Proc
begin
Index_List := New_List;
Proc_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (A_Type), "CInvariant"));
Body_Stmts := Check_One_Dimension (1);
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Object_Entity,
Parameter_Type => New_Occurrence_Of (A_Type, Loc)))),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Body_Stmts));
Set_Ekind (Proc_Id, E_Procedure);
Set_Is_Public (Proc_Id, Is_Public (A_Type));
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Proc_Id);
end if;
return Proc_Body;
end Build_Array_Invariant_Proc;
--------------------------------
-- Build_Discr_Checking_Funcs --
--------------------------------
procedure Build_Discr_Checking_Funcs (N : Node_Id) is
Rec_Id : Entity_Id;
Loc : Source_Ptr;
Enclosing_Func_Id : Entity_Id;
Sequence : Nat := 1;
Type_Def : Node_Id;
V : Node_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.
function Build_Dcheck_Function
(Case_Id : Entity_Id;
Variant : Node_Id) return Entity_Id;
-- Build the discriminant checking function for a given variant
procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
-- Builds the discriminant checking function for each variant of the
-- given variant part of the record type.
--------------------------
-- Build_Case_Statement --
--------------------------
function Build_Case_Statement
(Case_Id : Entity_Id;
Variant : Node_Id) return Node_Id
is
Alt_List : constant List_Id := New_List;
Actuals_List : List_Id;
Case_Node : Node_Id;
Case_Alt_Node : Node_Id;
Choice : Node_Id;
Choice_List : List_Id;
D : Entity_Id;
Return_Node : Node_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.
Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id)));
Choice := First (Discrete_Choices (Variant));
if Nkind (Choice) = N_Others_Choice then
Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
else
Choice_List := New_Copy_List (Discrete_Choices (Variant));
end if;
if not Is_Empty_List (Choice_List) then
Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
Set_Discrete_Choices (Case_Alt_Node, Choice_List);
-- In case this is a nested variant, we need to return the result
-- of the discriminant checking function for the immediately
-- enclosing variant.
if Present (Enclosing_Func_Id) then
Actuals_List := New_List;
D := First_Discriminant (Rec_Id);
while Present (D) loop
Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
Next_Discriminant (D);
end loop;
Return_Node :=
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Enclosing_Func_Id, Loc),
Parameter_Associations =>
Actuals_List));
else
Return_Node :=
Make_Simple_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Standard_False, Loc));
end if;
Set_Statements (Case_Alt_Node, New_List (Return_Node));
Append (Case_Alt_Node, Alt_List);
end if;
Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
Choice_List := New_List (New_Node (N_Others_Choice, Loc));
Set_Discrete_Choices (Case_Alt_Node, Choice_List);
Return_Node :=
Make_Simple_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Standard_True, Loc));
Set_Statements (Case_Alt_Node, New_List (Return_Node));
Append (Case_Alt_Node, Alt_List);
Set_Alternatives (Case_Node, Alt_List);
return Case_Node;
end Build_Case_Statement;
---------------------------
-- Build_Dcheck_Function --
---------------------------
function Build_Dcheck_Function
(Case_Id : Entity_Id;
Variant : Node_Id) return Entity_Id
is
Body_Node : Node_Id;
Func_Id : Entity_Id;
Parameter_List : List_Id;
Spec_Node : Node_Id;
begin
Body_Node := New_Node (N_Subprogram_Body, Loc);
Sequence := Sequence + 1;
Func_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
Set_Is_Discriminant_Check_Function (Func_Id);
Spec_Node := New_Node (N_Function_Specification, Loc);
Set_Defining_Unit_Name (Spec_Node, Func_Id);
Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
Set_Parameter_Specifications (Spec_Node, Parameter_List);
Set_Result_Definition (Spec_Node,
New_Occurrence_Of (Standard_Boolean, 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 (
Build_Case_Statement (Case_Id, Variant))));
Set_Ekind (Func_Id, E_Function);
Set_Mechanism (Func_Id, Default_Mechanism);
Set_Is_Inlined (Func_Id, True);
Set_Is_Pure (Func_Id, True);
Set_Is_Public (Func_Id, Is_Public (Rec_Id));
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_Id, Body_Node);
Set_Dcheck_Function (Variant, Func_Id);
return Func_Id;
end Build_Dcheck_Function;
----------------------------
-- Build_Dcheck_Functions --
----------------------------
procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
Component_List_Node : Node_Id;
Decl : Entity_Id;
Discr_Name : Entity_Id;
Func_Id : Entity_Id;
Variant : Node_Id;
Saved_Enclosing_Func_Id : Entity_Id;
begin
-- 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
Component_List_Node := Component_List (Variant);
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));
while Present (Decl) loop
Set_Discriminant_Checking_Func
(Defining_Identifier (Decl), Func_Id);
Next_Non_Pragma (Decl);
end loop;
if Present (Variant_Part (Component_List_Node)) then
Saved_Enclosing_Func_Id := Enclosing_Func_Id;
Enclosing_Func_Id := Func_Id;
Build_Dcheck_Functions (Variant_Part (Component_List_Node));
Enclosing_Func_Id := Saved_Enclosing_Func_Id;
end if;
end if;
Next_Non_Pragma (Variant);
end loop;
end Build_Dcheck_Functions;
-- Start of processing for Build_Discr_Checking_Funcs
begin
-- Only build if not done already
if not Discr_Check_Funcs_Built (N) then
Type_Def := Type_Definition (N);
if Nkind (Type_Def) = N_Record_Definition then
if No (Component_List (Type_Def)) then -- null record.
return;
else
V := Variant_Part (Component_List (Type_Def));
end if;
else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
if No (Component_List (Record_Extension_Part (Type_Def))) then
return;
else
V := Variant_Part
(Component_List (Record_Extension_Part (Type_Def)));
end if;
end if;
Rec_Id := Defining_Identifier (N);
if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
Loc := Sloc (N);
Enclosing_Func_Id := Empty;
Build_Dcheck_Functions (V);
end if;
Set_Discr_Check_Funcs_Built (N);
end if;
end Build_Discr_Checking_Funcs;
--------------------------------
-- Build_Discriminant_Formals --
--------------------------------
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean) return List_Id
is
Loc : Source_Ptr := Sloc (Rec_Id);
Parameter_List : constant List_Id := New_List;
D : Entity_Id;
Formal : Entity_Id;
Formal_Type : Entity_Id;
Param_Spec_Node : Node_Id;
begin
if Has_Discriminants (Rec_Id) then
D := First_Discriminant (Rec_Id);
while Present (D) loop
Loc := Sloc (D);
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_Occurrence_Of (Formal_Type, Loc));
Append (Param_Spec_Node, Parameter_List);
Next_Discriminant (D);
end loop;
end if;
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.
-- 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.
-- type R (D1, D2 : Integer) is record
-- X : Integer := F * D1;
-- Y : Integer := F * D2;
-- end record;
-- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
-- begin
-- Out_2.D1 := D1;
-- Out_2.D2 := D2;
-- Out_2.X := F * D1;
-- Out_2.Y := F * D2;
-- end;
function Build_Initialization_Call
(Loc : Source_Ptr;
Id_Ref : Node_Id;
Typ : Entity_Id;
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
With_Default_Init : Boolean := False;
Constructor_Ref : Node_Id := Empty) return List_Id
is
Res : constant List_Id := New_List;
Arg : Node_Id;
Args : List_Id;
Decls : List_Id;
Decl : Node_Id;
Discr : Entity_Id;
First_Arg : Node_Id;
Full_Init_Type : Entity_Id;
Full_Type : 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)
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;
-- Use the [underlying] full view when dealing with a private type. This
-- may require several steps depending on derivations.
Full_Type := Typ;
loop
if Is_Private_Type (Full_Type) then
if Present (Full_View (Full_Type)) then
Full_Type := Full_View (Full_Type);
elsif Present (Underlying_Full_View (Full_Type)) then
Full_Type := Underlying_Full_View (Full_Type);
-- When a private type acts as a generic actual and lacks a full
-- view, use the base type.
elsif Is_Generic_Actual_Type (Full_Type) then
Full_Type := Base_Type (Full_Type);
-- The loop has recovered the [underlying] full view, stop the
-- traversal.
else
exit;
end if;
-- The type is not private, nothing to do
else
exit;
end if;
end loop;
-- If Typ is derived, the procedure is the initialization procedure for
-- the root type. Wrap the argument in an conversion to make it type
-- 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))
and then Init_Type /= Base_Type (Typ)
then
First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
Set_Etype (First_Arg, Init_Type);
else
First_Arg := Id_Ref;
end if;
Args := New_List (Convert_Concurrent (First_Arg, Typ));
-- In the tasks case, add _Master as the value of the _Master parameter
-- and _Chain as the value of the _Chain parameter. At the outer level,
-- these will be variables holding the corresponding values obtained
-- from GNARL. At inner levels, they will be the parameters passed down
-- through the outer routines.
if Has_Task (Full_Type) then
if Restriction_Active (No_Task_Hierarchy) then
Append_To (Args,
New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
else
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if;
-- Add _Chain (not done for sequential elaboration policy, see
-- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
if Partition_Elaboration_Policy /= 'S' then
Append_To (Args, Make_Identifier (Loc, Name_uChain));
end if;
-- Ada 2005 (AI-287): In case of default initialized components
-- with tasks, we generate a null string actual parameter.
-- This is just a workaround that must be improved later???
if With_Default_Init then
Append_To (Args,
Make_String_Literal (Loc,
Strval => ""));
else
Decls :=
Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
Decl := Last (Decls);
Append_To (Args,
New_Occurrence_Of (Defining_Identifier (Decl), Loc));
Append_List (Decls, Res);
end if;
else
Decls := No_List;
Decl := Empty;
end if;
-- Add discriminant values if discriminants are present
if Has_Discriminants (Full_Init_Type) then
Discr := First_Discriminant (Full_Init_Type);
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.
declare
T : Entity_Id := Full_Type;
begin
if Is_Protected_Type (T) then
T := Corresponding_Record_Type (T);
end if;
Arg :=
Get_Discriminant_Value (
Discr,
T,
Discriminant_Constraint (Full_Type));
end;
-- If the target has access discriminants, and is constrained by
-- an access to the enclosing construct, i.e. a current instance,
-- replace the reference to the type by a reference to the object.
if Nkind (Arg) = N_Attribute_Reference
and then Is_Access_Type (Etype (Arg))
and then Is_Entity_Name (Prefix (Arg))
and then Is_Type (Entity (Prefix (Arg)))
then
Arg :=
Make_Attribute_Reference (Loc,
Prefix => New_Copy (Prefix (Id_Ref)),
Attribute_Name => Name_Unrestricted_Access);
elsif In_Init_Proc then
-- Replace any possible references to the discriminant in the
-- call to the record initialization procedure with references
-- to the appropriate formal parameter.
if Nkind (Arg) = N_Identifier
and then Ekind (Entity (Arg)) = E_Discriminant
then
Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc);
-- 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 :=
New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
end if;
else
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).
Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
end if;
end if;
-- 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,
Prefix => New_Copy_Tree (Prefix (Id_Ref)),
Selector_Name => Arg));
else
Append_To (Args, Arg);
end if;
Next_Discriminant (Discr);
end loop;
end if;
-- If this is a call to initialize the parent component of a derived
-- tagged type, indicate that the tag should not be set in the parent.
if Is_Tagged_Type (Full_Init_Type)
and then not Is_CPP_Class (Full_Init_Type)
and then Nkind (Id_Ref) = N_Selected_Component
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,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => Args));
if Needs_Finalization (Typ)
and then Nkind (Id_Ref) = N_Selected_Component
then
if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
Append_To (Res,
Make_Init_Call
(Obj_Ref => New_Copy_Tree (First_Arg),
Typ => Typ));
end if;
end if;
return Res;
exception
when RE_Not_Available =>
return Empty_List;
end Build_Initialization_Call;
----------------------------
-- Build_Record_Init_Proc --
----------------------------
procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is
Decls : constant List_Id := New_List;
Discr_Map : constant Elist_Id := New_Elmt_List;
Loc : constant Source_Ptr := Sloc (Rec_Ent);
Counter : Int := 0;
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 an assignment statement which assigns the default expression
-- to its corresponding record component if defined. The left hand side
-- of the assignment is marked Assignment_OK so that initialization of
-- limited private records works correctly. This routine may also build
-- an adjustment call if the component is controlled.
procedure Build_Discriminant_Assignments (Statement_List : List_Id);
-- If the record has discriminants, add assignment statements to
-- Statement_List to initialize the discriminant values from the
-- arguments of the initialization procedure.
function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
-- Build a list representing a sequence of statements which initialize
-- components of the given component list. This may involve building
-- case statements for the variant parts. Append any locally declared
-- objects on list Decls.
function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
-- Given an untagged type-derivation that declares discriminants, e.g.
--
-- type R (R1, R2 : Integer) is record ... end record;
-- type D (D1 : Integer) is new R (1, D1);
--
-- we make the _init_proc of D be
--
-- procedure _init_proc (X : D; D1 : Integer) is
-- begin
-- _init_proc (R (X), 1, D1);
-- end _init_proc;
--
-- This function builds the call statement in this _init_proc.
procedure Build_CPP_Init_Procedure;
-- Build the tree corresponding to the procedure specification and body
-- of the IC procedure that initializes the C++ part of the dispatch
-- table of an Ada tagged type that is a derivation of a CPP type.
-- Install it as the CPP_Init TSS.
procedure Build_Init_Procedure;
-- Build the tree corresponding to the procedure specification and body
-- of the initialization procedure 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 Offset_To_Top, a function used in conjuction with types
-- having secondary dispatch tables.
procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
-- 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.
function Component_Needs_Simple_Initialization
(T : Entity_Id) return Boolean;
-- Determine if a component needs simple initialization, given its type
-- T. This routine is the same as Needs_Simple_Initialization except for
-- components of type Tag and Interface_Tag. These two access types do
-- not require initialization since they are explicitly initialized by
-- other means.
function Parent_Subtype_Renaming_Discrims return Boolean;
-- Returns True for base types N that rename discriminants, else False
function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
-- Determine whether a record initialization procedure needs to be
-- generated for the given record type.
----------------------
-- Build_Assignment --
----------------------
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
N_Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Underlying_Type (Etype (Id));
Exp : Node_Id := N;
Kind : Node_Kind := Nkind (N);
Lhs : Node_Id;
Res : List_Id;
begin
Lhs :=
Make_Selected_Component (N_Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, N_Loc));
Set_Assignment_OK (Lhs);
-- Case of an access attribute applied to the current instance.
-- Replace the reference to the type by a reference to the actual
-- object. (Note that this handles the case of the top level of
-- the expression being given by such an attribute, but does not
-- cover uses nested within an initial value expression. Nested
-- uses are unlikely to occur in practice, but are theoretically
-- possible.) It is not clear how to handle them without fully
-- traversing the expression. ???
if Kind = N_Attribute_Reference
and then Nam_In (Attribute_Name (N), Name_Unchecked_Access,
Name_Unrestricted_Access)
and then Is_Entity_Name (Prefix (N))
and then Is_Type (Entity (Prefix (N)))
and then Entity (Prefix (N)) = Rec_Type
then
Exp :=
Make_Attribute_Reference (N_Loc,
Prefix =>
Make_Identifier (N_Loc, Name_uInit),
Attribute_Name => Name_Unrestricted_Access);
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. If the copy contains
-- itypes, the scope of the new itypes is the init_proc being built.
Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
Res := New_List (
Make_Assignment_Statement (Loc,
Name => Lhs,
Expression => Exp));
Set_No_Ctrl_Actions (First (Res));
-- Adjust the tag if tagged (because of possible view conversions).
-- Suppress the tag adjustment when VM_Target because VM tags are
-- represented implicitly in objects.
if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
Append_To (Res,
Make_Assignment_Statement (N_Loc,
Name =>
Make_Selected_Component (N_Loc,
Prefix =>
New_Copy_Tree (Lhs, New_Scope => Proc_Id),
Selector_Name =>
New_Occurrence_Of (First_Tag_Component (Typ), N_Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node
(First_Elmt
(Access_Disp_Table (Underlying_Type (Typ)))),
N_Loc))));
end if;
-- 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 Needs_Finalization (Typ)
and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
and then not Is_Limited_View (Typ)
then
Append_To (Res,
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Lhs),
Typ => Etype (Id)));
end if;
return Res;
exception
when RE_Not_Available =>
return Empty_List;
end Build_Assignment;
------------------------------------
-- Build_Discriminant_Assignments --
------------------------------------
procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
D : Entity_Id;
D_Loc : Source_Ptr;
begin
if Has_Discriminants (Rec_Type)
and then not Is_Unchecked_Union (Rec_Type)
then
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
-- when initializing the _parent field of the derived record.
if Is_Tagged
and then Present (Corresponding_Discriminant (D))
then
null;
else
D_Loc := Sloc (D);
Append_List_To (Statement_List,
Build_Assignment (D,
New_Occurrence_Of (Discriminal (D), D_Loc)));
end if;
Next_Discriminant (D);
end loop;
end if;
end Build_Discriminant_Assignments;
--------------------------
-- Build_Init_Call_Thru --
--------------------------
function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
Parent_Proc : constant Entity_Id :=
Base_Init_Proc (Etype (Rec_Type));
Parent_Type : constant Entity_Id :=
Etype (First_Formal (Parent_Proc));
Uparent_Type : constant Entity_Id :=
Underlying_Type (Parent_Type);
First_Discr_Param : Node_Id;
Arg : Node_Id;
Args : List_Id;
First_Arg : Node_Id;
Parent_Discr : Entity_Id;
Res : List_Id;
begin
-- First argument (_Init) is the object to be initialized.
-- ??? not sure where to get a reasonable Loc for First_Arg
First_Arg :=
OK_Convert_To (Parent_Type,
New_Occurrence_Of
(Defining_Identifier (First (Parameters)), Loc));
Set_Etype (First_Arg, Parent_Type);
Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
-- In the tasks case,
-- add _Master as the value of the _Master parameter
-- add _Chain as the value of the _Chain parameter.
-- add _Task_Name as the value of the _Task_Name parameter.
-- At the outer level, these will be variables holding the
-- corresponding values obtained from GNARL or the expander.
--
-- At inner levels, they will be the parameters passed down through
-- the outer routines.
First_Discr_Param := Next (First (Parameters));
if Has_Task (Rec_Type) then
if Restriction_Active (No_Task_Hierarchy) then
Append_To (Args,
New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
else
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if;
-- Add _Chain (not done for sequential elaboration policy, see
-- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
if Partition_Elaboration_Policy /= 'S' then
Append_To (Args, Make_Identifier (Loc, Name_uChain));
end if;
Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
First_Discr_Param := Next (Next (Next (First_Discr_Param)));
end if;
-- Append discriminant values
if Has_Discriminants (Uparent_Type) then
pragma Assert (not Is_Tagged_Type (Uparent_Type));
Parent_Discr := First_Discriminant (Uparent_Type);
while Present (Parent_Discr) loop
-- Get the initial value for this discriminant
-- ??? needs to be cleaned up to use parent_Discr_Constr
-- directly.
declare
Discr : Entity_Id :=
First_Stored_Discriminant (Uparent_Type);
Discr_Value : Elmt_Id :=
First_Elmt (Stored_Constraint (Rec_Type));
begin
while Original_Record_Component (Parent_Discr) /= Discr loop
Next_Stored_Discriminant (Discr);
Next_Elmt (Discr_Value);
end loop;
Arg := Node (Discr_Value);
end;
-- Append it to the list
if Nkind (Arg) = N_Identifier
and then Ekind (Entity (Arg)) = E_Discriminant
then
Append_To (Args,
New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
-- Case of access discriminants. We replace the reference
-- to the type by a reference to the actual object.
-- Is above comment right??? Use of New_Copy below seems mighty
-- suspicious ???
else
Append_To (Args, New_Copy (Arg));
end if;
Next_Discriminant (Parent_Discr);
end loop;
end if;
Res :=
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Parent_Proc, Loc),
Parameter_Associations => Args));
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 : Address) return Storage_Offset is
-- type Acc is access all <Typ>;
-- begin
-- return Acc!(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;
Acc_Type : Entity_Id;
begin
Func_Id := Make_Temporary (Loc, '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_Occurrence_Of (RTE (RE_Address), Loc))));
Set_Result_Definition (Spec_Node,
New_Occurrence_Of (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);
Acc_Type := Make_Temporary (Loc, 'T');
Set_Declarations (Body_Node, New_List (
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc_Type,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Null_Exclusion_Present => False,
Constant_Present => False,
Subtype_Indication =>
New_Occurrence_Of (Rec_Type, Loc)))));
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 =>
Unchecked_Convert_To (Acc_Type,
Make_Identifier (Loc, Name_uO)),
Selector_Name =>
New_Occurrence_Of (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
Iface_Comp : Node_Id;
Iface_Comp_Elmt : Elmt_Id;
Ifaces_Comp_List : Elist_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,
Use_Full_View => True)
then
Build_Offset_To_Top_Function (Iface_Comp);
end if;
Next_Elmt (Iface_Comp_Elmt);
end loop;
end Build_Offset_To_Top_Functions;
------------------------------
-- Build_CPP_Init_Procedure --
------------------------------
procedure Build_CPP_Init_Procedure is
Body_Node : Node_Id;
Body_Stmts : List_Id;
Flag_Id : Entity_Id;
Handled_Stmt_Node : Node_Id;
Init_Tags_List : List_Id;
Proc_Id : Entity_Id;
Proc_Spec_Node : Node_Id;
begin
-- Check cases requiring no IC routine
if not Is_CPP_Class (Root_Type (Rec_Type))
or else Is_CPP_Class (Rec_Type)
or else CPP_Num_Prims (Rec_Type) = 0
or else not Tagged_Type_Expansion
or else No_Run_Time_Mode
then
return;
end if;
-- Generate:
-- Flag : Boolean := False;
--
-- procedure Typ_IC is
-- begin
-- if not Flag then
-- Copy C++ dispatch table slots from parent
-- Update C++ slots of overridden primitives
-- end if;
-- end;
Flag_Id := Make_Temporary (Loc, 'F');
Append_Freeze_Action (Rec_Type,
Make_Object_Declaration (Loc,
Defining_Identifier => Flag_Id,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc),
Expression =>
New_Occurrence_Of (Standard_True, Loc)));
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
Proc_Id :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
Set_Ekind (Proc_Id, E_Procedure);
Set_Is_Internal (Proc_Id);
Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
Set_Parameter_Specifications (Proc_Spec_Node, New_List);
Set_Specification (Body_Node, Proc_Spec_Node);
Set_Declarations (Body_Node, New_List);
Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
Append_To (Init_Tags_List,
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (Flag_Id, Loc),
Expression =>
New_Occurrence_Of (Standard_False, Loc)));
Append_To (Body_Stmts,
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Flag_Id, Loc),
Then_Statements => Init_Tags_List));
Handled_Stmt_Node :=
New_Node (N_Handled_Sequence_Of_Statements, Loc);
Set_Statements (Handled_Stmt_Node, Body_Stmts);
Set_Exception_Handlers (Handled_Stmt_Node, No_List);
Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Proc_Id);
end if;
-- Associate CPP_Init_Proc with type
Set_Init_Proc (Rec_Type, Proc_Id);
end Build_CPP_Init_Procedure;
--------------------------
-- Build_Init_Procedure --
--------------------------
procedure Build_Init_Procedure is
Body_Stmts : List_Id;
Body_Node : Node_Id;
Handled_Stmt_Node : Node_Id;
Init_Tags_List : List_Id;
Parameters : List_Id;
Proc_Spec_Node : Node_Id;
Record_Extension_Node : Node_Id;
begin
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
Set_Ekind (Proc_Id, E_Procedure);
Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
Parameters := Init_Formals (Rec_Type);
Append_List_To (Parameters,
Build_Discriminant_Formals (Rec_Type, True));
-- For tagged types, we add a flag to indicate whether the routine
-- is called to initialize a parent component in the init_proc of
-- a type extension. If the flag is false, we do not set the tag
-- because it has been set already in the extension.
if Is_Tagged_Type (Rec_Type) then
Set_Tag := Make_Temporary (Loc, 'P');
Append_To (Parameters,
Make_Parameter_Specification (Loc,
Defining_Identifier => Set_Tag,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc),
Expression =>
New_Occurrence_Of (Standard_True, Loc)));
end if;
Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
Set_Specification (Body_Node, Proc_Spec_Node);
Set_Declarations (Body_Node, Decls);
-- N is a Derived_Type_Definition that renames the parameters of the
-- ancestor type. We initialize it by expanding our discriminants and
-- call the ancestor _init_proc with a type-converted object.
if Parent_Subtype_Renaming_Discrims then
Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
elsif Nkind (Type_Definition (N)) = N_Record_Definition then
Build_Discriminant_Assignments (Body_Stmts);
if not Null_Present (Type_Definition (N)) then
Append_List_To (Body_Stmts,
Build_Init_Statements (Component_List (Type_Definition (N))));
end if;
-- N is a Derived_Type_Definition with a possible non-empty
-- extension. The initialization of a type extension consists in the
-- initialization of the components in the extension.
else
Build_Discriminant_Assignments (Body_Stmts);
Record_Extension_Node :=
Record_Extension_Part (Type_Definition (N));
if not Null_Present (Record_Extension_Node) then
declare
Stmts : constant List_Id :=
Build_Init_Statements (
Component_List (Record_Extension_Node));
begin
-- The parent field must be initialized first because the
-- offset of the new discriminants may depend on it. This is
-- not needed if the parent is an interface type because in
-- such case the initialization of the _parent field was not
-- generated.
if not Is_Interface (Etype (Rec_Ent)) then
declare
Parent_IP : constant Name_Id :=
Make_Init_Proc_Name (Etype (Rec_Ent));
Stmt : Node_Id;
IP_Call : Node_Id;
IP_Stmts : List_Id;
begin
-- Look for a call to the parent IP at the beginning
-- of Stmts associated with the record extension
Stmt := First (Stmts);
IP_Call := Empty;
while Present (Stmt) loop
if Nkind (Stmt) = N_Procedure_Call_Statement
and then Chars (Name (Stmt)) = Parent_IP
then
IP_Call := Stmt;
exit;
end if;
Next (Stmt);
end loop;
-- If found then move it to the beginning of the
-- statements of this IP routine
if Present (IP_Call) then
IP_Stmts := New_List;
loop
Stmt := Remove_Head (Stmts);
Append_To (IP_Stmts, Stmt);
exit when Stmt = IP_Call;
end loop;
Prepend_List_To (Body_Stmts, IP_Stmts);
end if;
end;
end if;
Append_List_To (Body_Stmts, Stmts);
end;
end if;
end if;
-- Add here the assignment to instantiate the Tag
-- The assignment corresponds to the code:
-- _Init._Tag := Typ'Tag;
-- 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 Tagged_Type_Expansion
and then not No_Run_Time_Mode
then
-- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
-- the actual object and invoke the IP of the parent (in this
-- order). The tag must be initialized before the call to the IP
-- of the parent and the assignments to other components because
-- the initial value of the components may 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.
if not Is_CPP_Class (Root_Type (Rec_Type)) then
-- Initialize the primary tag component
Init_Tags_List := New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name =>
New_Occurrence_Of
(First_Tag_Component (Rec_Type), Loc)),
Expression =>
New_Occurrence_Of
(Node
(First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
-- 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_2005
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;
Prepend_To (Body_Stmts,
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => Init_Tags_List));
-- Case 2: CPP type. The imported C++ constructor takes care of
-- tags initialization. No action needed here because the IP
-- is built by Set_CPP_Constructors; in this case the IP is a
-- wrapper that invokes the C++ constructor and copies the C++
-- tags locally. Done to inherit the C++ slots in Ada derivations
-- (see case 3).
elsif Is_CPP_Class (Rec_Type) then
pragma Assert (False);
null;
-- Case 3: Combined hierarchy containing C++ types and Ada tagged
-- type derivations. Derivations of imported C++ classes add a
-- complication, because we cannot inhibit tag setting in the
-- constructor for the parent. Hence we initialize the tag after
-- the call to the parent IP (that is, in reverse order compared
-- with pure Ada hierarchies ---see comment on case 1).
else
-- Initialize the primary tag
Init_Tags_List := New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name =>
New_Occurrence_Of
(First_Tag_Component (Rec_Type), Loc)),
Expression =>
New_Occurrence_Of
(Node
(First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
-- 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_2005
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;
-- Initialize the tag component after invocation of parent IP.
-- Generate:
-- parent_IP(_init.parent); // Invokes the C++ constructor
-- [ typIC; ] // Inherit C++ slots from parent
-- init_tags
declare
Ins_Nod : Node_Id;
begin
-- Search for the call to the IP of the parent. We assume
-- that the first init_proc call is for the parent.
Ins_Nod := First (Body_Stmts);
while Present (Next (Ins_Nod))
and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
or else not Is_Init_Proc (Name (Ins_Nod)))
loop
Next (Ins_Nod);
end loop;
-- The IC routine copies the inherited slots of the C+ part
-- of the dispatch table from the parent and updates the
-- overridden C++ slots.
if CPP_Num_Prims (Rec_Type) > 0 then
declare
Init_DT : Entity_Id;
New_Nod : Node_Id;
begin
Init_DT := CPP_Init_Proc (Rec_Type);
pragma Assert (Present (Init_DT));
New_Nod :=
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (Init_DT, Loc));
Insert_After (Ins_Nod, New_Nod);
-- Update location of init tag statements
Ins_Nod := New_Nod;
end;
end if;
Insert_List_After (Ins_Nod, Init_Tags_List);
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_2005
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_Statements (Handled_Stmt_Node, Body_Stmts);
-- Generate:
-- Deep_Finalize (_init, C1, ..., CN);
-- raise;
if Counter > 0
and then Needs_Finalization (Rec_Type)
and then not Is_Abstract_Type (Rec_Type)
and then not Restriction_Active (No_Exception_Propagation)
then
declare
DF_Call : Node_Id;
DF_Id : Entity_Id;
begin
-- Create a local version of Deep_Finalize which has indication
-- of partial initialization state.
DF_Id := Make_Temporary (Loc, 'F');
Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
DF_Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (DF_Id, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Name_uInit),
New_Occurrence_Of (Standard_False, Loc)));
-- Do not emit warnings related to the elaboration order when a
-- controlled object is declared before the body of Finalize is
-- seen.
Set_No_Elaboration_Check (DF_Call);
Set_Exception_Handlers (Handled_Stmt_Node, New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
DF_Call,
Make_Raise_Statement (Loc)))));
end;
else
Set_Exception_Handlers (Handled_Stmt_Node, No_List);
end if;
Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Proc_Id);
end if;
-- Associate Init_Proc with type, and determine if the procedure
-- is null (happens because of the Initialize_Scalars pragma case,
-- where we have to generate a null procedure in case it is called
-- by a client with Initialize_Scalars set). Such procedures have
-- to be generated, but do not have to be called, so we mark them
-- as null to suppress the call.
Set_Init_Proc (Rec_Type, Proc_Id);
if List_Length (Body_Stmts) = 1
-- 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;
---------------------------
-- Build_Init_Statements --
---------------------------
function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
Checks : constant List_Id := New_List;
Actions : List_Id := No_List;
Counter_Id : Entity_Id := Empty;
Comp_Loc : Source_Ptr;
Decl : Node_Id;
Has_POC : Boolean;
Id : Entity_Id;
Parent_Stmts : List_Id;
Stmts : List_Id;
Typ : Entity_Id;
procedure Increment_Counter (Loc : Source_Ptr);
-- Generate an "increment by one" statement for the current counter
-- and append it to the list Stmts.
procedure Make_Counter (Loc : Source_Ptr);
-- Create a new counter for the current component list. The routine
-- creates a new defining Id, adds an object declaration and sets
-- the Id generator for the next variant.
-----------------------
-- Increment_Counter --
-----------------------
procedure Increment_Counter (Loc : Source_Ptr) is
begin
-- Generate:
-- Counter := Counter + 1;
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Counter_Id, Loc),
Expression =>
Make_Op_Add (Loc,
Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
Right_Opnd => Make_Integer_Literal (Loc, 1))));
end Increment_Counter;
------------------
-- Make_Counter --
------------------
procedure Make_Counter (Loc : Source_Ptr) is
begin
-- Increment the Id generator
Counter := Counter + 1;
-- Create the entity and declaration
Counter_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name ('C', Counter));
-- Generate:
-- Cnn : Integer := 0;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Counter_Id,
Object_Definition =>
New_Occurrence_Of (Standard_Integer, Loc),
Expression =>
Make_Integer_Literal (Loc, 0)));
end Make_Counter;
-- Start of processing for Build_Init_Statements
begin
if Null_Present (Comp_List) then
return New_List (Make_Null_Statement (Loc));
end if;
Parent_Stmts := New_List;
Stmts := New_List;
-- Loop through visible declarations of task types and protected
-- types moving any expanded code from the spec to the body of the
-- init procedure.
if Is_Task_Record_Type (Rec_Type)
or else Is_Protected_Record_Type (Rec_Type)
then
declare
Decl : constant Node_Id :=
Parent (Corresponding_Concurrent_Type (Rec_Type));
Def : Node_Id;
N1 : Node_Id;
N2 : Node_Id;
begin
if Is_Task_Record_Type (Rec_Type) then
Def := Task_Definition (Decl);
else
Def := Protected_Definition (Decl);
end if;
if Present (Def) then
N1 := First (Visible_Declarations (Def));
while Present (N1) loop
N2 := N1;
N1 := Next (N1);
if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
or else Nkind (N2) in N_Raise_xxx_Error
or else Nkind (N2) = N_Procedure_Call_Statement
then
Append_To (Stmts,
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 that have per object constraints and no explicit
-- initialization.
Has_POC := False;
-- First pass : regular components
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
Comp_Loc := Sloc (Decl);
Build_Record_Checks
(Subtype_Indication (Component_Definition (Decl)), Checks);
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
-- Leave any processing of per-object constrained component for
-- the second pass.
if Has_Access_Constraint (Id) and then No (Expression (Decl)) then
Has_POC := True;
-- Regular component cases
else
-- In the context of the init proc, references to discriminants
-- resolve to denote the discriminals: this is where we can
-- freeze discriminant dependent component subtypes.
if not Is_Frozen (Typ) then
Append_List_To (Stmts, Freeze_Entity (Typ, N));
end if;
-- Explicit initialization
if Present (Expression (Decl)) then
if Is_CPP_Constructor_Call (Expression (Decl)) then
Actions :=
Build_Initialization_Call
(Comp_Loc,
Id_Ref =>
Make_Selected_Component (Comp_Loc,
Prefix =>
Make_Identifier (Comp_Loc, Name_uInit),
Selector_Name =>
New_Occurrence_Of (Id, Comp_Loc)),
Typ => Typ,
In_Init_Proc => True,
Enclos_Type => Rec_Type,
Discr_Map => Discr_Map,
Constructor_Ref => Expression (Decl));
else
Actions := Build_Assignment (Id, Expression (Decl));
end if;
-- CPU, Dispatching_Domain, Priority and Size components are
-- filled with the corresponding rep item expression of the
-- concurrent type (if any).
elsif Ekind (Scope (Id)) = E_Record_Type
and then Present (Corresponding_Concurrent_Type (Scope (Id)))
and then Nam_In (Chars (Id), Name_uCPU,
Name_uDispatching_Domain,
Name_uPriority)
then
declare
Exp : Node_Id;
Nam : Name_Id;
Ritem : Node_Id;
begin
if Chars (Id) = Name_uCPU then
Nam := Name_CPU;
elsif Chars (Id) = Name_uDispatching_Domain then
Nam := Name_Dispatching_Domain;
elsif Chars (Id) = Name_uPriority then
Nam := Name_Priority;
end if;
-- Get the Rep Item (aspect specification, attribute
-- definition clause or pragma) of the corresponding
-- concurrent type.
Ritem :=
Get_Rep_Item
(Corresponding_Concurrent_Type (Scope (Id)),
Nam,
Check_Parents => False);
if Present (Ritem) then
-- Pragma case
if Nkind (Ritem) = N_Pragma then
Exp := First (Pragma_Argument_Associations (Ritem));
if Nkind (Exp) = N_Pragma_Argument_Association then
Exp := Expression (Exp);
end if;
-- Conversion for Priority expression
if Nam = Name_Priority then
if Pragma_Name (Ritem) = Name_Priority
and then not GNAT_Mode
then
Exp := Convert_To (RTE (RE_Priority), Exp);
else
Exp :=
Convert_To (RTE (RE_Any_Priority), Exp);
end if;
end if;
-- Aspect/Attribute definition clause case
else
Exp := Expression (Ritem);
-- Conversion for Priority expression
if Nam = Name_Priority then
if Chars (Ritem) = Name_Priority
and then not GNAT_Mode
then
Exp := Convert_To (RTE (RE_Priority), Exp);
else
Exp :=
Convert_To (RTE (RE_Any_Priority), Exp);
end if;
end if;
end if;
-- Conversion for Dispatching_Domain value
if Nam = Name_Dispatching_Domain then
Exp :=
Unchecked_Convert_To
(RTE (RE_Dispatching_Domain_Access), Exp);
end if;
Actions := Build_Assignment (Id, Exp);
-- Nothing needed if no Rep Item
else
Actions := No_List;
end if;
end;
-- Composite component with its own Init_Proc
elsif not Is_Interface (Typ)
and then Has_Non_Null_Base_Init_Proc (Typ)
then
Actions :=
Build_Initialization_Call
(Comp_Loc,
Make_Selected_Component (Comp_Loc,
Prefix =>
Make_Identifier (Comp_Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
Typ,
In_Init_Proc => True,
Enclos_Type => Rec_Type,
Discr_Map => Discr_Map);
Clean_Task_Names (Typ, Proc_Id);
-- Simple initialization
elsif Component_Needs_Simple_Initialization (Typ) then
Actions :=
Build_Assignment
(Id, Get_Simple_Init_Val (Typ, N, Esize (Id)));
-- Nothing needed for this case
else
Actions := No_List;
end if;
if Present (Checks) then
if Chars (Id) = Name_uParent then
Append_List_To (Parent_Stmts, Checks);
else
Append_List_To (Stmts, Checks);
end if;
end if;
if Present (Actions) then
if Chars (Id) = Name_uParent then
Append_List_To (Parent_Stmts, Actions);
else
Append_List_To (Stmts, Actions);
-- Preserve initialization state in the current counter
if Needs_Finalization (Typ) then
if No (Counter_Id) then
Make_Counter (Comp_Loc);
end if;
Increment_Counter (Comp_Loc);
end if;
end if;
end if;
end if;
Next_Non_Pragma (Decl);
end loop;
-- The parent field must be initialized first because variable
-- size components of the parent affect the location of all the
-- new components.
Prepend_List_To (Stmts, Parent_Stmts);
-- 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.
if Is_Task_Record_Type (Rec_Type) then
-- In the case of the restricted run time the ATCB has already
-- been preallocated.
if Restricted_Profile then
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uATCB)),
Attribute_Name => Name_Unchecked_Access)));
end if;
Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
declare
Task_Type : constant Entity_Id :=
Corresponding_Concurrent_Type (Rec_Type);
Task_Decl : constant Node_Id := Parent (Task_Type);
Task_Def : constant Node_Id := Task_Definition (Task_Decl);
Decl_Loc : Source_Ptr;
Ent : Entity_Id;
Vis_Decl : Node_Id;
begin
if Present (Task_Def) then
Vis_Decl := First (Visible_Declarations (Task_Def));
while Present (Vis_Decl) loop
Decl_Loc := Sloc (Vis_Decl);
if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
if Get_Attribute_Id (Chars (Vis_Decl)) =
Attribute_Address
then
Ent := Entity (Name (Vis_Decl));
if Ekind (Ent) = E_Entry then
Append_To (Stmts,
Make_Procedure_Call_Statement (Decl_Loc,
Name =>
New_Occurrence_Of (RTE (
RE_Bind_Interrupt_To_Entry), Decl_Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Decl_Loc,
Prefix =>
Make_Identifier (Decl_Loc, Name_uInit),
Selector_Name =>
Make_Identifier
(Decl_Loc, Name_uTask_Id)),
Entry_Index_Expression
(Decl_Loc, Ent, Empty, Task_Type),
Expression (Vis_Decl))));
end if;
end if;
end if;
Next (Vis_Decl);
end loop;
end if;
end;
end if;
-- For a protected type, add statements generated by
-- Make_Initialize_Protection.
if Is_Protected_Record_Type (Rec_Type) then
Append_List_To (Stmts,
Make_Initialize_Protection (Rec_Type));
end if;
-- Second pass: components with per-object constraints
if Has_POC then
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
Comp_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 (Stmts,
Build_Initialization_Call (Comp_Loc,
Make_Selected_Component (Comp_Loc,
Prefix =>
Make_Identifier (Comp_Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
Typ,
In_Init_Proc => True,
Enclos_Type => Rec_Type,
Discr_Map => Discr_Map));
Clean_Task_Names (Typ, Proc_Id);
-- Preserve initialization state in the current counter
if Needs_Finalization (Typ) then
if No (Counter_Id) then
Make_Counter (Comp_Loc);
end if;
Increment_Counter (Comp_Loc);
end if;
elsif Component_Needs_Simple_Initialization (Typ) then
Append_List_To (Stmts,
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
declare
Variant_Alts : constant List_Id := New_List;
Var_Loc : Source_Ptr;
Variant : Node_Id;
begin
Variant :=
First_Non_Pragma (Variants (Variant_Part (Comp_List)));
while Present (Variant) loop
Var_Loc := Sloc (Variant);
Append_To (Variant_Alts,
Make_Case_Statement_Alternative (Var_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 (Stmts,
Make_Case_Statement (Var_Loc,
Expression =>
New_Occurrence_Of (Discriminal (
Entity (Name (Variant_Part (Comp_List)))), Var_Loc),
Alternatives => Variant_Alts));
end;
end if;
-- If no initializations when generated for component declarations
-- corresponding to this Stmts, append a null statement to Stmts to
-- to make it a valid Ada tree.
if Is_Empty_List (Stmts) then
Append (Make_Null_Statement (Loc), Stmts);
end if;
return Stmts;
exception
when RE_Not_Available =>
return Empty_List;
end Build_Init_Statements;
-------------------------
-- Build_Record_Checks --
-------------------------
procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
Subtype_Mark_Id : Entity_Id;
procedure Constrain_Array
(SI : Node_Id;
Check_List : List_Id);
-- Apply a list of index constraints to an unconstrained array type.
-- The first parameter is the entity for the resulting subtype.
-- Check_List is a list to which the check actions are appended.
---------------------
-- Constrain_Array --
---------------------
procedure Constrain_Array
(SI : Node_Id;
Check_List : List_Id)
is
C : constant Node_Id := Constraint (SI);
Number_Of_Constraints : Nat := 0;
Index : Node_Id;
S, T : Entity_Id;
procedure Constrain_Index
(Index : Node_Id;
S : Node_Id;
Check_List : List_Id);
-- Process an index constraint in a constrained array declaration.
-- The constraint can be either a subtype name or a range with or
-- without an explicit subtype mark. 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.
---------------------
-- Constrain_Index --
---------------------
procedure Constrain_Index
(Index : Node_Id;
S : Node_Id;
Check_List : List_Id)
is
T : constant Entity_Id := Etype (Index);
begin
if Nkind (S) = N_Range then
Process_Range_Expr_In_Decl (S, T, Check_List => Check_List);
end if;
end Constrain_Index;
-- Start of processing for Constrain_Array
begin
T := Entity (Subtype_Mark (SI));
if Is_Access_Type (T) then
T := Designated_Type (T);
end if;
S := First (Constraints (C));
while Present (S) loop
Number_Of_Constraints := Number_Of_Constraints + 1;
Next (S);
end loop;
-- In either case, the index constraint must provide a discrete
-- range for each index of the array type and the type of each
-- discrete range must be the same as that of the corresponding
-- index. (RM 3.6.1)
S := First (Constraints (C));
Index := First_Index (T);
Analyze (Index);
-- Apply constraints to each index type
for J in 1 .. Number_Of_Constraints loop
Constrain_Index (Index, S, Check_List);
Next (Index);
Next (S);
end loop;
end Constrain_Array;
-- Start of processing for Build_Record_Checks
begin
if Nkind (S) = N_Subtype_Indication then
Find_Type (Subtype_Mark (S));
Subtype_Mark_Id := Entity (Subtype_Mark (S));
-- Remaining processing depends on type
case Ekind (Subtype_Mark_Id) is
when Array_Kind =>
Constrain_Array (S, Check_List);
when others =>
null;
end case;
end if;
end Build_Record_Checks;
-------------------------------------------
-- Component_Needs_Simple_Initialization --
-------------------------------------------
function Component_Needs_Simple_Initialization
(T : Entity_Id) return Boolean
is
begin
return
Needs_Simple_Initialization (T)
and then not Is_RTE (T, RE_Tag)
-- 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;
--------------------------------------
-- Parent_Subtype_Renaming_Discrims --
--------------------------------------
function Parent_Subtype_Renaming_Discrims return Boolean is
De : Entity_Id;
Dp : Entity_Id;
begin
if Base_Type (Rec_Ent) /= Rec_Ent then
return False;
end if;
if Etype (Rec_Ent) = Rec_Ent
or else not Has_Discriminants (Rec_Ent)
or else Is_Constrained (Rec_Ent)
or else Is_Tagged_Type (Rec_Ent)
then
return False;
end if;
-- If there are no explicit stored discriminants we have inherited
-- the root type discriminants so far, so no renamings occurred.
if First_Discriminant (Rec_Ent) =
First_Stored_Discriminant (Rec_Ent)
then
return False;
end if;
-- Check if we have done some trivial renaming of the parent
-- discriminants, i.e. something like
--
-- type DT (X1, X2: int) is new PT (X1, X2);
De := First_Discriminant (Rec_Ent);
Dp := First_Discriminant (Etype (Rec_Ent));
while Present (De) loop
pragma Assert (Present (Dp));
if Corresponding_Discriminant (De) /= Dp then
return True;
end if;
Next_Discriminant (De);
Next_Discriminant (Dp);
end loop;
return Present (Dp);
end Parent_Subtype_Renaming_Discrims;
------------------------
-- Requires_Init_Proc --
------------------------
function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
Comp_Decl : Node_Id;
Id : Entity_Id;
Typ : Entity_Id;
begin
-- Definitely do not need one if specifically suppressed
if Initialization_Suppressed (Rec_Id) then
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:
-- 1. Discriminants are present, since they need to be initialized
-- with the appropriate discriminant constraint expressions.
-- However, the discriminant of an unchecked union does not
-- count, since the discriminant is not present.
-- 2. The type is a tagged type, since the implicit Tag component
-- needs to be initialized with a pointer to the dispatch table.
-- 3. The type contains tasks
-- 4. One or more components has an initial value
-- 5. One or more components is for a type which itself requires
-- an initialization procedure.
-- 6. One or more components is a type that requires simple
-- initialization (see Needs_Simple_Initialization), except
-- that types Tag and Interface_Tag are excluded, since fields
-- of these types are initialized by other means.
-- 7. The type is the record type built for a task type (since at
-- the very least, Create_Task must be called)
-- 8. The type is the record type built for a protected type (since
-- at least Initialize_Protection must be called)
-- 9. The type is marked as a public entity. The reason we add this
-- case (even if none of the above apply) is to properly handle
-- Initialize_Scalars. If a package is compiled without an IS
-- pragma, and the client is compiled with an IS pragma, then
-- the client will think an initialization procedure is present
-- and call it, when in fact no such procedure is required, but
-- 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 because in this
-- case the initialization is performed by the C++ constructors, and
-- the IP is built by Set_CPP_Constructors.
if Is_CPP_Class (Rec_Id) then
return False;
elsif Is_Interface (Rec_Id) then
return False;
elsif (Has_Discriminants (Rec_Id)
and then not Is_Unchecked_Union (Rec_Id))
or else Is_Tagged_Type (Rec_Id)
or else Is_Concurrent_Record_Type (Rec_Id)
or else Has_Task (Rec_Id)
then
return True;
end if;
Id := First_Component (Rec_Id);
while Present (Id) loop
Comp_Decl := Parent (Id);
Typ := Etype (Id);
if Present (Expression (Comp_Decl))
or else Has_Non_Null_Base_Init_Proc (Typ)
or else Component_Needs_Simple_Initialization (Typ)
then
return True;
end if;
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.
-- The initialization procedure is built for the record type, which
-- is retrievable from the private entity.
if Is_Incomplete_Or_Private_Type (Rec_Type) then
Rec_Type := Underlying_Type (Rec_Type);
end if;
-- If we have a variant record with restriction No_Implicit_Conditionals
-- in effect, then we skip building the procedure. This is safe because
-- if we can see the restriction, so can any caller, calls to initialize
-- such records are not allowed for variant records if this restriction
-- is active.
if Has_Variant_Part (Rec_Type)
and then Restriction_Active (No_Implicit_Conditionals)
then
return;
end if;
-- 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 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);
Next_Discriminant (Disc);
end loop;
end;
end if;
-- Derived types that have no type extension can use the initialization
-- procedure of their parent and do not need a procedure of their own.
-- This is only correct if there are no representation clauses for the
-- type or its parent, and if the parent has in fact been frozen so
-- that its initialization procedure exists.
if Is_Derived_Type (Rec_Type)
and then not Is_Tagged_Type (Rec_Type)
and then not Is_Unchecked_Union (Rec_Type)
and then not Has_New_Non_Standard_Rep (Rec_Type)
and then not Parent_Subtype_Renaming_Discrims
and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
then
Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
-- Otherwise if we need an initialization procedure, then build one,
-- mark it as public and inlinable and as having a completion.
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_CPP_Init_Procedure;
Build_Init_Procedure;
Set_Is_Public (Proc_Id, Is_Public (Rec_Ent));
-- The initialization of protected records is not worth inlining.
-- In addition, when compiled for another unit for inlining purposes,
-- it may make reference to entities that have not been elaborated
-- yet. The initialization of controlled records contains a nested
-- clean-up procedure that makes it impractical to inline as well,
-- and leads to undefined symbols if inlined in a different unit.
-- Similar considerations apply to task types.
if not Is_Concurrent_Type (Rec_Type)
and then not Has_Task (Rec_Type)
and then not Needs_Finalization (Rec_Type)
then
Set_Is_Inlined (Proc_Id);
end if;
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
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);
-- Recurse on nested arrays
Sub_Aggr := First (Expressions (Comp));
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;
--------------------------------
-- Build_Record_Invariant_Proc --
--------------------------------
function Build_Record_Invariant_Proc
(R_Type : Entity_Id;
Nod : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of invariant procedure
Object_Entity : constant Node_Id :=
Make_Defining_Identifier (Loc, Object_Name);
-- The procedure declaration entity for the argument
Invariant_Found : Boolean;
-- Set if any component needs an invariant check.
Proc_Id : Entity_Id;
Proc_Body : Node_Id;
Stmts : List_Id;
Type_Def : Node_Id;
function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id;
-- Recursive procedure that generates a list of checks for components
-- that need it, and recurses through variant parts when present.
function Build_Component_Invariant_Call (Comp : Entity_Id)
return Node_Id;
-- Build call to invariant procedure for a record component.
------------------------------------
-- Build_Component_Invariant_Call --
------------------------------------
function Build_Component_Invariant_Call (Comp : Entity_Id)
return Node_Id
is
Sel_Comp : Node_Id;
Typ : Entity_Id;
Call : Node_Id;
begin
Invariant_Found := True;
Typ := Etype (Comp);
Sel_Comp :=
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Object_Entity, Loc),
Selector_Name => New_Occurrence_Of (Comp, Loc));
if Is_Access_Type (Typ) then
-- If the access component designates a type with an invariant,
-- the check applies to the designated object. The access type
-- itself may have an invariant, in which case it applies to the
-- access value directly.
-- Note: we are assuming that invariants will not occur on both
-- the access type and the type that it designates. This is not
-- really justified but it is hard to imagine that this case will
-- ever cause trouble ???
if not (Has_Invariants (Typ)) then
Sel_Comp := Make_Explicit_Dereference (Loc, Sel_Comp);
Typ := Designated_Type (Typ);
end if;
end if;
-- The aspect is type-specific, so retrieve it from the base type
Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Invariant_Procedure (Base_Type (Typ)), Loc),
Parameter_Associations => New_List (Sel_Comp));
if Is_Access_Type (Etype (Comp)) then
Call :=
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => Make_Null (Loc),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Object_Entity, Loc),
Selector_Name => New_Occurrence_Of (Comp, Loc))),
Then_Statements => New_List (Call));
end if;
return Call;
end Build_Component_Invariant_Call;
----------------------------
-- Build_Invariant_Checks --
----------------------------
function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id is
Decl : Node_Id;
Id : Entity_Id;
Stmts : List_Id;
begin
Stmts := New_List;
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
if Nkind (Decl) = N_Component_Declaration then
Id := Defining_Identifier (Decl);
if Has_Invariants (Etype (Id))
and then In_Open_Scopes (Scope (R_Type))
then
if Has_Unchecked_Union (R_Type) then
Error_Msg_NE
("invariants cannot be checked on components of "
& "unchecked_union type&?", Decl, R_Type);
return Empty_List;
else
Append_To (Stmts, Build_Component_Invariant_Call (Id));
end if;
elsif Is_Access_Type (Etype (Id))
and then not Is_Access_Constant (Etype (Id))
and then Has_Invariants (Designated_Type (Etype (Id)))
and then In_Open_Scopes (Scope (Designated_Type (Etype (Id))))
then
Append_To (Stmts, Build_Component_Invariant_Call (Id));
end if;
end if;
Next (Decl);
end loop;
if Present (Variant_Part (Comp_List)) then
declare
Variant_Alts : constant List_Id := New_List;
Var_Loc : Source_Ptr;
Variant : Node_Id;
Variant_Stmts : List_Id;
begin
Variant :=
First_Non_Pragma (Variants (Variant_Part (Comp_List)));
while Present (Variant) loop
Variant_Stmts :=
Build_Invariant_Checks (Component_List (Variant));
Var_Loc := Sloc (Variant);
Append_To (Variant_Alts,
Make_Case_Statement_Alternative (Var_Loc,
Discrete_Choices =>
New_Copy_List (Discrete_Choices (Variant)),
Statements => Variant_Stmts));
Next_Non_Pragma (Variant);
end loop;
-- The expression in the case statement is the reference to
-- the discriminant of the target object.
Append_To (Stmts,
Make_Case_Statement (Var_Loc,
Expression =>
Make_Selected_Component (Var_Loc,
Prefix => New_Occurrence_Of (Object_Entity, Var_Loc),
Selector_Name => New_Occurrence_Of
(Entity
(Name (Variant_Part (Comp_List))), Var_Loc)),
Alternatives => Variant_Alts));
end;
end if;
return Stmts;
end Build_Invariant_Checks;
-- Start of processing for Build_Record_Invariant_Proc
begin
Invariant_Found := False;
Type_Def := Type_Definition (Parent (R_Type));
if Nkind (Type_Def) = N_Record_Definition
and then not Null_Present (Type_Def)
then
Stmts := Build_Invariant_Checks (Component_List (Type_Def));
else
return Empty;
end if;
if not Invariant_Found then
return Empty;
end if;
-- The name of the invariant procedure reflects the fact that the
-- checks correspond to invariants on the component types. The
-- record type itself may have invariants that will create a separate
-- procedure whose name carries the Invariant suffix.
Proc_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (R_Type), "CInvariant"));
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Object_Entity,
Parameter_Type => New_Occurrence_Of (R_Type, Loc)))),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
Set_Ekind (Proc_Id, E_Procedure);
Set_Is_Public (Proc_Id, Is_Public (R_Type));
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
return Proc_Body;
-- Insert_After (Nod, Proc_Body);
-- Analyze (Proc_Body);
end Build_Record_Invariant_Proc;
----------------------------
-- Build_Slice_Assignment --
----------------------------
-- Generates the following subprogram:
-- procedure Assign
-- (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;
-- else
-- Li1 := Left_Lo;
-- Ri1 := Right_Lo;
-- end if;
-- loop
-- 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;
procedure Build_Slice_Assignment (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
Larray : constant Entity_Id := Make_Temporary (Loc, 'A');
Rarray : constant Entity_Id := Make_Temporary (Loc, 'R');
Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L');
Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L');
Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R');
Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R');
Rev : constant Entity_Id := Make_Temporary (Loc, 'D');
-- Formal parameters of procedure
Proc_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
Lnn : constant Entity_Id := Make_Temporary (Loc, 'L');
Rnn : constant Entity_Id := Make_Temporary (Loc, 'R');
-- Subscripts for left and right sides
Decls : List_Id;
Loops : Node_Id;
Stats : List_Id;
begin
-- Build declarations for indexes
Decls := New_List;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Lnn,
Object_Definition =>
New_Occurrence_Of (Index, Loc)));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Rnn,
Object_Definition =>
New_Occurrence_Of (Index, Loc)));
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 indexes
declare
F_Init : constant List_Id := New_List;
B_Init : constant List_Id := New_List;
begin
Append_To (F_Init,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lnn, Loc),
Expression => New_Occurrence_Of (Left_Lo, Loc)));
Append_To (F_Init,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Rnn, Loc),
Expression => New_Occurrence_Of (Right_Lo, Loc)));
Append_To (B_Init,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lnn, Loc),
Expression => New_Occurrence_Of (Left_Hi, Loc)));
Append_To (B_Init,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Rnn, Loc),
Expression => New_Occurrence_Of (Right_Hi, Loc)));
Append_To (Stats,
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Rev, Loc),
Then_Statements => B_Init,
Else_Statements => F_Init));
end;
-- Now construct the assignment statement
Loops :=
Make_Loop_Statement (Loc,
Statements => New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (Larray, Loc),
Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
Expression =>
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (Rarray, Loc),
Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
End_Label => Empty);
-- Build the exit condition and increment/decrement statements
declare
F_Ass : constant List_Id := New_List;
B_Ass : constant List_Id := New_List;
begin
Append_To (F_Ass,
Make_Exit_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
Append_To (F_Ass,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lnn, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Index, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (
New_Occurrence_Of (Lnn, Loc)))));
Append_To (F_Ass,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Rnn, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Index, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (
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 =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Index, Loc),
Attribute_Name => Name_Pred,
Expressions => New_List (
New_Occurrence_Of (Lnn, Loc)))));
Append_To (B_Ass,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Rnn, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Index, Loc),
Attribute_Name => Name_Pred,
Expressions => New_List (
New_Occurrence_Of (Rnn, Loc)))));
Append_To (Statements (Loops),
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Rev, Loc),
Then_Statements => B_Ass,
Else_Statements => F_Ass));
end;
Append_To (Stats, Loops);
declare
Spec : Node_Id;
Formals : List_Id := New_List;
begin
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Larray,
Out_Present => True,
Parameter_Type =>
New_Occurrence_Of (Base_Type (Typ), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Rarray,
Parameter_Type =>
New_Occurrence_Of (Base_Type (Typ), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Left_Lo,
Parameter_Type =>
New_Occurrence_Of (Index, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Left_Hi,
Parameter_Type =>
New_Occurrence_Of (Index, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Right_Lo,
Parameter_Type =>
New_Occurrence_Of (Index, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Right_Hi,
Parameter_Type =>
New_Occurrence_Of (Index, Loc)));
Append_To (Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier => Rev,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc)));
Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Name,
Parameter_Specifications => Formals);
Discard_Node (
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stats)));
end;
Set_TSS (Typ, Proc_Name);
Set_Is_Pure (Proc_Name);
end Build_Slice_Assignment;
-----------------------------
-- Build_Untagged_Equality --
-----------------------------
procedure Build_Untagged_Equality (Typ : Entity_Id) is
Build_Eq : Boolean;
Comp : Entity_Id;
Decl : Node_Id;
Op : Entity_Id;
Prim : Elmt_Id;
Eq_Op : Entity_Id;
function User_Defined_Eq (T : Entity_Id) return Entity_Id;
-- Check whether the type T has a user-defined primitive equality. If so
-- return it, else return Empty. If true for a component of Typ, we have
-- to build the primitive equality for it.
---------------------
-- User_Defined_Eq --
---------------------
function User_Defined_Eq (T : Entity_Id) return Entity_Id is
Prim : Elmt_Id;
Op : Entity_Id;
begin
Op := TSS (T, TSS_Composite_Equality);
if Present (Op) then
return Op;
end if;
Prim := First_Elmt (Collect_Primitive_Operations (T));
while Present (Prim) loop
Op := Node (Prim);