CbC/CbC_gcc: gcc/ada/exp_ch3.adb comparison

comparison gcc/ada/exp_ch3.adb @ 111:04ced10e8804

gcc 7

author	kono
date	Fri, 27 Oct 2017 22:46:09 +0900
parents
children	84e7813d76e9

comparison

equal deleted inserted replaced

-:561a7518be6b
+:04ced10e8804
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              E X P _ C H 3                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 1992-2017, 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_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 Lib;      use Lib;
+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_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 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_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 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 Inline_Init_Proc (Typ : Entity_Id) return Boolean;
+--  Returns true if the initialization procedure of Typ should be inlined
+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);
+Comp_Simple_Init : constant Boolean   :=
+Needs_Simple_Initialization
+(T           => Comp_Type,
+Consider_IS =>
+not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type)));
+--  True if the component needs simple initialization, based on its type,
+--  plus the fact that we do not do simple initialization for components
+--  of bit-packed arrays when validity checks are enabled, because the
+--  initialization with deliberately out-of-range values would raise
+--  Constraint_Error.
+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 Comp_Simple_Init 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 Comp_Simple_Init
+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. An initialization already exists for the base type
+if Initialization_Suppressed (A_Type)
+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 Comp_Simple_Init
+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 on Init_Proc if it is set on the Init_Proc of the
+--  component type itself (see also Build_Record_Init_Proc).
+Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type));
+--  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_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.
+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) 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;
+Full_Type : Entity_Id;
+procedure Check_Predicated_Discriminant
+(Val   : Node_Id;
+Discr : Entity_Id);
+--  Discriminants whose subtypes have predicates are checked in two
+--  cases:
+--    a) When an object is default-initialized and assertions are enabled
+--       we check that the value of the discriminant obeys the predicate.
+--    b) In all cases, if the discriminant controls a variant and the
+--       variant has no others_choice, Constraint_Error must be raised if
+--       the predicate is violated, because there is no variant covered
+--       by the illegal discriminant value.
+-----------------------------------
+-- Check_Predicated_Discriminant --
+-----------------------------------
+procedure Check_Predicated_Discriminant
+(Val   : Node_Id;
+Discr : Entity_Id)
+is
+Typ : constant Entity_Id := Etype (Discr);
+procedure Check_Missing_Others (V : Node_Id);
+--  ???
+--------------------------
+-- Check_Missing_Others --
+--------------------------
+procedure Check_Missing_Others (V : Node_Id) is
+Alt      : Node_Id;
+Choice   : Node_Id;
+Last_Var : Node_Id;
+begin
+Last_Var := Last_Non_Pragma (Variants (V));
+Choice   := First (Discrete_Choices (Last_Var));
+--  An others_choice is added during expansion for gcc use, but
+--  does not cover the illegality.
+if Entity (Name (V)) = Discr then
+if Present (Choice)
+and then (Nkind (Choice) /= N_Others_Choice
+or else not Comes_From_Source (Choice))
+then
+Check_Expression_Against_Static_Predicate (Val, Typ);
+if not Is_Static_Expression (Val) then
+Prepend_To (Res,
+Make_Raise_Constraint_Error (Loc,
+Condition =>
+Make_Op_Not (Loc,
+Right_Opnd => Make_Predicate_Call (Typ, Val)),
+Reason    => CE_Invalid_Data));
+end if;
+end if;
+end if;
+--  Check whether some nested variant is ruled by the predicated
+--  discriminant.
+Alt := First (Variants (V));
+while Present (Alt) loop
+if Nkind (Alt) = N_Variant
+and then Present (Variant_Part (Component_List (Alt)))
+then
+Check_Missing_Others
+(Variant_Part (Component_List (Alt)));
+end if;
+Next (Alt);
+end loop;
+end Check_Missing_Others;
+--  Local variables
+Def : Node_Id;
+--  Start of processing for Check_Predicated_Discriminant
+begin
+if Ekind (Base_Type (Full_Type)) = E_Record_Type then
+Def := Type_Definition (Parent (Base_Type (Full_Type)));
+else
+return;
+end if;
+if Policy_In_Effect (Name_Assert) = Name_Check
+and then not Predicates_Ignored (Etype (Discr))
+then
+Prepend_To (Res, Make_Predicate_Check (Typ, Val));
+end if;
+--  If discriminant controls a variant, verify that predicate is
+--  obeyed or else an Others_Choice is present.
+if Nkind (Def) = N_Record_Definition
+and then Present (Variant_Part (Component_List (Def)))
+and then Policy_In_Effect (Name_Assert) = Name_Ignore
+then
+Check_Missing_Others (Variant_Part (Component_List (Def)));
+end if;
+end Check_Predicated_Discriminant;
+--  Local variables
+Arg            : Node_Id;
+Args           : List_Id;
+Decls          : List_Id;
+Decl           : Node_Id;
+Discr          : Entity_Id;
+First_Arg      : Node_Id;
+Full_Init_Type : Entity_Id;
+Init_Call      : Node_Id;
+Init_Type      : Entity_Id;
+Proc           : Entity_Id;
+--  Start of processing for Build_Initialization_Call
+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).
+if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
+return Empty_List;
+--  Nothing to do for an array of controlled components that have only
+--  the inherited Initialize primitive. This is a useful optimization
+--  for CodePeer.
+elsif Is_Trivial_Subprogram (Proc)
+and then Is_Array_Type (Full_Init_Type)
+then
+return New_List (Make_Null_Statement (Loc));
+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);
+elsif Ekind (Full_Type) = E_Private_Subtype
+and then (not Has_Discriminants (Full_Type)
+or else No (Discriminant_Constraint (Full_Type)))
+then
+Full_Type := Etype (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).
+--  In addition, if a predicate check is needed on the value
+--  of the discriminant, insert it ahead of the call.
+Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
+end if;
+if Has_Predicates (Etype (Discr)) then
+Check_Predicated_Discriminant (Arg, Discr);
+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
+Init_Call :=
+Make_Init_Call
+(Obj_Ref => New_Copy_Tree (First_Arg),
+Typ     => Typ);
+--  Guard against a missing [Deep_]Initialize when the type was not
+--  properly frozen.
+if Present (Init_Call) then
+Append_To (Res, Init_Call);
+end if;
+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   : Nat := 0;
+Proc_Id   : Entity_Id;
+Rec_Type  : Entity_Id;
+Set_Tag   : Entity_Id := Empty;
+function Build_Assignment
+(Id      : Entity_Id;
+Default : Node_Id) return List_Id;
+--  Build an assignment statement that 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;
+Default : Node_Id) return List_Id
+is
+Default_Loc : constant Source_Ptr := Sloc (Default);
+Typ         : constant Entity_Id  := Underlying_Type (Etype (Id));
+Adj_Call : Node_Id;
+Exp      : Node_Id   := Default;
+Kind     : Node_Kind := Nkind (Default);
+Lhs      : Node_Id;
+Res      : List_Id;
+function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
+--  Analysis of the aggregate has replaced discriminants by their
+--  corresponding discriminals, but these are irrelevant when the
+--  component has a mutable type and is initialized with an aggregate.
+--  Instead, they must be replaced by the values supplied in the
+--  aggregate, that will be assigned during the expansion of the
+--  assignment.
+-----------------------
+-- Replace_Discr_Ref --
+-----------------------
+function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
+Val : Node_Id;
+begin
+if Is_Entity_Name (N)
+and then Present (Entity (N))
+and then Is_Formal (Entity (N))
+and then Present (Discriminal_Link (Entity (N)))
+then
+Val :=
+Make_Selected_Component (Default_Loc,
+Prefix        => New_Copy_Tree (Lhs),
+Selector_Name =>
+New_Occurrence_Of
+(Discriminal_Link (Entity (N)), Default_Loc));
+if Present (Val) then
+Rewrite (N, New_Copy_Tree (Val));
+end if;
+end if;
+return OK;
+end Replace_Discr_Ref;
+procedure Replace_Discriminant_References is
+new Traverse_Proc (Replace_Discr_Ref);
+--  Start of processing for Build_Assignment
+begin
+Lhs :=
+Make_Selected_Component (Default_Loc,
+Prefix        => Make_Identifier (Loc, Name_uInit),
+Selector_Name => New_Occurrence_Of (Id, Default_Loc));
+Set_Assignment_OK (Lhs);
+if Nkind (Exp) = N_Aggregate
+and then Has_Discriminants (Typ)
+and then not Is_Constrained (Base_Type (Typ))
+then
+--  The aggregate may provide new values for the discriminants
+--  of the component, and other components may depend on those
+--  discriminants. Previous analysis of those expressions have
+--  replaced the discriminants by the formals of the initialization
+--  procedure for the type, but these are irrelevant in the
+--  enclosing initialization procedure: those discriminant
+--  references must be replaced by the values provided in the
+--  aggregate.
+Replace_Discriminant_References (Exp);
+end if;
+--  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 (Default), Name_Unchecked_Access,
+Name_Unrestricted_Access)
+and then Is_Entity_Name (Prefix (Default))
+and then Is_Type (Entity (Prefix (Default)))
+and then Entity (Prefix (Default)) = Rec_Type
+then
+Exp :=
+Make_Attribute_Reference (Default_Loc,
+Prefix         =>
+Make_Identifier (Default_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 not Tagged_Type_Expansion because
+--  tags are represented implicitly in objects.
+if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
+Append_To (Res,
+Make_Assignment_Statement (Default_Loc,
+Name       =>
+Make_Selected_Component (Default_Loc,
+Prefix        =>
+New_Copy_Tree (Lhs, New_Scope => Proc_Id),
+Selector_Name =>
+New_Occurrence_Of
+(First_Tag_Component (Typ), Default_Loc)),
+Expression =>
+Unchecked_Convert_To (RTE (RE_Tag),
+New_Occurrence_Of
+(Node (First_Elmt (Access_Disp_Table (Underlying_Type
+(Typ)))),
+Default_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 (Default));
+end if;
+if Needs_Finalization (Typ)
+and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
+and then not Is_Build_In_Place_Function_Call (Exp)
+then
+Adj_Call :=
+Make_Adjust_Call
+(Obj_Ref => New_Copy_Tree (Lhs),
+Typ     => Etype (Id));
+--  Guard against a missing [Deep_]Adjust when the component type
+--  was not properly frozen.
+if Present (Adj_Call) then
+Append_To (Res, Adj_Call);
+end if;
+end if;
+--  If a component type has a predicate, add check to the component
+--  assignment. Discriminants are handled at the point of the call,
+--  which provides for a better error message.
+if Comes_From_Source (Exp)
+and then Has_Predicates (Typ)
+and then not Predicate_Checks_Suppressed (Empty)
+and then not Predicates_Ignored (Typ)
+then
+Append (Make_Predicate_Check (Typ, Exp), Res);
+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 targets, since
+--  interfaces are handled directly by the target.
+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 not Tagged_Type_Expansion because
+--  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
+declare
+Elab_Sec_DT_Stmts_List : constant List_Id := New_List;
+begin
+Init_Secondary_Tags
+(Typ            => Rec_Type,
+Target         => Make_Identifier (Loc, Name_uInit),
+Init_Tags_List => Init_Tags_List,
+Stmts_List     => Elab_Sec_DT_Stmts_List,
+Fixed_Comps    => True,
+Variable_Comps => False);
+Append_To (Elab_Sec_DT_Stmts_List,
+Make_Assignment_Statement (Loc,
+Name       =>
+New_Occurrence_Of
+(Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
+Expression =>
+New_Occurrence_Of (Standard_False, Loc)));
+Prepend_List_To (Body_Stmts, New_List (
+Make_If_Statement (Loc,
+Condition       => New_Occurrence_Of (Set_Tag, Loc),
+Then_Statements => Init_Tags_List),
+Make_If_Statement (Loc,
+Condition       =>
+New_Occurrence_Of
+(Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
+Then_Statements => Elab_Sec_DT_Stmts_List)));
+end;
+else
+Prepend_To (Body_Stmts,
+Make_If_Statement (Loc,
+Condition       => New_Occurrence_Of (Set_Tag, Loc),
+Then_Statements => Init_Tags_List));
+end if;
+--  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),
+Init_Tags_List => Init_Tags_List,
+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),
+Init_Tags_List => Init_Tags_List,
+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_Id : Entity_Id;
+begin
+--  Create a local version of Deep_Finalize which has indication
+--  of partial initialization state.
+DF_Id :=
+Make_Defining_Identifier (Loc,
+Chars => New_External_Name (Name_uFinalizer));
+Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
+Set_Exception_Handlers (Handled_Stmt_Node, New_List (
+Make_Exception_Handler (Loc,
+Exception_Choices => New_List (
+Make_Others_Choice (Loc)),
+Statements        => New_List (
+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))),
+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
+then
+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 Secondary_Stack_Size
+--  components are filled in 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,
+Name_uSecondary_Stack_Size)
+then
+declare
+Exp   : Node_Id;
+Nam   : Name_Id;
+pragma Warnings (Off, Nam);
+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;
+elsif Chars (Id) = Name_uSecondary_Stack_Size then
+Nam := Name_Secondary_Stack_Size;
+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);
+--  Conversion for Secondary_Stack_Size value
+elsif Nam = Name_Secondary_Stack_Size then
+Exp := Convert_To (RTE (RE_Size_Type), 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 := No_Location;
+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
+Rec_Type := Defining_Identifier (N);
+--  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));
+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_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type));
+--  Do not build an aggregate if Modify_Tree_For_C, this isn't
+--  needed and may generate early references to non frozen types
+--  since we expand aggregate much more systematically.
+if Modify_Tree_For_C then
+return;
+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_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);
+if Chars (Op) = Name_Op_Eq
+and then Etype (Op) = Standard_Boolean
+and then Etype (First_Formal (Op)) = T
+and then Etype (Next_Formal (First_Formal (Op))) = T
+then
+return Op;
+end if;
+Next_Elmt (Prim);
+end loop;
+return Empty;
+end User_Defined_Eq;
+--  Start of processing for Build_Untagged_Equality
+begin
+--  If a record component has a primitive equality operation, we must
+--  build the corresponding one for the current type.
+Build_Eq := False;
+Comp := First_Component (Typ);
+while Present (Comp) loop
+if Is_Record_Type (Etype (Comp))
+and then Present (User_Defined_Eq (Etype (Comp)))
+then
+Build_Eq := True;
+end if;
+Next_Component (Comp);
+end loop;
+--  If there is a user-defined equality for the type, we do not create
+--  the implicit one.
+Prim := First_Elmt (Collect_Primitive_Operations (Typ));
+Eq_Op := Empty;
+while Present (Prim) loop
+if Chars (Node (Prim)) = Name_Op_Eq
+and then Comes_From_Source (Node (Prim))
+--  Don't we also need to check formal types and return type as in
+--  User_Defined_Eq above???
+then
+Eq_Op := Node (Prim);
+Build_Eq := False;
+exit;
+end if;
+Next_Elmt (Prim);
+end loop;
+--  If the type is derived, inherit the operation, if present, from the
+--  parent type. It may have been declared after the type derivation. If
+--  the parent type itself is derived, it may have inherited an operation
+--  that has itself been overridden, so update its alias and related
+--  flags. Ditto for inequality.
+if No (Eq_Op) and then Is_Derived_Type (Typ) then
+Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
+while Present (Prim) loop
+if Chars (Node (Prim)) = Name_Op_Eq then
+Copy_TSS (Node (Prim), Typ);
+Build_Eq := False;
+declare
+Op    : constant Entity_Id := User_Defined_Eq (Typ);
+Eq_Op : constant Entity_Id := Node (Prim);
+NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
+begin
+if Present (Op) then
+Set_Alias (Op, Eq_Op);
+Set_Is_Abstract_Subprogram
+(Op, Is_Abstract_Subprogram (Eq_Op));
+if Chars (Next_Entity (Op)) = Name_Op_Ne then
+Set_Is_Abstract_Subprogram
+(Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
+end if;
+end if;
+end;
+exit;
+end if;
+Next_Elmt (Prim);
+end loop;
+end if;
+--  If not inherited and not user-defined, build body as for a type with
+--  tagged components.
+if Build_Eq then
+Decl :=
+Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
+Op := Defining_Entity (Decl);
+Set_TSS (Typ, Op);
+Set_Is_Pure (Op);
+if Is_Library_Level_Entity (Typ) then
+Set_Is_Public (Op);
+end if;
+end if;
+end Build_Untagged_Equality;
+-----------------------------------
+-- Build_Variant_Record_Equality --
+-----------------------------------
+--  Generates:
+--    function _Equality (X, Y : T) return Boolean is
+--    begin
+--       --  Compare discriminants
+--       if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
+--          return False;
+--       end if;
+--       --  Compare components
+--       if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
+--          return False;
+--       end if;
+--       --  Compare variant part
+--       case X.D1 is
+--          when V1 =>
+--             if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
+--                return False;
+--             end if;
+--          ...
+--          when Vn =>
+--             if X.Cn /= Y.Cn or else ... then
+--                return False;
+--             end if;
+--       end case;
+--       return True;
+--    end _Equality;
+procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
+Loc : constant Source_Ptr := Sloc (Typ);
+F : constant Entity_Id :=
+Make_Defining_Identifier (Loc,
+Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
+X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
+Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
+Def    : constant Node_Id := Parent (Typ);
+Comps  : constant Node_Id := Component_List (Type_Definition (Def));
+Stmts  : constant List_Id := New_List;
+Pspecs : constant List_Id := New_List;
+begin
+--  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 equality
+--  test routines are not allowed for variant records if this restriction
+--  is active.
+if Restriction_Active (No_Implicit_Conditionals) then
+return;
+end if;
+--  Derived Unchecked_Union types no longer inherit the equality function
+--  of their parent.
+if Is_Derived_Type (Typ)
+and then not Is_Unchecked_Union (Typ)
+and then not Has_New_Non_Standard_Rep (Typ)
+then
+declare
+Parent_Eq : constant Entity_Id :=
+TSS (Root_Type (Typ), TSS_Composite_Equality);
+begin
+if Present (Parent_Eq) then
+Copy_TSS (Parent_Eq, Typ);
+return;
+end if;
+end;
+end if;
+Discard_Node (
+Make_Subprogram_Body (Loc,
+Specification =>
+Make_Function_Specification (Loc,
+Defining_Unit_Name       => F,
+Parameter_Specifications => Pspecs,
+Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
+Declarations               => New_List,
+Handled_Statement_Sequence =>
+Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
+Append_To (Pspecs,
+Make_Parameter_Specification (Loc,
+Defining_Identifier => X,
+Parameter_Type      => New_Occurrence_Of (Typ, Loc)));
+Append_To (Pspecs,
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Y,
+Parameter_Type      => New_Occurrence_Of (Typ, Loc)));
+--  Unchecked_Unions require additional machinery to support equality.
+--  Two extra parameters (A and B) are added to the equality function
+--  parameter list for each discriminant of the type, in order to
+--  capture the inferred values of the discriminants in equality calls.
+--  The names of the parameters match the names of the corresponding
+--  discriminant, with an added suffix.
+if Is_Unchecked_Union (Typ) then
+declare
+Discr      : Entity_Id;
+Discr_Type : Entity_Id;
+A, B       : Entity_Id;
+New_Discrs : Elist_Id;
+begin
+New_Discrs := New_Elmt_List;
+Discr := First_Discriminant (Typ);
+while Present (Discr) loop
+Discr_Type := Etype (Discr);
+A := Make_Defining_Identifier (Loc,
+Chars => New_External_Name (Chars (Discr), 'A'));
+B := Make_Defining_Identifier (Loc,
+Chars => New_External_Name (Chars (Discr), 'B'));
+--  Add new parameters to the parameter list
+Append_To (Pspecs,
+Make_Parameter_Specification (Loc,
+Defining_Identifier => A,
+Parameter_Type      =>
+New_Occurrence_Of (Discr_Type, Loc)));
+Append_To (Pspecs,
+Make_Parameter_Specification (Loc,
+Defining_Identifier => B,
+Parameter_Type      =>
+New_Occurrence_Of (Discr_Type, Loc)));
+Append_Elmt (A, New_Discrs);
+--  Generate the following code to compare each of the inferred
+--  discriminants:
+--  if a /= b then
+--     return False;
+--  end if;
+Append_To (Stmts,
+Make_If_Statement (Loc,
+Condition       =>
+Make_Op_Ne (Loc,
+Left_Opnd  => New_Occurrence_Of (A, Loc),
+Right_Opnd => New_Occurrence_Of (B, Loc)),
+Then_Statements => New_List (
+Make_Simple_Return_Statement (Loc,
+Expression =>
+New_Occurrence_Of (Standard_False, Loc)))));
+Next_Discriminant (Discr);
+end loop;
+--  Generate component-by-component comparison. Note that we must
+--  propagate the inferred discriminants formals to act as
+--  the case statement switch. Their value is added when an
+--  equality call on unchecked unions is expanded.
+Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs));
+end;
+--  Normal case (not unchecked union)
+else
+Append_To (Stmts,
+Make_Eq_If (Typ, Discriminant_Specifications (Def)));
+Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
+end if;
+Append_To (Stmts,
+Make_Simple_Return_Statement (Loc,
+Expression => New_Occurrence_Of (Standard_True, Loc)));
+Set_TSS (Typ, F);
+Set_Is_Pure (F);
+if not Debug_Generated_Code then
+Set_Debug_Info_Off (F);
+end if;
+end Build_Variant_Record_Equality;
+-----------------------------
+-- Check_Stream_Attributes --
+-----------------------------
+procedure Check_Stream_Attributes (Typ : Entity_Id) is
+Comp      : Entity_Id;
+Par_Read  : constant Boolean :=
+Stream_Attribute_Available (Typ, TSS_Stream_Read)
+and then not Has_Specified_Stream_Read (Typ);
+Par_Write : constant Boolean :=
+Stream_Attribute_Available (Typ, TSS_Stream_Write)
+and then not Has_Specified_Stream_Write (Typ);
+procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
+--  Check that Comp has a user-specified Nam stream attribute
+----------------
+-- Check_Attr --
+----------------
+procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
+begin
+if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
+Error_Msg_Name_1 := Nam;
+Error_Msg_N
+("|component& in limited extension must have% attribute", Comp);
+end if;
+end Check_Attr;
+--  Start of processing for Check_Stream_Attributes
+begin
+if Par_Read or else Par_Write then
+Comp := First_Component (Typ);
+while Present (Comp) loop
+if Comes_From_Source (Comp)
+and then Original_Record_Component (Comp) = Comp
+and then Is_Limited_Type (Etype (Comp))
+then
+if Par_Read then
+Check_Attr (Name_Read, TSS_Stream_Read);
+end if;
+if Par_Write then
+Check_Attr (Name_Write, TSS_Stream_Write);
+end if;
+end if;
+Next_Component (Comp);
+end loop;
+end if;
+end Check_Stream_Attributes;
+----------------------
+-- Clean_Task_Names --
+----------------------
+procedure Clean_Task_Names
+(Typ     : Entity_Id;
+Proc_Id : Entity_Id)
+is
+begin
+if Has_Task (Typ)
+and then not Restriction_Active (No_Implicit_Heap_Allocations)
+and then not Global_Discard_Names
+and then Tagged_Type_Expansion
+then
+Set_Uses_Sec_Stack (Proc_Id);
+end if;
+end Clean_Task_Names;
+------------------------------
+-- Expand_Freeze_Array_Type --
+------------------------------
+procedure Expand_Freeze_Array_Type (N : Node_Id) is
+Typ      : constant Entity_Id := Entity (N);
+Base     : constant Entity_Id := Base_Type (Typ);
+Comp_Typ : constant Entity_Id := Component_Type (Typ);
+begin
+if not Is_Bit_Packed_Array (Typ) then
+--  If the component contains tasks, so does the array type. This may
+--  not be indicated in the array type because the component may have
+--  been a private type at the point of definition. Same if component
+--  type is controlled or contains protected objects.
+Propagate_Concurrent_Flags (Base, Comp_Typ);
+Set_Has_Controlled_Component
+(Base, Has_Controlled_Component (Comp_Typ)
+or else Is_Controlled (Comp_Typ));
+if No (Init_Proc (Base)) then
+--  If this is an anonymous array created for a declaration with
+--  an initial value, its init_proc will never be called. The
+--  initial value itself may have been expanded into assignments,
+--  in which case the object declaration is carries the
+--  No_Initialization flag.
+if Is_Itype (Base)
+and then Nkind (Associated_Node_For_Itype (Base)) =
+N_Object_Declaration
+and then
+(Present (Expression (Associated_Node_For_Itype (Base)))
+or else No_Initialization (Associated_Node_For_Itype (Base)))
+then
+null;
+--  We do not need an init proc for string or wide [wide] string,
+--  since the only time these need initialization in normalize or
+--  initialize scalars mode, and these types are treated specially
+--  and do not need initialization procedures.
+elsif Is_Standard_String_Type (Base) then
+null;
+--  Otherwise we have to build an init proc for the subtype
+else
+Build_Array_Init_Proc (Base, N);
+end if;
+end if;
+if Typ = Base and then Has_Controlled_Component (Base) then
+Build_Controlling_Procs (Base);
+if not Is_Limited_Type (Comp_Typ)
+and then Number_Dimensions (Typ) = 1
+then
+Build_Slice_Assignment (Typ);
+end if;
+end if;
+--  For packed case, default initialization, except if the component type
+--  is itself a packed structure with an initialization procedure, or
+--  initialize/normalize scalars active, and we have a base type, or the
+--  type is public, because in that case a client might specify
+--  Normalize_Scalars and there better be a public Init_Proc for it.
+elsif (Present (Init_Proc (Component_Type (Base)))
+and then No (Base_Init_Proc (Base)))
+or else (Init_Or_Norm_Scalars and then Base = Typ)
+or else Is_Public (Typ)
+then
+Build_Array_Init_Proc (Base, N);
+end if;
+end Expand_Freeze_Array_Type;
+-----------------------------------
+-- Expand_Freeze_Class_Wide_Type --
+-----------------------------------
+procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
+function Is_C_Derivation (Typ : Entity_Id) return Boolean;
+--  Given a type, determine whether it is derived from a C or C++ root
+---------------------
+-- Is_C_Derivation --
+---------------------
+function Is_C_Derivation (Typ : Entity_Id) return Boolean is
+T : Entity_Id;
+begin
+T := Typ;
+loop
+if Is_CPP_Class (T)
+or else Convention (T) = Convention_C
+or else Convention (T) = Convention_CPP
+then
+return True;
+end if;
+exit when T = Etype (T);
+T := Etype (T);
+end loop;
+return False;
+end Is_C_Derivation;
+--  Local variables
+Typ  : constant Entity_Id := Entity (N);
+Root : constant Entity_Id := Root_Type (Typ);
+--  Start of processing for Expand_Freeze_Class_Wide_Type
+begin
+--  Certain run-time configurations and targets do not provide support
+--  for controlled types.
+if Restriction_Active (No_Finalization) then
+return;
+--  Do not create TSS routine Finalize_Address when dispatching calls are
+--  disabled since the core of the routine is a dispatching call.
+elsif Restriction_Active (No_Dispatching_Calls) then
+return;
+--  Do not create TSS routine Finalize_Address for concurrent class-wide
+--  types. Ignore C, C++, CIL and Java types since it is assumed that the
+--  non-Ada side will handle their destruction.
+elsif Is_Concurrent_Type (Root)
+or else Is_C_Derivation (Root)
+or else Convention (Typ) = Convention_CPP
+then
+return;
+--  Do not create TSS routine Finalize_Address when compiling in CodePeer
+--  mode since the routine contains an Unchecked_Conversion.
+elsif CodePeer_Mode then
+return;
+end if;
+--  Create the body of TSS primitive Finalize_Address. This automatically
+--  sets the TSS entry for the class-wide type.
+Make_Finalize_Address_Body (Typ);
+end Expand_Freeze_Class_Wide_Type;
+------------------------------------
+-- Expand_Freeze_Enumeration_Type --
+------------------------------------
+procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
+Typ : constant Entity_Id  := Entity (N);
+Loc : constant Source_Ptr := Sloc (Typ);
+Arr           : Entity_Id;
+Ent           : Entity_Id;
+Fent          : Entity_Id;
+Is_Contiguous : Boolean;
+Ityp          : Entity_Id;
+Last_Repval   : Uint;
+Lst           : List_Id;
+Num           : Nat;
+Pos_Expr      : Node_Id;
+Func : Entity_Id;
+pragma Warnings (Off, Func);
+begin
+--  Various optimizations possible if given representation is contiguous
+Is_Contiguous := True;
+Ent := First_Literal (Typ);
+Last_Repval := Enumeration_Rep (Ent);
+Next_Literal (Ent);
+while Present (Ent) loop
+if Enumeration_Rep (Ent) - Last_Repval /= 1 then
+Is_Contiguous := False;
+exit;
+else
+Last_Repval := Enumeration_Rep (Ent);
+end if;
+Next_Literal (Ent);
+end loop;
+if Is_Contiguous then
+Set_Has_Contiguous_Rep (Typ);
+Ent := First_Literal (Typ);
+Num := 1;
+Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent)));
+else
+--  Build list of literal references
+Lst := New_List;
+Num := 0;
+Ent := First_Literal (Typ);
+while Present (Ent) loop
+Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
+Num := Num + 1;
+Next_Literal (Ent);
+end loop;
+end if;
+--  Now build an array declaration
+--    typA : array (Natural range 0 .. num - 1) of ctype :=
+--             (v, v, v, v, v, ....)
+--  where ctype is the corresponding integer type. If the representation
+--  is contiguous, we only keep the first literal, which provides the
+--  offset for Pos_To_Rep computations.
+Arr :=
+Make_Defining_Identifier (Loc,
+Chars => New_External_Name (Chars (Typ), 'A'));
+Append_Freeze_Action (Typ,
+Make_Object_Declaration (Loc,
+Defining_Identifier => Arr,
+Constant_Present    => True,
+Object_Definition   =>
+Make_Constrained_Array_Definition (Loc,
+Discrete_Subtype_Definitions => New_List (
+Make_Subtype_Indication (Loc,
+Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
+Constraint   =>
+Make_Range_Constraint (Loc,
+Range_Expression =>
+Make_Range (Loc,
+Low_Bound  =>
+Make_Integer_Literal (Loc, 0),
+High_Bound =>
+Make_Integer_Literal (Loc, Num - 1))))),
+Component_Definition =>
+Make_Component_Definition (Loc,
+Aliased_Present => False,
+Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
+Expression =>
+Make_Aggregate (Loc,
+Expressions => Lst)));
+Set_Enum_Pos_To_Rep (Typ, Arr);
+--  Now we build the function that converts representation values to
+--  position values. This function has the form:
+--    function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
+--    begin
+--       case ityp!(A) is
+--         when enum-lit'Enum_Rep => return posval;
+--         when enum-lit'Enum_Rep => return posval;
+--         ...
+--         when others   =>
+--           [raise Constraint_Error when F "invalid data"]
+--           return -1;
+--       end case;
+--    end;
+--  Note: the F parameter determines whether the others case (no valid
+--  representation) raises Constraint_Error or returns a unique value
+--  of minus one. The latter case is used, e.g. in 'Valid code.
+--  Note: the reason we use Enum_Rep values in the case here is to avoid
+--  the code generator making inappropriate assumptions about the range
+--  of the values in the case where the value is invalid. ityp is a
+--  signed or unsigned integer type of appropriate width.
+--  Note: if exceptions are not supported, then we suppress the raise
+--  and return -1 unconditionally (this is an erroneous program in any
+--  case and there is no obligation to raise Constraint_Error here). We
+--  also do this if pragma Restrictions (No_Exceptions) is active.
+--  Is this right??? What about No_Exception_Propagation???
+--  Representations are signed
+if Enumeration_Rep (First_Literal (Typ)) < 0 then
+--  The underlying type is signed. Reset the Is_Unsigned_Type
+--  explicitly, because it might have been inherited from
+--  parent type.
+Set_Is_Unsigned_Type (Typ, False);
+if Esize (Typ) <= Standard_Integer_Size then
+Ityp := Standard_Integer;
+else
+Ityp := Universal_Integer;
+end if;
+--  Representations are unsigned
+else
+if Esize (Typ) <= Standard_Integer_Size then
+Ityp := RTE (RE_Unsigned);
+else
+Ityp := RTE (RE_Long_Long_Unsigned);
+end if;
+end if;
+--  The body of the function is a case statement. First collect case
+--  alternatives, or optimize the contiguous case.
+Lst := New_List;
+--  If representation is contiguous, Pos is computed by subtracting
+--  the representation of the first literal.
+if Is_Contiguous then
+Ent := First_Literal (Typ);
+if Enumeration_Rep (Ent) = Last_Repval then
+--  Another special case: for a single literal, Pos is zero
+Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
+else
+Pos_Expr :=
+Convert_To (Standard_Integer,
+Make_Op_Subtract (Loc,
+Left_Opnd  =>
+Unchecked_Convert_To
+(Ityp, Make_Identifier (Loc, Name_uA)),
+Right_Opnd =>
+Make_Integer_Literal (Loc,
+Intval => Enumeration_Rep (First_Literal (Typ)))));
+end if;
+Append_To (Lst,
+Make_Case_Statement_Alternative (Loc,
+Discrete_Choices => New_List (
+Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
+Low_Bound =>
+Make_Integer_Literal (Loc,
+Intval =>  Enumeration_Rep (Ent)),
+High_Bound =>
+Make_Integer_Literal (Loc, Intval => Last_Repval))),
+Statements => New_List (
+Make_Simple_Return_Statement (Loc,
+Expression => Pos_Expr))));
+else
+Ent := First_Literal (Typ);
+while Present (Ent) loop
+Append_To (Lst,
+Make_Case_Statement_Alternative (Loc,
+Discrete_Choices => New_List (
+Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
+Intval => Enumeration_Rep (Ent))),
+Statements => New_List (
+Make_Simple_Return_Statement (Loc,
+Expression =>
+Make_Integer_Literal (Loc,
+Intval => Enumeration_Pos (Ent))))));
+Next_Literal (Ent);
+end loop;
+end if;
+--  In normal mode, add the others clause with the test.
+--  If Predicates_Ignored is True, validity checks do not apply to
+--  the subtype.
+if not No_Exception_Handlers_Set
+and then not Predicates_Ignored (Typ)
+then
+Append_To (Lst,
+Make_Case_Statement_Alternative (Loc,
+Discrete_Choices => New_List (Make_Others_Choice (Loc)),
+Statements       => New_List (
+Make_Raise_Constraint_Error (Loc,
+Condition => Make_Identifier (Loc, Name_uF),
+Reason    => CE_Invalid_Data),
+Make_Simple_Return_Statement (Loc,
+Expression => Make_Integer_Literal (Loc, -1)))));
+--  If either of the restrictions No_Exceptions_Handlers/Propagation is
+--  active then return -1 (we cannot usefully raise Constraint_Error in
+--  this case). See description above for further details.
+else
+Append_To (Lst,
+Make_Case_Statement_Alternative (Loc,
+Discrete_Choices => New_List (Make_Others_Choice (Loc)),
+Statements       => New_List (
+Make_Simple_Return_Statement (Loc,
+Expression => Make_Integer_Literal (Loc, -1)))));
+end if;
+--  Now we can build the function body
+Fent :=
+Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
+Func :=
+Make_Subprogram_Body (Loc,
+Specification =>
+Make_Function_Specification (Loc,
+Defining_Unit_Name       => Fent,
+Parameter_Specifications => New_List (
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Name_uA),
+Parameter_Type => New_Occurrence_Of (Typ, Loc)),
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Name_uF),
+Parameter_Type =>
+New_Occurrence_Of (Standard_Boolean, Loc))),
+Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
+Declarations => Empty_List,
+Handled_Statement_Sequence =>
+Make_Handled_Sequence_Of_Statements (Loc,
+Statements => New_List (
+Make_Case_Statement (Loc,
+Expression =>
+Unchecked_Convert_To
+(Ityp, Make_Identifier (Loc, Name_uA)),
+Alternatives => Lst))));
+Set_TSS (Typ, Fent);
+--  Set Pure flag (it will be reset if the current context is not Pure).
+--  We also pretend there was a pragma Pure_Function so that for purposes
+--  of optimization and constant-folding, we will consider the function
+--  Pure even if we are not in a Pure context).
+Set_Is_Pure (Fent);
+Set_Has_Pragma_Pure_Function (Fent);
+--  Unless we are in -gnatD mode, where we are debugging generated code,
+--  this is an internal entity for which we don't need debug info.
+if not Debug_Generated_Code then
+Set_Debug_Info_Off (Fent);
+end if;
+Set_Is_Inlined (Fent);
+exception
+when RE_Not_Available =>
+return;
+end Expand_Freeze_Enumeration_Type;
+-------------------------------
+-- Expand_Freeze_Record_Type --
+-------------------------------
+procedure Expand_Freeze_Record_Type (N : Node_Id) is
+Typ      : constant Node_Id := Entity (N);
+Typ_Decl : constant Node_Id := Parent (Typ);
+Comp        : Entity_Id;
+Comp_Typ    : Entity_Id;
+Predef_List : List_Id;
+Wrapper_Decl_List : List_Id := No_List;
+Wrapper_Body_List : List_Id := No_List;
+Renamed_Eq : Node_Id := Empty;
+--  Defining unit name for the predefined equality function in the case
+--  where the type has a primitive operation that is a renaming of
+--  predefined equality (but only if there is also an overriding
+--  user-defined equality function). Used to pass this entity from
+--  Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
+--  Start of processing for Expand_Freeze_Record_Type
+begin
+--  Build discriminant checking functions if not a derived type (for
+--  derived types that are not tagged types, always use the discriminant
+--  checking functions of the parent type). However, for untagged types
+--  the derivation may have taken place before the parent was frozen, so
+--  we copy explicitly the discriminant checking functions from the
+--  parent into the components of the derived type.
+if not Is_Derived_Type (Typ)
+or else Has_New_Non_Standard_Rep (Typ)
+or else Is_Tagged_Type (Typ)
+then
+Build_Discr_Checking_Funcs (Typ_Decl);
+elsif Is_Derived_Type (Typ)
+and then not Is_Tagged_Type (Typ)
+--  If we have a derived Unchecked_Union, we do not inherit the
+--  discriminant checking functions from the parent type since the
+--  discriminants are non existent.
+and then not Is_Unchecked_Union (Typ)
+and then Has_Discriminants (Typ)
+then
+declare
+Old_Comp : Entity_Id;
+begin
+Old_Comp :=
+First_Component (Base_Type (Underlying_Type (Etype (Typ))));
+Comp := First_Component (Typ);
+while Present (Comp) loop
+if Ekind (Comp) = E_Component
+and then Chars (Comp) = Chars (Old_Comp)
+then
+Set_Discriminant_Checking_Func
+(Comp, Discriminant_Checking_Func (Old_Comp));
+end if;
+Next_Component (Old_Comp);
+Next_Component (Comp);
+end loop;
+end;
+end if;
+if Is_Derived_Type (Typ)
+and then Is_Limited_Type (Typ)
+and then Is_Tagged_Type (Typ)
+then
+Check_Stream_Attributes (Typ);
+end if;
+--  Update task, protected, and controlled component flags, because some
+--  of the component types may have been private at the point of the
+--  record declaration. Detect anonymous access-to-controlled components.
+Comp := First_Component (Typ);
+while Present (Comp) loop
+Comp_Typ := Etype (Comp);
+Propagate_Concurrent_Flags (Typ, Comp_Typ);
+--  Do not set Has_Controlled_Component on a class-wide equivalent
+--  type. See Make_CW_Equivalent_Type.
+if not Is_Class_Wide_Equivalent_Type (Typ)
+and then
+(Has_Controlled_Component (Comp_Typ)
+or else (Chars (Comp) /= Name_uParent
+and then Is_Controlled (Comp_Typ)))
+then
+Set_Has_Controlled_Component (Typ);
+end if;
+Next_Component (Comp);
+end loop;
+--  Handle constructors of untagged CPP_Class types
+if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then
+Set_CPP_Constructors (Typ);
+end if;
+--  Creation of the Dispatch Table. Note that a Dispatch Table is built
+--  for regular tagged types as well as for Ada types deriving from a C++
+--  Class, but not for tagged types directly corresponding to C++ classes
+--  In the later case we assume that it is created in the C++ side and we
+--  just use it.
+if Is_Tagged_Type (Typ) then
+--  Add the _Tag component
+if Underlying_Type (Etype (Typ)) = Typ then
+Expand_Tagged_Root (Typ);
+end if;
+if Is_CPP_Class (Typ) then
+Set_All_DT_Position (Typ);
+--  Create the tag entities with a minimum decoration
+if Tagged_Type_Expansion then
+Append_Freeze_Actions (Typ, Make_Tags (Typ));
+end if;
+Set_CPP_Constructors (Typ);
+else
+if not Building_Static_DT (Typ) then
+--  Usually inherited primitives are not delayed but the first
+--  Ada extension of a CPP_Class is an exception since the
+--  address of the inherited subprogram has to be inserted in
+--  the new Ada Dispatch Table and this is a freezing action.
+--  Similarly, if this is an inherited operation whose parent is
+--  not frozen yet, it is not in the DT of the parent, and we
+--  generate an explicit freeze node for the inherited operation
+--  so it is properly inserted in the DT of the current type.
+declare
+Elmt : Elmt_Id;
+Subp : Entity_Id;
+begin
+Elmt := First_Elmt (Primitive_Operations (Typ));
+while Present (Elmt) loop
+Subp := Node (Elmt);
+if Present (Alias (Subp)) then
+if Is_CPP_Class (Etype (Typ)) then
+Set_Has_Delayed_Freeze (Subp);
+elsif Has_Delayed_Freeze (Alias (Subp))
+and then not Is_Frozen (Alias (Subp))
+then
+Set_Is_Frozen (Subp, False);
+Set_Has_Delayed_Freeze (Subp);
+end if;
+end if;
+Next_Elmt (Elmt);
+end loop;
+end;
+end if;
+--  Unfreeze momentarily the type to add the predefined primitives
+--  operations. The reason we unfreeze is so that these predefined
+--  operations will indeed end up as primitive operations (which
+--  must be before the freeze point).
+Set_Is_Frozen (Typ, False);
+--  Do not add the spec of predefined primitives in case of
+--  CPP tagged type derivations that have convention CPP.
+if Is_CPP_Class (Root_Type (Typ))
+and then Convention (Typ) = Convention_CPP
+then
+null;
+--  Do not add the spec of the predefined primitives if we are
+--  compiling under restriction No_Dispatching_Calls.
+elsif not Restriction_Active (No_Dispatching_Calls) then
+Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq);
+Insert_List_Before_And_Analyze (N, Predef_List);
+end if;
+--  Ada 2005 (AI-391): For a nonabstract null extension, create
+--  wrapper functions for each nonoverridden inherited function
+--  with a controlling result of the type. The wrapper for such
+--  a function returns an extension aggregate that invokes the
+--  parent function.
+if Ada_Version >= Ada_2005
+and then not Is_Abstract_Type (Typ)
+and then Is_Null_Extension (Typ)
+then
+Make_Controlling_Function_Wrappers
+(Typ, Wrapper_Decl_List, Wrapper_Body_List);
+Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
+end if;
+--  Ada 2005 (AI-251): For a nonabstract type extension, build
+--  null procedure declarations for each set of homographic null
+--  procedures that are inherited from interface types but not
+--  overridden. This is done to ensure that the dispatch table
+--  entry associated with such null primitives are properly filled.
+if Ada_Version >= Ada_2005
+and then Etype (Typ) /= Typ
+and then not Is_Abstract_Type (Typ)
+and then Has_Interfaces (Typ)
+then
+Insert_Actions (N, Make_Null_Procedure_Specs (Typ));
+end if;
+Set_Is_Frozen (Typ);
+if not Is_Derived_Type (Typ)
+or else Is_Tagged_Type (Etype (Typ))
+then
+Set_All_DT_Position (Typ);
+--  If this is a type derived from an untagged private type whose
+--  full view is tagged, the type is marked tagged for layout
+--  reasons, but it has no dispatch table.
+elsif Is_Derived_Type (Typ)
+and then Is_Private_Type (Etype (Typ))
+and then not Is_Tagged_Type (Etype (Typ))
+then
+return;
+end if;
+--  Create and decorate the tags. Suppress their creation when
+--  not Tagged_Type_Expansion because the dispatching mechanism is
+--  handled internally by the virtual target.
+if Tagged_Type_Expansion then
+Append_Freeze_Actions (Typ, Make_Tags (Typ));
+--  Generate dispatch table of locally defined tagged type.
+--  Dispatch tables of library level tagged types are built
+--  later (see Analyze_Declarations).
+if not Building_Static_DT (Typ) then
+Append_Freeze_Actions (Typ, Make_DT (Typ));
+end if;
+end if;
+--  If the type has unknown discriminants, propagate dispatching
+--  information to its underlying record view, which does not get
+--  its own dispatch table.
+if Is_Derived_Type (Typ)
+and then Has_Unknown_Discriminants (Typ)
+and then Present (Underlying_Record_View (Typ))
+then
+declare
+Rep : constant Entity_Id := Underlying_Record_View (Typ);
+begin
+Set_Access_Disp_Table
+(Rep, Access_Disp_Table           (Typ));
+Set_Dispatch_Table_Wrappers
+(Rep, Dispatch_Table_Wrappers     (Typ));
+Set_Direct_Primitive_Operations
+(Rep, Direct_Primitive_Operations (Typ));
+end;
+end if;
+--  Make sure that the primitives Initialize, Adjust and Finalize
+--  are Frozen before other TSS subprograms. We don't want them
+--  Frozen inside.
+if Is_Controlled (Typ) then
+if not Is_Limited_Type (Typ) then
+Append_Freeze_Actions (Typ,
+Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ));
+end if;
+Append_Freeze_Actions (Typ,
+Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ));
+Append_Freeze_Actions (Typ,
+Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ));
+end if;
+--  Freeze rest of primitive operations. There is no need to handle
+--  the predefined primitives if we are compiling under restriction
+--  No_Dispatching_Calls.
+if not Restriction_Active (No_Dispatching_Calls) then
+Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ));
+end if;
+end if;
+--  In the untagged case, ever since Ada 83 an equality function must
+--  be  provided for variant records that are not unchecked unions.
+--  In Ada 2012 the equality function composes, and thus must be built
+--  explicitly just as for tagged records.
+elsif Has_Discriminants (Typ)
+and then not Is_Limited_Type (Typ)
+then
+declare
+Comps : constant Node_Id :=
+Component_List (Type_Definition (Typ_Decl));
+begin
+if Present (Comps)
+and then Present (Variant_Part (Comps))
+then
+Build_Variant_Record_Equality (Typ);
+end if;
+end;
+--  Otherwise create primitive equality operation (AI05-0123)
+--  This is done unconditionally to ensure that tools can be linked
+--  properly with user programs compiled with older language versions.
+--  In addition, this is needed because "=" composes for bounded strings
+--  in all language versions (see Exp_Ch4.Expand_Composite_Equality).
+elsif Comes_From_Source (Typ)
+and then Convention (Typ) = Convention_Ada
+and then not Is_Limited_Type (Typ)
+then
+Build_Untagged_Equality (Typ);
+end if;
+--  Before building the record initialization procedure, if we are
+--  dealing with a concurrent record value type, then we must go through
+--  the discriminants, exchanging discriminals between the concurrent
+--  type and the concurrent record value type. See the section "Handling
+--  of Discriminants" in the Einfo spec for details.
+if Is_Concurrent_Record_Type (Typ)
+and then Has_Discriminants (Typ)
+then
+declare
+Ctyp       : constant Entity_Id :=
+Corresponding_Concurrent_Type (Typ);
+Conc_Discr : Entity_Id;
+Rec_Discr  : Entity_Id;
+Temp       : Entity_Id;
+begin
+Conc_Discr := First_Discriminant (Ctyp);
+Rec_Discr  := First_Discriminant (Typ);
+while Present (Conc_Discr) loop
+Temp := Discriminal (Conc_Discr);
+Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
+Set_Discriminal (Rec_Discr, Temp);
+Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
+Set_Discriminal_Link (Discriminal (Rec_Discr),  Rec_Discr);
+Next_Discriminant (Conc_Discr);
+Next_Discriminant (Rec_Discr);
+end loop;
+end;
+end if;
+if Has_Controlled_Component (Typ) then
+Build_Controlling_Procs (Typ);
+end if;
+Adjust_Discriminants (Typ);
+--  Do not need init for interfaces on virtual targets since they're
+--  abstract.
+if Tagged_Type_Expansion or else not Is_Interface (Typ) then
+Build_Record_Init_Proc (Typ_Decl, Typ);
+end if;
+--  For tagged type that are not interfaces, build bodies of primitive
+--  operations. Note: do this after building the record initialization
+--  procedure, since the primitive operations may need the initialization
+--  routine. There is no need to add predefined primitives of interfaces
+--  because all their predefined primitives are abstract.
+if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
+--  Do not add the body of predefined primitives in case of CPP tagged
+--  type derivations that have convention CPP.
+if Is_CPP_Class (Root_Type (Typ))
+and then Convention (Typ) = Convention_CPP
+then
+null;
+--  Do not add the body of the predefined primitives if we are
+--  compiling under restriction No_Dispatching_Calls or if we are
+--  compiling a CPP tagged type.
+elsif not Restriction_Active (No_Dispatching_Calls) then
+--  Create the body of TSS primitive Finalize_Address. This must
+--  be done before the bodies of all predefined primitives are
+--  created. If Typ is limited, Stream_Input and Stream_Read may
+--  produce build-in-place allocations and for those the expander
+--  needs Finalize_Address.
+Make_Finalize_Address_Body (Typ);
+Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
+Append_Freeze_Actions (Typ, Predef_List);
+end if;
+--  Ada 2005 (AI-391): If any wrappers were created for nonoverridden
+--  inherited functions, then add their bodies to the freeze actions.
+if Present (Wrapper_Body_List) then
+Append_Freeze_Actions (Typ, Wrapper_Body_List);
+end if;
+--  Create extra formals for the primitive operations of the type.
+--  This must be done before analyzing the body of the initialization
+--  procedure, because a self-referential type might call one of these
+--  primitives in the body of the init_proc itself.
+declare
+Elmt : Elmt_Id;
+Subp : Entity_Id;
+begin
+Elmt := First_Elmt (Primitive_Operations (Typ));
+while Present (Elmt) loop
+Subp := Node (Elmt);
+if not Has_Foreign_Convention (Subp)
+and then not Is_Predefined_Dispatching_Operation (Subp)
+then
+Create_Extra_Formals (Subp);
+end if;
+Next_Elmt (Elmt);
+end loop;
+end;
+end if;
+end Expand_Freeze_Record_Type;
+------------------------------------
+-- Expand_N_Full_Type_Declaration --
+------------------------------------
+procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
+procedure Build_Master (Ptr_Typ : Entity_Id);
+--  Create the master associated with Ptr_Typ
+------------------
+-- Build_Master --
+------------------
+procedure Build_Master (Ptr_Typ : Entity_Id) is
+Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
+begin
+--  If the designated type is an incomplete view coming from a
+--  limited-with'ed package, we need to use the nonlimited view in
+--  case it has tasks.
+if Ekind (Desig_Typ) in Incomplete_Kind
+and then Present (Non_Limited_View (Desig_Typ))
+then
+Desig_Typ := Non_Limited_View (Desig_Typ);
+end if;
+--  Anonymous access types are created for the components of the
+--  record parameter for an entry declaration. No master is created
+--  for such a type.
+if Comes_From_Source (N) and then Has_Task (Desig_Typ) then
+Build_Master_Entity (Ptr_Typ);
+Build_Master_Renaming (Ptr_Typ);
+--  Create a class-wide master because a Master_Id must be generated
+--  for access-to-limited-class-wide types whose root may be extended
+--  with task components.
+--  Note: This code covers access-to-limited-interfaces because they
+--        can be used to reference tasks implementing them.
+elsif Is_Limited_Class_Wide_Type (Desig_Typ)
+and then Tasking_Allowed
+then
+Build_Class_Wide_Master (Ptr_Typ);
+end if;
+end Build_Master;
+--  Local declarations
+Def_Id : constant Entity_Id := Defining_Identifier (N);
+B_Id   : constant Entity_Id := Base_Type (Def_Id);
+FN     : Node_Id;
+Par_Id : Entity_Id;
+--  Start of processing for Expand_N_Full_Type_Declaration
+begin
+if Is_Access_Type (Def_Id) then
+Build_Master (Def_Id);
+if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
+Expand_Access_Protected_Subprogram_Type (N);
+end if;
+--  Array of anonymous access-to-task pointers
+elsif Ada_Version >= Ada_2005
+and then Is_Array_Type (Def_Id)
+and then Is_Access_Type (Component_Type (Def_Id))
+and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
+then
+Build_Master (Component_Type (Def_Id));
+elsif Has_Task (Def_Id) then
+Expand_Previous_Access_Type (Def_Id);
+--  Check the components of a record type or array of records for
+--  anonymous access-to-task pointers.
+elsif Ada_Version >= Ada_2005
+and then (Is_Record_Type (Def_Id)
+or else
+(Is_Array_Type (Def_Id)
+and then Is_Record_Type (Component_Type (Def_Id))))
+then
+declare
+Comp  : Entity_Id;
+First : Boolean;
+M_Id  : Entity_Id;
+Typ   : Entity_Id;
+begin
+if Is_Array_Type (Def_Id) then
+Comp := First_Entity (Component_Type (Def_Id));
+else
+Comp := First_Entity (Def_Id);
+end if;
+--  Examine all components looking for anonymous access-to-task
+--  types.
+First := True;
+while Present (Comp) loop
+Typ := Etype (Comp);
+if Ekind (Typ) = E_Anonymous_Access_Type
+and then Has_Task (Available_View (Designated_Type (Typ)))
+and then No (Master_Id (Typ))
+then
+--  Ensure that the record or array type have a _master
+if First then
+Build_Master_Entity (Def_Id);
+Build_Master_Renaming (Typ);
+M_Id := Master_Id (Typ);
+First := False;
+--  Reuse the same master to service any additional types
+else
+Set_Master_Id (Typ, M_Id);
+end if;
+end if;
+Next_Entity (Comp);
+end loop;
+end;
+end if;
+Par_Id := Etype (B_Id);
+--  The parent type is private then we need to inherit any TSS operations
+--  from the full view.
+if Ekind (Par_Id) in Private_Kind
+and then Present (Full_View (Par_Id))
+then
+Par_Id := Base_Type (Full_View (Par_Id));
+end if;
+if Nkind (Type_Definition (Original_Node (N))) =
+N_Derived_Type_Definition
+and then not Is_Tagged_Type (Def_Id)
+and then Present (Freeze_Node (Par_Id))
+and then Present (TSS_Elist (Freeze_Node (Par_Id)))
+then
+Ensure_Freeze_Node (B_Id);
+FN := Freeze_Node (B_Id);
+if No (TSS_Elist (FN)) then
+Set_TSS_Elist (FN, New_Elmt_List);
+end if;
+declare
+T_E  : constant Elist_Id := TSS_Elist (FN);
+Elmt : Elmt_Id;
+begin
+Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
+while Present (Elmt) loop
+if Chars (Node (Elmt)) /= Name_uInit then
+Append_Elmt (Node (Elmt), T_E);
+end if;
+Next_Elmt (Elmt);
+end loop;
+--  If the derived type itself is private with a full view, then
+--  associate the full view with the inherited TSS_Elist as well.
+if Ekind (B_Id) in Private_Kind
+and then Present (Full_View (B_Id))
+then
+Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
+Set_TSS_Elist
+(Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
+end if;
+end;
+end if;
+end Expand_N_Full_Type_Declaration;
+---------------------------------
+-- Expand_N_Object_Declaration --
+---------------------------------
+procedure Expand_N_Object_Declaration (N : Node_Id) is
+Loc      : constant Source_Ptr := Sloc (N);
+Def_Id   : constant Entity_Id  := Defining_Identifier (N);
+Expr     : constant Node_Id    := Expression (N);
+Obj_Def  : constant Node_Id    := Object_Definition (N);
+Typ      : constant Entity_Id  := Etype (Def_Id);
+Base_Typ : constant Entity_Id  := Base_Type (Typ);
+Expr_Q   : Node_Id;
+function Build_Equivalent_Aggregate return Boolean;
+--  If the object has a constrained discriminated type and no initial
+--  value, it may be possible to build an equivalent aggregate instead,
+--  and prevent an actual call to the initialization procedure.
+procedure Check_Large_Modular_Array;
+--  Check that the size of the array can be computed without overflow,
+--  and generate a Storage_Error otherwise. This is only relevant for
+--  array types whose index in a (mod 2**64) type, where wrap-around
+--  arithmetic might yield a meaningless value for the length of the
+--  array, or its corresponding attribute.
+procedure Count_Default_Sized_Task_Stacks
+(Typ         : Entity_Id;
+Pri_Stacks  : out Int;
+Sec_Stacks  : out Int);
+--  Count the number of default-sized primary and secondary task stacks
+--  required for task objects contained within type Typ. If the number of
+--  task objects contained within the type is not known at compile time
+--  the procedure will return the stack counts of zero.
+procedure Default_Initialize_Object (After : Node_Id);
+--  Generate all default initialization actions for object Def_Id. Any
+--  new code is inserted after node After.
+function Rewrite_As_Renaming return Boolean;
+--  Indicate whether to rewrite a declaration with initialization into an
+--  object renaming declaration (see below).
+--------------------------------
+-- Build_Equivalent_Aggregate --
+--------------------------------
+function Build_Equivalent_Aggregate return Boolean is
+Aggr      : Node_Id;
+Comp      : Entity_Id;
+Discr     : Elmt_Id;
+Full_Type : Entity_Id;
+begin
+Full_Type := Typ;
+if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+Full_Type := Full_View (Typ);
+end if;
+--  Only perform this transformation if Elaboration_Code is forbidden
+--  or undesirable, and if this is a global entity of a constrained
+--  record type.
+--  If Initialize_Scalars might be active this  transformation cannot
+--  be performed either, because it will lead to different semantics
+--  or because elaboration code will in fact be created.
+if Ekind (Full_Type) /= E_Record_Subtype
+or else not Has_Discriminants (Full_Type)
+or else not Is_Constrained (Full_Type)
+or else Is_Controlled (Full_Type)
+or else Is_Limited_Type (Full_Type)
+or else not Restriction_Active (No_Initialize_Scalars)
+then
+return False;
+end if;
+if Ekind (Current_Scope) = E_Package
+and then
+(Restriction_Active (No_Elaboration_Code)
+or else Is_Preelaborated (Current_Scope))
+then
+--  Building a static aggregate is possible if the discriminants
+--  have static values and the other components have static
+--  defaults or none.
+Discr := First_Elmt (Discriminant_Constraint (Full_Type));
+while Present (Discr) loop
+if not Is_OK_Static_Expression (Node (Discr)) then
+return False;
+end if;
+Next_Elmt (Discr);
+end loop;
+--  Check that initialized components are OK, and that non-
+--  initialized components do not require a call to their own
+--  initialization procedure.
+Comp := First_Component (Full_Type);
+while Present (Comp) loop
+if Ekind (Comp) = E_Component
+and then Present (Expression (Parent (Comp)))
+and then
+not Is_OK_Static_Expression (Expression (Parent (Comp)))
+then
+return False;
+elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
+return False;
+end if;
+Next_Component (Comp);
+end loop;
+--  Everything is static, assemble the aggregate, discriminant
+--  values first.
+Aggr :=
+Make_Aggregate (Loc,
+Expressions            => New_List,
+Component_Associations => New_List);
+Discr := First_Elmt (Discriminant_Constraint (Full_Type));
+while Present (Discr) loop
+Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
+Next_Elmt (Discr);
+end loop;
+--  Now collect values of initialized components
+Comp := First_Component (Full_Type);
+while Present (Comp) loop
+if Ekind (Comp) = E_Component
+and then Present (Expression (Parent (Comp)))
+then
+Append_To (Component_Associations (Aggr),
+Make_Component_Association (Loc,
+Choices    => New_List (New_Occurrence_Of (Comp, Loc)),
+Expression => New_Copy_Tree
+(Expression (Parent (Comp)))));
+end if;
+Next_Component (Comp);
+end loop;
+--  Finally, box-initialize remaining components
+Append_To (Component_Associations (Aggr),
+Make_Component_Association (Loc,
+Choices    => New_List (Make_Others_Choice (Loc)),
+Expression => Empty));
+Set_Box_Present (Last (Component_Associations (Aggr)));
+Set_Expression (N, Aggr);
+if Typ /= Full_Type then
+Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
+Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
+Analyze_And_Resolve (Aggr, Typ);
+else
+Analyze_And_Resolve (Aggr, Full_Type);
+end if;
+return True;
+else
+return False;
+end if;
+end Build_Equivalent_Aggregate;
+-------------------------------
+-- Check_Large_Modular_Array --
+-------------------------------
+procedure Check_Large_Modular_Array is
+Index_Typ : Entity_Id;
+begin
+if Is_Array_Type (Typ)
+and then Is_Modular_Integer_Type (Etype (First_Index (Typ)))
+then
+--  To prevent arithmetic overflow with large values, we raise
+--  Storage_Error under the following guard:
+--    (Arr'Last / 2 - Arr'First / 2) > (2 ** 30)
+--  This takes care of the boundary case, but it is preferable to
+--  use a smaller limit, because even on 64-bit architectures an
+--  array of more than 2 ** 30 bytes is likely to raise
+--  Storage_Error.
+Index_Typ := Etype (First_Index (Typ));
+if RM_Size (Index_Typ) = RM_Size (Standard_Long_Long_Integer) then
+Insert_Action (N,
+Make_Raise_Storage_Error (Loc,
+Condition =>
+Make_Op_Ge (Loc,
+Left_Opnd  =>
+Make_Op_Subtract (Loc,
+Left_Opnd  =>
+Make_Op_Divide (Loc,
+Left_Opnd  =>
+Make_Attribute_Reference (Loc,
+Prefix         =>
+New_Occurrence_Of (Typ, Loc),
+Attribute_Name => Name_Last),
+Right_Opnd =>
+Make_Integer_Literal (Loc, Uint_2)),
+Right_Opnd =>
+Make_Op_Divide (Loc,
+Left_Opnd =>
+Make_Attribute_Reference (Loc,
+Prefix         =>
+New_Occurrence_Of (Typ, Loc),
+Attribute_Name => Name_First),
+Right_Opnd =>
+Make_Integer_Literal (Loc, Uint_2))),
+Right_Opnd =>
+Make_Integer_Literal (Loc, (Uint_2 ** 30))),
+Reason    => SE_Object_Too_Large));
+end if;
+end if;
+end Check_Large_Modular_Array;
+-------------------------------------
+-- Count_Default_Sized_Task_Stacks --
+-------------------------------------
+procedure Count_Default_Sized_Task_Stacks
+(Typ         : Entity_Id;
+Pri_Stacks  : out Int;
+Sec_Stacks  : out Int)
+is
+Component : Entity_Id;
+begin
+--  To calculate the number of default-sized task stacks required for
+--  an object of Typ, a depth-first recursive traversal of the AST
+--  from the Typ entity node is undertaken. Only type nodes containing
+--  task objects are visited.
+Pri_Stacks := 0;
+Sec_Stacks := 0;
+if not Has_Task (Typ) then
+return;
+end if;
+case Ekind (Typ) is
+when E_Task_Subtype
+| E_Task_Type
+=>
+--  A task type is found marking the bottom of the descent. If
+--  the type has no representation aspect for the corresponding
+--  stack then that stack is using the default size.
+if Present (Get_Rep_Item (Typ, Name_Storage_Size)) then
+Pri_Stacks := 0;
+else
+Pri_Stacks := 1;
+end if;
+if Present (Get_Rep_Item (Typ, Name_Secondary_Stack_Size)) then
+Sec_Stacks := 0;
+else
+Sec_Stacks := 1;
+end if;
+when E_Array_Subtype
+| E_Array_Type
+=>
+--  First find the number of default stacks contained within an
+--  array component.
+Count_Default_Sized_Task_Stacks
+(Component_Type (Typ),
+Pri_Stacks,
+Sec_Stacks);
+--  Then multiply the result by the size of the array
+declare
+Quantity : constant Int := Number_Of_Elements_In_Array (Typ);
+--  Number_Of_Elements_In_Array is non-trival, consequently
+--  its result is captured as an optimization.
+begin
+Pri_Stacks := Pri_Stacks * Quantity;
+Sec_Stacks := Sec_Stacks * Quantity;
+end;
+when E_Protected_Subtype
+| E_Protected_Type
+| E_Record_Subtype
+| E_Record_Type
+=>
+Component := First_Component_Or_Discriminant (Typ);
+--  Recursively descend each component of the composite type
+--  looking for tasks, but only if the component is marked as
+--  having a task.
+while Present (Component) loop
+if Has_Task (Etype (Component)) then
+declare
+P : Int;
+S : Int;
+begin
+Count_Default_Sized_Task_Stacks
+(Etype (Component), P, S);
+Pri_Stacks := Pri_Stacks + P;
+Sec_Stacks := Sec_Stacks + S;
+end;
+end if;
+Next_Component_Or_Discriminant (Component);
+end loop;
+when E_Limited_Private_Subtype
+| E_Limited_Private_Type
+| E_Record_Subtype_With_Private
+| E_Record_Type_With_Private
+=>
+--  Switch to the full view of the private type to continue
+--  search.
+Count_Default_Sized_Task_Stacks
+(Full_View (Typ), Pri_Stacks, Sec_Stacks);
+--  Other types should not contain tasks
+when others =>
+raise Program_Error;
+end case;
+end Count_Default_Sized_Task_Stacks;
+-------------------------------
+-- Default_Initialize_Object --
+-------------------------------
+procedure Default_Initialize_Object (After : Node_Id) is
+function New_Object_Reference return Node_Id;
+--  Return a new reference to Def_Id with attributes Assignment_OK and
+--  Must_Not_Freeze already set.
+--------------------------
+-- New_Object_Reference --
+--------------------------
+function New_Object_Reference return Node_Id is
+Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
+begin
+--  The call to the type init proc or [Deep_]Finalize must not
+--  freeze the related object as the call is internally generated.
+--  This way legal rep clauses that apply to the object will not be
+--  flagged. Note that the initialization call may be removed if
+--  pragma Import is encountered or moved to the freeze actions of
+--  the object because of an address clause.
+Set_Assignment_OK   (Obj_Ref);
+Set_Must_Not_Freeze (Obj_Ref);
+return Obj_Ref;
+end New_Object_Reference;
+--  Local variables
+Exceptions_OK : constant Boolean :=
+not Restriction_Active (No_Exception_Propagation);
+Aggr_Init  : Node_Id;
+Comp_Init  : List_Id := No_List;
+Fin_Block  : Node_Id;
+Fin_Call   : Node_Id;
+Init_Stmts : List_Id := No_List;
+Obj_Init   : Node_Id := Empty;
+Obj_Ref    : Node_Id;
+--  Start of processing for Default_Initialize_Object
+begin
+--  Default initialization is suppressed for objects that are already
+--  known to be imported (i.e. whose declaration specifies the Import
+--  aspect). Note that for objects with a pragma Import, we generate
+--  initialization here, and then remove it downstream when processing
+--  the pragma. It is also suppressed for variables for which a pragma
+--  Suppress_Initialization has been explicitly given
+if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
+return;
+--  Nothing to do if the object being initialized is of a task type
+--  and restriction No_Tasking is in effect, because this is a direct
+--  violation of the restriction.
+elsif Is_Task_Type (Base_Typ)
+and then Restriction_Active (No_Tasking)
+then
+return;
+end if;
+--  The expansion performed by this routine is as follows:
+--    begin
+--       Abort_Defer;
+--       Type_Init_Proc (Obj);
+--       begin
+--          [Deep_]Initialize (Obj);
+--       exception
+--          when others =>
+--             [Deep_]Finalize (Obj, Self => False);
+--             raise;
+--       end;
+--    at end
+--       Abort_Undefer_Direct;
+--    end;
+--  Initialize the components of the object
+if Has_Non_Null_Base_Init_Proc (Typ)
+and then not No_Initialization (N)
+and then not Initialization_Suppressed (Typ)
+then
+--  Do not initialize the components if No_Default_Initialization
+--  applies as the actual restriction check will occur later
+--  when the object is frozen as it is not known yet whether the
+--  object is imported or not.
+if not Restriction_Active (No_Default_Initialization) then
+--  If the values of the components are compile-time known, use
+--  their prebuilt aggregate form directly.
+Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
+if Present (Aggr_Init) then
+Set_Expression
+(N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
+--  If type has discriminants, try to build an equivalent
+--  aggregate using discriminant values from the declaration.
+--  This is a useful optimization, in particular if restriction
+--  No_Elaboration_Code is active.
+elsif Build_Equivalent_Aggregate then
+null;
+--  Otherwise invoke the type init proc, generate:
+--    Type_Init_Proc (Obj);
+else
+Obj_Ref := New_Object_Reference;
+if Comes_From_Source (Def_Id) then
+Initialization_Warning (Obj_Ref);
+end if;
+Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
+end if;
+end if;
+--  Provide a default value if the object needs simple initialization
+--  and does not already have an initial value. A generated temporary
+--  does not require initialization because it will be assigned later.
+elsif Needs_Simple_Initialization
+(Typ, Initialize_Scalars
+and then No (Following_Address_Clause (N)))
+and then not Is_Internal (Def_Id)
+and then not Has_Init_Expression (N)
+then
+Set_No_Initialization (N, False);
+Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
+Analyze_And_Resolve (Expression (N), Typ);
+end if;
+--  Initialize the object, generate:
+--    [Deep_]Initialize (Obj);
+if Needs_Finalization (Typ) and then not No_Initialization (N) then
+Obj_Init :=
+Make_Init_Call
+(Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
+Typ     => Typ);
+end if;
+--  Build a special finalization block when both the object and its
+--  controlled components are to be initialized. The block finalizes
+--  the components if the object initialization fails. Generate:
+--    begin
+--       <Obj_Init>
+--    exception
+--       when others =>
+--          <Fin_Call>
+--          raise;
+--    end;
+if Has_Controlled_Component (Typ)
+and then Present (Comp_Init)
+and then Present (Obj_Init)
+and then Exceptions_OK
+then
+Init_Stmts := Comp_Init;
+Fin_Call :=
+Make_Final_Call
+(Obj_Ref   => New_Object_Reference,
+Typ       => Typ,
+Skip_Self => True);
+if Present (Fin_Call) then
+Fin_Block :=
+Make_Block_Statement (Loc,
+Declarations               => No_List,
+Handled_Statement_Sequence =>
+Make_Handled_Sequence_Of_Statements (Loc,
+Statements         => New_List (Obj_Init),
+Exception_Handlers => New_List (
+Make_Exception_Handler (Loc,
+Exception_Choices => New_List (
+Make_Others_Choice (Loc)),
+Statements        => New_List (
+Fin_Call,
+Make_Raise_Statement (Loc))))));
+--  Signal the ABE mechanism that the block carries out
+--  initialization actions.
+Set_Is_Initialization_Block (Fin_Block);
+Append_To (Init_Stmts, Fin_Block);
+end if;
+--  Otherwise finalization is not required, the initialization calls
+--  are passed to the abort block building circuitry, generate:
+--    Type_Init_Proc (Obj);
+--    [Deep_]Initialize (Obj);
+else
+if Present (Comp_Init) then
+Init_Stmts := Comp_Init;
+end if;
+if Present (Obj_Init) then
+if No (Init_Stmts) then
+Init_Stmts := New_List;
+end if;
+Append_To (Init_Stmts, Obj_Init);
+end if;
+end if;
+--  Build an abort block to protect the initialization calls
+if Abort_Allowed
+and then Present (Comp_Init)
+and then Present (Obj_Init)
+then
+--  Generate:
+--    Abort_Defer;
+Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+--  When exceptions are propagated, abort deferral must take place
+--  in the presence of initialization or finalization exceptions.
+--  Generate:
+--    begin
+--       Abort_Defer;
+--       <Init_Stmts>
+--    at end
+--       Abort_Undefer_Direct;
+--    end;
+if Exceptions_OK then
+Init_Stmts := New_List (
+Build_Abort_Undefer_Block (Loc,
+Stmts   => Init_Stmts,
+Context => N));
+--  Otherwise exceptions are not propagated. Generate:
+--    Abort_Defer;
+--    <Init_Stmts>
+--    Abort_Undefer;
+else
+Append_To (Init_Stmts,
+Build_Runtime_Call (Loc, RE_Abort_Undefer));
+end if;
+end if;
+--  Insert the whole initialization sequence into the tree. If the
+--  object has a delayed freeze, as will be the case when it has
+--  aspect specifications, the initialization sequence is part of
+--  the freeze actions.
+if Present (Init_Stmts) then
+if Has_Delayed_Freeze (Def_Id) then
+Append_Freeze_Actions (Def_Id, Init_Stmts);
+else
+Insert_Actions_After (After, Init_Stmts);
+end if;
+end if;
+end Default_Initialize_Object;
+-------------------------
+-- Rewrite_As_Renaming --
+-------------------------
+function Rewrite_As_Renaming return Boolean is
+begin
+--  If the object declaration appears in the form
+--    Obj : Ctrl_Typ := Func (...);
+--  where Ctrl_Typ is controlled but not immutably limited type, then
+--  the expansion of the function call should use a dereference of the
+--  result to reference the value on the secondary stack.
+--    Obj : Ctrl_Typ renames Func (...).all;
+--  As a result, the call avoids an extra copy. This an optimization,
+--  but it is required for passing ACATS tests in some cases where it
+--  would otherwise make two copies. The RM allows removing redunant
+--  Adjust/Finalize calls, but does not allow insertion of extra ones.
+--  This part is disabled for now, because it breaks GPS builds
+return (False -- ???
+and then Nkind (Expr_Q) = N_Explicit_Dereference
+and then not Comes_From_Source (Expr_Q)
+and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
+and then Nkind (Object_Definition (N)) in N_Has_Entity
+and then (Needs_Finalization (Entity (Object_Definition (N)))))
+--  If the initializing expression is for a variable with attribute
+--  OK_To_Rename set, then transform:
+--     Obj : Typ := Expr;
+--  into
+--     Obj : Typ renames Expr;
+--  provided that Obj is not aliased. The aliased case has to be
+--  excluded in general because Expr will not be aliased in
+--  general.
+or else
+(not Aliased_Present (N)
+and then Is_Entity_Name (Expr_Q)
+and then Ekind (Entity (Expr_Q)) = E_Variable
+and then OK_To_Rename (Entity (Expr_Q))
+and then Is_Entity_Name (Obj_Def));
+end Rewrite_As_Renaming;
+--  Local variables
+Next_N : constant Node_Id := Next (N);
+Adj_Call   : Node_Id;
+Id_Ref     : Node_Id;
+Tag_Assign : Node_Id;
+Init_After : Node_Id := N;
+--  Node after which the initialization actions are to be inserted. This
+--  is normally N, except for the case of a shared passive variable, in
+--  which case the init proc call must be inserted only after the bodies
+--  of the shared variable procedures have been seen.
+--  Start of processing for Expand_N_Object_Declaration
+begin
+--  Don't do anything for deferred constants. All proper actions will be
+--  expanded during the full declaration.
+if No (Expr) and Constant_Present (N) then
+return;
+end if;
+--  The type of the object cannot be abstract. This is diagnosed at the
+--  point the object is frozen, which happens after the declaration is
+--  fully expanded, so simply return now.
+if Is_Abstract_Type (Typ) then
+return;
+end if;
+--  No action needed for the internal imported dummy object added by
+--  Make_DT to compute the offset of the components that reference
+--  secondary dispatch tables; required to avoid never-ending loop
+--  processing this internal object declaration.
+if Tagged_Type_Expansion
+and then Is_Internal (Def_Id)
+and then Is_Imported (Def_Id)
+and then Related_Type (Def_Id) = Implementation_Base_Type (Typ)
+then
+return;
+end if;
+--  First we do special processing for objects of a tagged type where
+--  this is the point at which the type is frozen. The creation of the
+--  dispatch table and the initialization procedure have to be deferred
+--  to this point, since we reference previously declared primitive
+--  subprograms.
+--  Force construction of dispatch tables of library level tagged types
+if Tagged_Type_Expansion
+and then Static_Dispatch_Tables
+and then Is_Library_Level_Entity (Def_Id)
+and then Is_Library_Level_Tagged_Type (Base_Typ)
+and then Ekind_In (Base_Typ, E_Record_Type,
+E_Protected_Type,
+E_Task_Type)
+and then not Has_Dispatch_Table (Base_Typ)
+then
+declare
+New_Nodes : List_Id := No_List;
+begin
+if Is_Concurrent_Type (Base_Typ) then
+New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
+else
+New_Nodes := Make_DT (Base_Typ, N);
+end if;
+if not Is_Empty_List (New_Nodes) then
+Insert_List_Before (N, New_Nodes);
+end if;
+end;
+end if;
+--  Make shared memory routines for shared passive variable
+if Is_Shared_Passive (Def_Id) then
+Init_After := Make_Shared_Var_Procs (N);
+end if;
+--  If tasks being declared, make sure we have an activation chain
+--  defined for the tasks (has no effect if we already have one), and
+--  also that a Master variable is established and that the appropriate
+--  enclosing construct is established as a task master.
+if Has_Task (Typ) then
+Build_Activation_Chain_Entity (N);
+Build_Master_Entity (Def_Id);
+end if;
+Check_Large_Modular_Array;
+--  If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
+--  restrictions are active then default-sized secondary stacks are
+--  generated by the binder and allocated by SS_Init. To provide the
+--  binder the number of stacks to generate, the number of default-sized
+--  stacks required for task objects contained within the object
+--  declaration N is calculated here as it is at this point where
+--  unconstrained types become constrained. The result is stored in the
+--  enclosing unit's Unit_Record.
+--  Note if N is an array object declaration that has an initialization
+--  expression, a second object declaration for the initialization
+--  expression is created by the compiler. To prevent double counting
+--  of the stacks in this scenario, the stacks of the first array are
+--  not counted.
+if Has_Task (Typ)
+and then not Restriction_Active (No_Secondary_Stack)
+and then (Restriction_Active (No_Implicit_Heap_Allocations)
+or else Restriction_Active (No_Implicit_Task_Allocations))
+and then not (Ekind_In (Ekind (Typ), E_Array_Type, E_Array_Subtype)
+and then (Has_Init_Expression (N)))
+then
+declare
+PS_Count, SS_Count : Int := 0;
+begin
+Count_Default_Sized_Task_Stacks (Typ, PS_Count, SS_Count);
+Increment_Primary_Stack_Count (PS_Count);
+Increment_Sec_Stack_Count (SS_Count);
+end;
+end if;
+--  Default initialization required, and no expression present
+if No (Expr) then
+--  If we have a type with a variant part, the initialization proc
+--  will contain implicit tests of the discriminant values, which
+--  counts as a violation of the restriction No_Implicit_Conditionals.
+if Has_Variant_Part (Typ) then
+declare
+Msg : Boolean;
+begin
+Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
+if Msg then
+Error_Msg_N
+("\initialization of variant record tests discriminants",
+Obj_Def);
+return;
+end if;
+end;
+end if;
+--  For the default initialization case, if we have a private type
+--  with invariants, and invariant checks are enabled, then insert an
+--  invariant check after the object declaration. Note that it is OK
+--  to clobber the object with an invalid value since if the exception
+--  is raised, then the object will go out of scope. In the case where
+--  an array object is initialized with an aggregate, the expression
+--  is removed. Check flag Has_Init_Expression to avoid generating a
+--  junk invariant check and flag No_Initialization to avoid checking
+--  an uninitialized object such as a compiler temporary used for an
+--  aggregate.
+if Has_Invariants (Base_Typ)
+and then Present (Invariant_Procedure (Base_Typ))
+and then not Has_Init_Expression (N)
+and then not No_Initialization (N)
+then
+--  If entity has an address clause or aspect, make invariant
+--  call into a freeze action for the explicit freeze node for
+--  object. Otherwise insert invariant check after declaration.
+if Present (Following_Address_Clause (N))
+or else Has_Aspect (Def_Id, Aspect_Address)
+then
+Ensure_Freeze_Node (Def_Id);
+Set_Has_Delayed_Freeze (Def_Id);
+Set_Is_Frozen (Def_Id, False);
+if not Partial_View_Has_Unknown_Discr (Typ) then
+Append_Freeze_Action (Def_Id,
+Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
+end if;
+elsif not Partial_View_Has_Unknown_Discr (Typ) then
+Insert_After (N,
+Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
+end if;
+end if;
+Default_Initialize_Object (Init_After);
+--  Generate attribute for Persistent_BSS if needed
+if Persistent_BSS_Mode
+and then Comes_From_Source (N)
+and then Is_Potentially_Persistent_Type (Typ)
+and then not Has_Init_Expression (N)
+and then Is_Library_Level_Entity (Def_Id)
+then
+declare
+Prag : Node_Id;
+begin
+Prag :=
+Make_Linker_Section_Pragma
+(Def_Id, Sloc (N), ".persistent.bss");
+Insert_After (N, Prag);
+Analyze (Prag);
+end;
+end if;
+--  If access type, then we know it is null if not initialized
+if Is_Access_Type (Typ) then
+Set_Is_Known_Null (Def_Id);
+end if;
+--  Explicit initialization present
+else
+--  Obtain actual expression from qualified expression
+if Nkind (Expr) = N_Qualified_Expression then
+Expr_Q := Expression (Expr);
+else
+Expr_Q := Expr;
+end if;
+--  When we have the appropriate type of aggregate in the expression
+--  (it has been determined during analysis of the aggregate by
+--  setting the delay flag), let's perform in place assignment and
+--  thus avoid creating a temporary.
+if Is_Delayed_Aggregate (Expr_Q) then
+Convert_Aggr_In_Object_Decl (N);
+--  Ada 2005 (AI-318-02): If the initialization expression is a call
+--  to a build-in-place function, then access to the declared object
+--  must be passed to the function. Currently we limit such functions
+--  to those with constrained limited result subtypes, but eventually
+--  plan to expand the allowed forms of functions that are treated as
+--  build-in-place.
+elsif Is_Build_In_Place_Function_Call (Expr_Q) then
+Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
+--  The previous call expands the expression initializing the
+--  built-in-place object into further code that will be analyzed
+--  later. No further expansion needed here.
+return;
+--  This is the same as the previous 'elsif', except that the call has
+--  been transformed by other expansion activities into something like
+--  F(...)'Reference.
+elsif Nkind (Expr_Q) = N_Reference
+and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q))
+and then not Is_Expanded_Build_In_Place_Call
+(Unqual_Conv (Prefix (Expr_Q)))
+then
+Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q));
+--  The previous call expands the expression initializing the
+--  built-in-place object into further code that will be analyzed
+--  later. No further expansion needed here.
+return;
+--  Ada 2005 (AI-318-02): Specialization of the previous case for
+--  expressions containing a build-in-place function call whose
+--  returned object covers interface types, and Expr_Q has calls to
+--  Ada.Tags.Displace to displace the pointer to the returned build-
+--  in-place object to reference the secondary dispatch table of a
+--  covered interface type.
+elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then
+Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q);
+--  The previous call expands the expression initializing the
+--  built-in-place object into further code that will be analyzed
+--  later. No further expansion needed here.
+return;
+--  Ada 2005 (AI-251): Rewrite the expression that initializes a
+--  class-wide interface object to ensure that we copy the full
+--  object, unless we are targetting a VM where interfaces are handled
+--  by VM itself. Note that if the root type of Typ is an ancestor of
+--  Expr's type, both types share the same dispatch table and there is
+--  no need to displace the pointer.
+elsif Is_Interface (Typ)
+--  Avoid never-ending recursion because if Equivalent_Type is set
+--  then we've done it already and must not do it again.
+and then not
+(Nkind (Obj_Def) = N_Identifier
+and then Present (Equivalent_Type (Entity (Obj_Def))))
+then
+pragma Assert (Is_Class_Wide_Type (Typ));
+--  If the object is a return object of an inherently limited type,
+--  which implies build-in-place treatment, bypass the special
+--  treatment of class-wide interface initialization below. In this
+--  case, the expansion of the return statement will take care of
+--  creating the object (via allocator) and initializing it.
+if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
+null;
+elsif Tagged_Type_Expansion then
+declare
+Iface    : constant Entity_Id := Root_Type (Typ);
+Expr_N   : Node_Id := Expr;
+Expr_Typ : Entity_Id;
+New_Expr : Node_Id;
+Obj_Id   : Entity_Id;
+Tag_Comp : Node_Id;
+begin
+--  If the original node of the expression was a conversion
+--  to this specific class-wide interface type then restore
+--  the original node because we must copy the object before
+--  displacing the pointer to reference the secondary tag
+--  component. This code must be kept synchronized with the
+--  expansion done by routine Expand_Interface_Conversion
+if not Comes_From_Source (Expr_N)
+and then Nkind (Expr_N) = N_Explicit_Dereference
+and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
+and then Etype (Original_Node (Expr_N)) = Typ
+then
+Rewrite (Expr_N, Original_Node (Expression (N)));
+end if;
+--  Avoid expansion of redundant interface conversion
+if Is_Interface (Etype (Expr_N))
+and then Nkind (Expr_N) = N_Type_Conversion
+and then Etype (Expr_N) = Typ
+then
+Expr_N := Expression (Expr_N);
+Set_Expression (N, Expr_N);
+end if;
+Obj_Id   := Make_Temporary (Loc, 'D', Expr_N);
+Expr_Typ := Base_Type (Etype (Expr_N));
+if Is_Class_Wide_Type (Expr_Typ) then
+Expr_Typ := Root_Type (Expr_Typ);
+end if;
+--  Replace
+--     CW : I'Class := Obj;
+--  by
+--     Tmp : T := Obj;
+--     type Ityp is not null access I'Class;
+--     CW  : I'Class renames Ityp (Tmp.I_Tag'Address).all;
+if Comes_From_Source (Expr_N)
+and then Nkind (Expr_N) = N_Identifier
+and then not Is_Interface (Expr_Typ)
+and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
+and then (Expr_Typ = Etype (Expr_Typ)
+or else not
+Is_Variable_Size_Record (Etype (Expr_Typ)))
+then
+--  Copy the object
+Insert_Action (N,
+Make_Object_Declaration (Loc,
+Defining_Identifier => Obj_Id,
+Object_Definition   =>
+New_Occurrence_Of (Expr_Typ, Loc),
+Expression          => Relocate_Node (Expr_N)));
+--  Statically reference the tag associated with the
+--  interface
+Tag_Comp :=
+Make_Selected_Component (Loc,
+Prefix        => New_Occurrence_Of (Obj_Id, Loc),
+Selector_Name =>
+New_Occurrence_Of
+(Find_Interface_Tag (Expr_Typ, Iface), Loc));
+--  Replace
+--     IW : I'Class := Obj;
+--  by
+--     type Equiv_Record is record ... end record;
+--     implicit subtype CW is <Class_Wide_Subtype>;
+--     Tmp : CW := CW!(Obj);
+--     type Ityp is not null access I'Class;
+--     IW : I'Class renames
+--            Ityp!(Displace (Temp'Address, I'Tag)).all;
+else
+--  Generate the equivalent record type and update the
+--  subtype indication to reference it.
+Expand_Subtype_From_Expr
+(N             => N,
+Unc_Type      => Typ,
+Subtype_Indic => Obj_Def,
+Exp           => Expr_N);
+if not Is_Interface (Etype (Expr_N)) then
+New_Expr := Relocate_Node (Expr_N);
+--  For interface types we use 'Address which displaces
+--  the pointer to the base of the object (if required)
+else
+New_Expr :=
+Unchecked_Convert_To (Etype (Obj_Def),
+Make_Explicit_Dereference (Loc,
+Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+Make_Attribute_Reference (Loc,
+Prefix => Relocate_Node (Expr_N),
+Attribute_Name => Name_Address))));
+end if;
+--  Copy the object
+if not Is_Limited_Record (Expr_Typ) then
+Insert_Action (N,
+Make_Object_Declaration (Loc,
+Defining_Identifier => Obj_Id,
+Object_Definition   =>
+New_Occurrence_Of (Etype (Obj_Def), Loc),
+Expression => New_Expr));
+--  Rename limited type object since they cannot be copied
+--  This case occurs when the initialization expression
+--  has been previously expanded into a temporary object.
+else pragma Assert (not Comes_From_Source (Expr_Q));
+Insert_Action (N,
+Make_Object_Renaming_Declaration (Loc,
+Defining_Identifier => Obj_Id,
+Subtype_Mark        =>
+New_Occurrence_Of (Etype (Obj_Def), Loc),
+Name                =>
+Unchecked_Convert_To
+(Etype (Obj_Def), New_Expr)));
+end if;
+--  Dynamically reference the tag associated with the
+--  interface.
+Tag_Comp :=
+Make_Function_Call (Loc,
+Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
+Parameter_Associations => New_List (
+Make_Attribute_Reference (Loc,
+Prefix => New_Occurrence_Of (Obj_Id, Loc),
+Attribute_Name => Name_Address),
+New_Occurrence_Of
+(Node (First_Elmt (Access_Disp_Table (Iface))),
+Loc)));
+end if;
+Rewrite (N,
+Make_Object_Renaming_Declaration (Loc,
+Defining_Identifier => Make_Temporary (Loc, 'D'),
+Subtype_Mark        => New_Occurrence_Of (Typ, Loc),
+Name                =>
+Convert_Tag_To_Interface (Typ, Tag_Comp)));
+--  If the original entity comes from source, then mark the
+--  new entity as needing debug information, even though it's
+--  defined by a generated renaming that does not come from
+--  source, so that Materialize_Entity will be set on the
+--  entity when Debug_Renaming_Declaration is called during
+--  analysis.
+if Comes_From_Source (Def_Id) then
+Set_Debug_Info_Needed (Defining_Identifier (N));
+end if;
+Analyze (N, Suppress => All_Checks);
+--  Replace internal identifier of rewritten node by the
+--  identifier found in the sources. We also have to exchange
+--  entities containing their defining identifiers to ensure
+--  the correct replacement of the object declaration by this
+--  object renaming declaration because these identifiers
+--  were previously added by Enter_Name to the current scope.
+--  We must preserve the homonym chain of the source entity
+--  as well. We must also preserve the kind of the entity,
+--  which may be a constant. Preserve entity chain because
+--  itypes may have been generated already, and the full
+--  chain must be preserved for final freezing. Finally,
+--  preserve Comes_From_Source setting, so that debugging
+--  and cross-referencing information is properly kept, and
+--  preserve source location, to prevent spurious errors when
+--  entities are declared (they must have their own Sloc).
+declare
+New_Id    : constant Entity_Id := Defining_Identifier (N);
+Next_Temp : constant Entity_Id := Next_Entity (New_Id);
+S_Flag    : constant Boolean   :=
+Comes_From_Source (Def_Id);
+begin
+Set_Next_Entity (New_Id, Next_Entity (Def_Id));
+Set_Next_Entity (Def_Id, Next_Temp);
+Set_Chars   (Defining_Identifier (N), Chars   (Def_Id));
+Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
+Set_Ekind   (Defining_Identifier (N), Ekind   (Def_Id));
+Set_Sloc    (Defining_Identifier (N), Sloc    (Def_Id));
+Set_Comes_From_Source (Def_Id, False);
+Exchange_Entities (Defining_Identifier (N), Def_Id);
+Set_Comes_From_Source (Def_Id, S_Flag);
+end;
+end;
+end if;
+return;
+--  Common case of explicit object initialization
+else
+--  In most cases, we must check that the initial value meets any
+--  constraint imposed by the declared type. However, there is one
+--  very important exception to this rule. If the entity has an
+--  unconstrained nominal subtype, then it acquired its constraints
+--  from the expression in the first place, and not only does this
+--  mean that the constraint check is not needed, but an attempt to
+--  perform the constraint check can cause order of elaboration
+--  problems.
+if not Is_Constr_Subt_For_U_Nominal (Typ) then
+--  If this is an allocator for an aggregate that has been
+--  allocated in place, delay checks until assignments are
+--  made, because the discriminants are not initialized.
+if Nkind (Expr) = N_Allocator
+and then No_Initialization (Expr)
+then
+null;
+--  Otherwise apply a constraint check now if no prev error
+elsif Nkind (Expr) /= N_Error then
+Apply_Constraint_Check (Expr, Typ);
+--  Deal with possible range check
+if Do_Range_Check (Expr) then
+--  If assignment checks are suppressed, turn off flag
+if Suppress_Assignment_Checks (N) then
+Set_Do_Range_Check (Expr, False);
+--  Otherwise generate the range check
+else
+Generate_Range_Check
+(Expr, Typ, CE_Range_Check_Failed);
+end if;
+end if;
+end if;
+end if;
+--  If the type is controlled and not inherently limited, then
+--  the target is adjusted after the copy and attached to the
+--  finalization list. However, no adjustment is done in the case
+--  where the object was initialized by a call to a function whose
+--  result is built in place, since no copy occurred. Similarly, no
+--  adjustment is required if we are going to rewrite the object
+--  declaration into a renaming declaration.
+if Needs_Finalization (Typ)
+and then not Is_Limited_View (Typ)
+and then not Rewrite_As_Renaming
+then
+Adj_Call :=
+Make_Adjust_Call (
+Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
+Typ     => Base_Typ);
+--  Guard against a missing [Deep_]Adjust when the base type
+--  was not properly frozen.
+if Present (Adj_Call) then
+Insert_Action_After (Init_After, Adj_Call);
+end if;
+end if;
+--  For tagged types, when an init value is given, the tag has to
+--  be re-initialized separately in order to avoid the propagation
+--  of a wrong tag coming from a view conversion unless the type
+--  is class wide (in this case the tag comes from the init value).
+--  Suppress the tag assignment when not Tagged_Type_Expansion
+--  because tags are represented implicitly in objects. Ditto for
+--  types that are CPP_CLASS, and for initializations that are
+--  aggregates, because they have to have the right tag.
+--  The re-assignment of the tag has to be done even if the object
+--  is a constant. The assignment must be analyzed after the
+--  declaration. If an address clause follows, this is handled as
+--  part of the freeze actions for the object, otherwise insert
+--  tag assignment here.
+Tag_Assign := Make_Tag_Assignment (N);
+if Present (Tag_Assign) then
+if Present (Following_Address_Clause (N)) then
+Ensure_Freeze_Node (Def_Id);
+else
+Insert_Action_After (Init_After, Tag_Assign);
+end if;
+--  Handle C++ constructor calls. Note that we do not check that
+--  Typ is a tagged type since the equivalent Ada type of a C++
+--  class that has no virtual methods is an untagged limited
+--  record type.
+elsif Is_CPP_Constructor_Call (Expr) then
+--  The call to the initialization procedure does NOT freeze the
+--  object being initialized.
+Id_Ref := New_Occurrence_Of (Def_Id, Loc);
+Set_Must_Not_Freeze (Id_Ref);
+Set_Assignment_OK (Id_Ref);
+Insert_Actions_After (Init_After,
+Build_Initialization_Call (Loc, Id_Ref, Typ,
+Constructor_Ref => Expr));
+--  We remove here the original call to the constructor
+--  to avoid its management in the backend
+Set_Expression (N, Empty);
+return;
+--  Handle initialization of limited tagged types
+elsif Is_Tagged_Type (Typ)
+and then Is_Class_Wide_Type (Typ)
+and then Is_Limited_Record (Typ)
+and then not Is_Limited_Interface (Typ)
+then
+--  Given that the type is limited we cannot perform a copy. If
+--  Expr_Q is the reference to a variable we mark the variable
+--  as OK_To_Rename to expand this declaration into a renaming
+--  declaration (see bellow).
+if Is_Entity_Name (Expr_Q) then
+Set_OK_To_Rename (Entity (Expr_Q));
+--  If we cannot convert the expression into a renaming we must
+--  consider it an internal error because the backend does not
+--  have support to handle it.
+else
+pragma Assert (False);
+raise Program_Error;
+end if;
+--  For discrete types, set the Is_Known_Valid flag if the
+--  initializing value is known to be valid. Only do this for
+--  source assignments, since otherwise we can end up turning
+--  on the known valid flag prematurely from inserted code.
+elsif Comes_From_Source (N)
+and then Is_Discrete_Type (Typ)
+and then Expr_Known_Valid (Expr)
+then
+Set_Is_Known_Valid (Def_Id);
+elsif Is_Access_Type (Typ) then
+--  For access types set the Is_Known_Non_Null flag if the
+--  initializing value is known to be non-null. We can also set
+--  Can_Never_Be_Null if this is a constant.
+if Known_Non_Null (Expr) then
+Set_Is_Known_Non_Null (Def_Id, True);
+if Constant_Present (N) then
+Set_Can_Never_Be_Null (Def_Id);
+end if;
+end if;
+end if;
+--  If validity checking on copies, validate initial expression.
+--  But skip this if declaration is for a generic type, since it
+--  makes no sense to validate generic types. Not clear if this
+--  can happen for legal programs, but it definitely can arise
+--  from previous instantiation errors.
+if Validity_Checks_On
+and then Comes_From_Source (N)
+and then Validity_Check_Copies
+and then not Is_Generic_Type (Etype (Def_Id))
+then
+Ensure_Valid (Expr);
+Set_Is_Known_Valid (Def_Id);
+end if;
+end if;
+--  Cases where the back end cannot handle the initialization
+--  directly. In such cases, we expand an assignment that will
+--  be appropriately handled by Expand_N_Assignment_Statement.
+--  The exclusion of the unconstrained case is wrong, but for now it
+--  is too much trouble ???
+if (Is_Possibly_Unaligned_Slice (Expr)
+or else (Is_Possibly_Unaligned_Object (Expr)
+and then not Represented_As_Scalar (Etype (Expr))))
+and then not (Is_Array_Type (Etype (Expr))
+and then not Is_Constrained (Etype (Expr)))
+then
+declare
+Stat : constant Node_Id :=
+Make_Assignment_Statement (Loc,
+Name       => New_Occurrence_Of (Def_Id, Loc),
+Expression => Relocate_Node (Expr));
+begin
+Set_Expression (N, Empty);
+Set_No_Initialization (N);
+Set_Assignment_OK (Name (Stat));
+Set_No_Ctrl_Actions (Stat);
+Insert_After_And_Analyze (Init_After, Stat);
+end;
+end if;
+end if;
+if Nkind (Obj_Def) = N_Access_Definition
+and then not Is_Local_Anonymous_Access (Etype (Def_Id))
+then
+--  An Ada 2012 stand-alone object of an anonymous access type
+declare
+Loc : constant Source_Ptr := Sloc (N);
+Level : constant Entity_Id :=
+Make_Defining_Identifier (Sloc (N),
+Chars =>
+New_External_Name (Chars (Def_Id), Suffix => "L"));
+Level_Expr : Node_Id;
+Level_Decl : Node_Id;
+begin
+Set_Ekind (Level, Ekind (Def_Id));
+Set_Etype (Level, Standard_Natural);
+Set_Scope (Level, Scope (Def_Id));
+if No (Expr) then
+--  Set accessibility level of null
+Level_Expr :=
+Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
+else
+Level_Expr := Dynamic_Accessibility_Level (Expr);
+end if;
+Level_Decl :=
+Make_Object_Declaration (Loc,
+Defining_Identifier => Level,
+Object_Definition   =>
+New_Occurrence_Of (Standard_Natural, Loc),
+Expression          => Level_Expr,
+Constant_Present    => Constant_Present (N),
+Has_Init_Expression => True);
+Insert_Action_After (Init_After, Level_Decl);
+Set_Extra_Accessibility (Def_Id, Level);
+end;
+end if;
+--  If the object is default initialized and its type is subject to
+--  pragma Default_Initial_Condition, add a runtime check to verify
+--  the assumption of the pragma (SPARK RM 7.3.3). Generate:
+--    <Base_Typ>DIC (<Base_Typ> (Def_Id));
+--  Note that the check is generated for source objects only
+if Comes_From_Source (Def_Id)
+and then Has_DIC (Typ)
+and then Present (DIC_Procedure (Typ))
+and then not Has_Init_Expression (N)
+then
+declare
+DIC_Call : constant Node_Id := Build_DIC_Call (Loc, Def_Id, Typ);
+begin
+if Present (Next_N) then
+Insert_Before_And_Analyze (Next_N, DIC_Call);
+--  The object declaration is the last node in a declarative or a
+--  statement list.
+else
+Append_To (List_Containing (N), DIC_Call);
+Analyze (DIC_Call);
+end if;
+end;
+end if;
+--  Final transformation - turn the object declaration into a renaming
+--  if appropriate. If this is the completion of a deferred constant
+--  declaration, then this transformation generates what would be
+--  illegal code if written by hand, but that's OK.
+if Present (Expr) then
+if Rewrite_As_Renaming then
+Rewrite (N,
+Make_Object_Renaming_Declaration (Loc,
+Defining_Identifier => Defining_Identifier (N),
+Subtype_Mark        => Obj_Def,
+Name                => Expr_Q));
+--  We do not analyze this renaming declaration, because all its
+--  components have already been analyzed, and if we were to go
+--  ahead and analyze it, we would in effect be trying to generate
+--  another declaration of X, which won't do.
+Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
+Set_Analyzed (N);
+--  We do need to deal with debug issues for this renaming
+--  First, if entity comes from source, then mark it as needing
+--  debug information, even though it is defined by a generated
+--  renaming that does not come from source.
+if Comes_From_Source (Defining_Identifier (N)) then
+Set_Debug_Info_Needed (Defining_Identifier (N));
+end if;
+--  Now call the routine to generate debug info for the renaming
+declare
+Decl : constant Node_Id := Debug_Renaming_Declaration (N);
+begin
+if Present (Decl) then
+Insert_Action (N, Decl);
+end if;
+end;
+end if;
+end if;
+--  Exception on library entity not available
+exception
+when RE_Not_Available =>
+return;
+end Expand_N_Object_Declaration;
+---------------------------------
+-- Expand_N_Subtype_Indication --
+---------------------------------
+--  Add a check on the range of the subtype. The static case is partially
+--  duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
+--  to check here for the static case in order to avoid generating
+--  extraneous expanded code. Also deal with validity checking.
+procedure Expand_N_Subtype_Indication (N : Node_Id) is
+Ran : constant Node_Id   := Range_Expression (Constraint (N));
+Typ : constant Entity_Id := Entity (Subtype_Mark (N));
+begin
+if Nkind (Constraint (N)) = N_Range_Constraint then
+Validity_Check_Range (Range_Expression (Constraint (N)));
+end if;
+if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
+Apply_Range_Check (Ran, Typ);
+end if;
+end Expand_N_Subtype_Indication;
+---------------------------
+-- Expand_N_Variant_Part --
+---------------------------
+--  Note: this procedure no longer has any effect. It used to be that we
+--  would replace the choices in the last variant by a when others, and
+--  also expanded static predicates in variant choices here, but both of
+--  those activities were being done too early, since we can't check the
+--  choices until the statically predicated subtypes are frozen, which can
+--  happen as late as the free point of the record, and we can't change the
+--  last choice to an others before checking the choices, which is now done
+--  at the freeze point of the record.
+procedure Expand_N_Variant_Part (N : Node_Id) is
+begin
+null;
+end Expand_N_Variant_Part;
+---------------------------------
+-- Expand_Previous_Access_Type --
+---------------------------------
+procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
+Ptr_Typ : Entity_Id;
+begin
+--  Find all access types in the current scope whose designated type is
+--  Def_Id and build master renamings for them.
+Ptr_Typ := First_Entity (Current_Scope);
+while Present (Ptr_Typ) loop
+if Is_Access_Type (Ptr_Typ)
+and then Designated_Type (Ptr_Typ) = Def_Id
+and then No (Master_Id (Ptr_Typ))
+then
+--  Ensure that the designated type has a master
+Build_Master_Entity (Def_Id);
+--  Private and incomplete types complicate the insertion of master
+--  renamings because the access type may precede the full view of
+--  the designated type. For this reason, the master renamings are
+--  inserted relative to the designated type.
+Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
+end if;
+Next_Entity (Ptr_Typ);
+end loop;
+end Expand_Previous_Access_Type;
+-----------------------------
+-- Expand_Record_Extension --
+-----------------------------
+--  Add a field _parent at the beginning of the record extension. This is
+--  used to implement inheritance. Here are some examples of expansion:
+--  1. no discriminants
+--      type T2 is new T1 with null record;
+--   gives
+--      type T2 is new T1 with record
+--        _Parent : T1;
+--      end record;
+--  2. renamed discriminants
+--    type T2 (B, C : Int) is new T1 (A => B) with record
+--       _Parent : T1 (A => B);
+--       D : Int;
+--    end;
+--  3. inherited discriminants
+--    type T2 is new T1 with record -- discriminant A inherited
+--       _Parent : T1 (A);
+--       D : Int;
+--    end;
+procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
+Indic        : constant Node_Id    := Subtype_Indication (Def);
+Loc          : constant Source_Ptr := Sloc (Def);
+Rec_Ext_Part : Node_Id             := Record_Extension_Part (Def);
+Par_Subtype  : Entity_Id;
+Comp_List    : Node_Id;
+Comp_Decl    : Node_Id;
+Parent_N     : Node_Id;
+D            : Entity_Id;
+List_Constr  : constant List_Id    := New_List;
+begin
+--  Expand_Record_Extension is called directly from the semantics, so
+--  we must check to see whether expansion is active before proceeding,
+--  because this affects the visibility of selected components in bodies
+--  of instances.
+if not Expander_Active then
+return;
+end if;
+--  This may be a derivation of an untagged private type whose full
+--  view is tagged, in which case the Derived_Type_Definition has no
+--  extension part. Build an empty one now.
+if No (Rec_Ext_Part) then
+Rec_Ext_Part :=
+Make_Record_Definition (Loc,
+End_Label      => Empty,
+Component_List => Empty,
+Null_Present   => True);
+Set_Record_Extension_Part (Def, Rec_Ext_Part);
+Mark_Rewrite_Insertion (Rec_Ext_Part);
+end if;
+Comp_List := Component_List (Rec_Ext_Part);
+Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
+--  If the derived type inherits its discriminants the type of the
+--  _parent field must be constrained by the inherited discriminants
+if Has_Discriminants (T)
+and then Nkind (Indic) /= N_Subtype_Indication
+and then not Is_Constrained (Entity (Indic))
+then
+D := First_Discriminant (T);
+while Present (D) loop
+Append_To (List_Constr, New_Occurrence_Of (D, Loc));
+Next_Discriminant (D);
+end loop;
+Par_Subtype :=
+Process_Subtype (
+Make_Subtype_Indication (Loc,
+Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
+Constraint   =>
+Make_Index_Or_Discriminant_Constraint (Loc,
+Constraints => List_Constr)),
+Def);
+--  Otherwise the original subtype_indication is just what is needed
+else
+Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
+end if;
+Set_Parent_Subtype (T, Par_Subtype);
+Comp_Decl :=
+Make_Component_Declaration (Loc,
+Defining_Identifier => Parent_N,
+Component_Definition =>
+Make_Component_Definition (Loc,
+Aliased_Present => False,
+Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
+if Null_Present (Rec_Ext_Part) then
+Set_Component_List (Rec_Ext_Part,
+Make_Component_List (Loc,
+Component_Items => New_List (Comp_Decl),
+Variant_Part => Empty,
+Null_Present => False));
+Set_Null_Present (Rec_Ext_Part, False);
+elsif Null_Present (Comp_List)
+or else Is_Empty_List (Component_Items (Comp_List))
+then
+Set_Component_Items (Comp_List, New_List (Comp_Decl));
+Set_Null_Present (Comp_List, False);
+else
+Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
+end if;
+Analyze (Comp_Decl);
+end Expand_Record_Extension;
+------------------------
+-- Expand_Tagged_Root --
+------------------------
+procedure Expand_Tagged_Root (T : Entity_Id) is
+Def       : constant Node_Id := Type_Definition (Parent (T));
+Comp_List : Node_Id;
+Comp_Decl : Node_Id;
+Sloc_N    : Source_Ptr;
+begin
+if Null_Present (Def) then
+Set_Component_List (Def,
+Make_Component_List (Sloc (Def),
+Component_Items => Empty_List,
+Variant_Part => Empty,
+Null_Present => True));
+end if;
+Comp_List := Component_List (Def);
+if Null_Present (Comp_List)
+or else Is_Empty_List (Component_Items (Comp_List))
+then
+Sloc_N := Sloc (Comp_List);
+else
+Sloc_N := Sloc (First (Component_Items (Comp_List)));
+end if;
+Comp_Decl :=
+Make_Component_Declaration (Sloc_N,
+Defining_Identifier => First_Tag_Component (T),
+Component_Definition =>
+Make_Component_Definition (Sloc_N,
+Aliased_Present => False,
+Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
+if Null_Present (Comp_List)
+or else Is_Empty_List (Component_Items (Comp_List))
+then
+Set_Component_Items (Comp_List, New_List (Comp_Decl));
+Set_Null_Present (Comp_List, False);
+else
+Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
+end if;
+--  We don't Analyze the whole expansion because the tag component has
+--  already been analyzed previously. Here we just insure that the tree
+--  is coherent with the semantic decoration
+Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
+exception
+when RE_Not_Available =>
+return;
+end Expand_Tagged_Root;
+------------------------------
+-- Freeze_Stream_Operations --
+------------------------------
+procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
+Names     : constant array (1 .. 4) of TSS_Name_Type :=
+(TSS_Stream_Input,
+TSS_Stream_Output,
+TSS_Stream_Read,
+TSS_Stream_Write);
+Stream_Op : Entity_Id;
+begin
+--  Primitive operations of tagged types are frozen when the dispatch
+--  table is constructed.
+if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then
+return;
+end if;
+for J in Names'Range loop
+Stream_Op := TSS (Typ, Names (J));
+if Present (Stream_Op)
+and then Is_Subprogram (Stream_Op)
+and then Nkind (Unit_Declaration_Node (Stream_Op)) =
+N_Subprogram_Declaration
+and then not Is_Frozen (Stream_Op)
+then
+Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
+end if;
+end loop;
+end Freeze_Stream_Operations;
+-----------------
+-- Freeze_Type --
+-----------------
+--  Full type declarations are expanded at the point at which the type is
+--  frozen. The formal N is the Freeze_Node for the type. Any statements or
+--  declarations generated by the freezing (e.g. the procedure generated
+--  for initialization) are chained in the Actions field list of the freeze
+--  node using Append_Freeze_Actions.
+--  WARNING: This routine manages Ghost regions. Return statements must be
+--  replaced by gotos which jump to the end of the routine and restore the
+--  Ghost mode.
+function Freeze_Type (N : Node_Id) return Boolean is
+procedure Process_RACW_Types (Typ : Entity_Id);
+--  Validate and generate stubs for all RACW types associated with type
+--  Typ.
+procedure Process_Pending_Access_Types (Typ : Entity_Id);
+--  Associate type Typ's Finalize_Address primitive with the finalization
+--  masters of pending access-to-Typ types.
+------------------------
+-- Process_RACW_Types --
+------------------------
+procedure Process_RACW_Types (Typ : Entity_Id) is
+List : constant Elist_Id := Access_Types_To_Process (N);
+E    : Elmt_Id;
+Seen : Boolean := False;
+begin
+if Present (List) then
+E := First_Elmt (List);
+while Present (E) loop
+if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
+Validate_RACW_Primitives (Node (E));
+Seen := True;
+end if;
+Next_Elmt (E);
+end loop;
+end if;
+--  If there are RACWs designating this type, make stubs now
+if Seen then
+Remote_Types_Tagged_Full_View_Encountered (Typ);
+end if;
+end Process_RACW_Types;
+----------------------------------
+-- Process_Pending_Access_Types --
+----------------------------------
+procedure Process_Pending_Access_Types (Typ : Entity_Id) is
+E : Elmt_Id;
+begin
+--  Finalize_Address is not generated in CodePeer mode because the
+--  body contains address arithmetic. This processing is disabled.
+if CodePeer_Mode then
+null;
+--  Certain itypes are generated for contexts that cannot allocate
+--  objects and should not set primitive Finalize_Address.
+elsif Is_Itype (Typ)
+and then Nkind (Associated_Node_For_Itype (Typ)) =
+N_Explicit_Dereference
+then
+null;
+--  When an access type is declared after the incomplete view of a
+--  Taft-amendment type, the access type is considered pending in
+--  case the full view of the Taft-amendment type is controlled. If
+--  this is indeed the case, associate the Finalize_Address routine
+--  of the full view with the finalization masters of all pending
+--  access types. This scenario applies to anonymous access types as
+--  well.
+elsif Needs_Finalization (Typ)
+and then Present (Pending_Access_Types (Typ))
+then
+E := First_Elmt (Pending_Access_Types (Typ));
+while Present (E) loop
+--  Generate:
+--    Set_Finalize_Address
+--      (Ptr_Typ, <Typ>FD'Unrestricted_Access);
+Append_Freeze_Action (Typ,
+Make_Set_Finalize_Address_Call
+(Loc     => Sloc (N),
+Ptr_Typ => Node (E)));
+Next_Elmt (E);
+end loop;
+end if;
+end Process_Pending_Access_Types;
+--  Local variables
+Def_Id : constant Entity_Id := Entity (N);
+Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+--  Save the Ghost mode to restore on exit
+Result : Boolean := False;
+--  Start of processing for Freeze_Type
+begin
+--  The type being frozen may be subject to pragma Ghost. Set the mode
+--  now to ensure that any nodes generated during freezing are properly
+--  marked as Ghost.
+Set_Ghost_Mode (Def_Id);
+--  Process any remote access-to-class-wide types designating the type
+--  being frozen.
+Process_RACW_Types (Def_Id);
+--  Freeze processing for record types
+if Is_Record_Type (Def_Id) then
+if Ekind (Def_Id) = E_Record_Type then
+Expand_Freeze_Record_Type (N);
+elsif Is_Class_Wide_Type (Def_Id) then
+Expand_Freeze_Class_Wide_Type (N);
+end if;
+--  Freeze processing for array types
+elsif Is_Array_Type (Def_Id) then
+Expand_Freeze_Array_Type (N);
+--  Freeze processing for access types
+--  For pool-specific access types, find out the pool object used for
+--  this type, needs actual expansion of it in some cases. Here are the
+--  different cases :
+--  1. Rep Clause "for Def_Id'Storage_Size use 0;"
+--      ---> don't use any storage pool
+--  2. Rep Clause : for Def_Id'Storage_Size use Expr.
+--     Expand:
+--      Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
+--  3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
+--      ---> Storage Pool is the specified one
+--  See GNAT Pool packages in the Run-Time for more details
+elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then
+declare
+Loc        : constant Source_Ptr := Sloc (N);
+Desig_Type : constant Entity_Id  := Designated_Type (Def_Id);
+Freeze_Action_Typ : Entity_Id;
+Pool_Object       : Entity_Id;
+begin
+--  Case 1
+--    Rep Clause "for Def_Id'Storage_Size use 0;"
+--    ---> don't use any storage pool
+if No_Pool_Assigned (Def_Id) then
+null;
+--  Case 2
+--    Rep Clause : for Def_Id'Storage_Size use Expr.
+--    ---> Expand:
+--           Def_Id__Pool : Stack_Bounded_Pool
+--                            (Expr, DT'Size, DT'Alignment);
+elsif Has_Storage_Size_Clause (Def_Id) then
+declare
+DT_Align : Node_Id;
+DT_Size  : Node_Id;
+begin
+--  For unconstrained composite types we give a size of zero
+--  so that the pool knows that it needs a special algorithm
+--  for variable size object allocation.
+if Is_Composite_Type (Desig_Type)
+and then not Is_Constrained (Desig_Type)
+then
+DT_Size  := Make_Integer_Literal (Loc, 0);
+DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment);
+else
+DT_Size :=
+Make_Attribute_Reference (Loc,
+Prefix         => New_Occurrence_Of (Desig_Type, Loc),
+Attribute_Name => Name_Max_Size_In_Storage_Elements);
+DT_Align :=
+Make_Attribute_Reference (Loc,
+Prefix         => New_Occurrence_Of (Desig_Type, Loc),
+Attribute_Name => Name_Alignment);
+end if;
+Pool_Object :=
+Make_Defining_Identifier (Loc,
+Chars => New_External_Name (Chars (Def_Id), 'P'));
+--  We put the code associated with the pools in the entity
+--  that has the later freeze node, usually the access type
+--  but it can also be the designated_type; because the pool
+--  code requires both those types to be frozen
+if Is_Frozen (Desig_Type)
+and then (No (Freeze_Node (Desig_Type))
+or else Analyzed (Freeze_Node (Desig_Type)))
+then
+Freeze_Action_Typ := Def_Id;
+--  A Taft amendment type cannot get the freeze actions
+--  since the full view is not there.
+elsif Is_Incomplete_Or_Private_Type (Desig_Type)
+and then No (Full_View (Desig_Type))
+then
+Freeze_Action_Typ := Def_Id;
+else
+Freeze_Action_Typ := Desig_Type;
+end if;
+Append_Freeze_Action (Freeze_Action_Typ,
+Make_Object_Declaration (Loc,
+Defining_Identifier => Pool_Object,
+Object_Definition   =>
+Make_Subtype_Indication (Loc,
+Subtype_Mark =>
+New_Occurrence_Of
+(RTE (RE_Stack_Bounded_Pool), Loc),
+Constraint   =>
+Make_Index_Or_Discriminant_Constraint (Loc,
+Constraints => New_List (
+--  First discriminant is the Pool Size
+New_Occurrence_Of (
+Storage_Size_Variable (Def_Id), Loc),
+--  Second discriminant is the element size
+DT_Size,
+--  Third discriminant is the alignment
+DT_Align)))));
+end;
+Set_Associated_Storage_Pool (Def_Id, Pool_Object);
+--  Case 3
+--    Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
+--    ---> Storage Pool is the specified one
+--  When compiling in Ada 2012 mode, ensure that the accessibility
+--  level of the subpool access type is not deeper than that of the
+--  pool_with_subpools.
+elsif Ada_Version >= Ada_2012
+and then Present (Associated_Storage_Pool (Def_Id))
+--  Omit this check for the case of a configurable run-time that
+--  does not provide package System.Storage_Pools.Subpools.
+and then RTE_Available (RE_Root_Storage_Pool_With_Subpools)
+then
+declare
+Loc   : constant Source_Ptr := Sloc (Def_Id);
+Pool  : constant Entity_Id :=
+Associated_Storage_Pool (Def_Id);
+RSPWS : constant Entity_Id :=
+RTE (RE_Root_Storage_Pool_With_Subpools);
+begin
+--  It is known that the accessibility level of the access
+--  type is deeper than that of the pool.
+if Type_Access_Level (Def_Id) > Object_Access_Level (Pool)
+and then not Accessibility_Checks_Suppressed (Def_Id)
+and then not Accessibility_Checks_Suppressed (Pool)
+then
+--  Static case: the pool is known to be a descendant of
+--  Root_Storage_Pool_With_Subpools.
+if Is_Ancestor (RSPWS, Etype (Pool)) then
+Error_Msg_N
+("??subpool access type has deeper accessibility "
+& "level than pool", Def_Id);
+Append_Freeze_Action (Def_Id,
+Make_Raise_Program_Error (Loc,
+Reason => PE_Accessibility_Check_Failed));
+--  Dynamic case: when the pool is of a class-wide type,
+--  it may or may not support subpools depending on the
+--  path of derivation. Generate:
+--    if Def_Id in RSPWS'Class then
+--       raise Program_Error;
+--    end if;
+elsif Is_Class_Wide_Type (Etype (Pool)) then
+Append_Freeze_Action (Def_Id,
+Make_If_Statement (Loc,
+Condition       =>
+Make_In (Loc,
+Left_Opnd  => New_Occurrence_Of (Pool, Loc),
+Right_Opnd =>
+New_Occurrence_Of
+(Class_Wide_Type (RSPWS), Loc)),
+Then_Statements => New_List (
+Make_Raise_Program_Error (Loc,
+Reason => PE_Accessibility_Check_Failed))));
+end if;
+end if;
+end;
+end if;
+--  For access-to-controlled types (including class-wide types and
+--  Taft-amendment types, which potentially have controlled
+--  components), expand the list controller object that will store
+--  the dynamically allocated objects. Don't do this transformation
+--  for expander-generated access types, but do it for types that
+--  are the full view of types derived from other private types.
+--  Also suppress the list controller in the case of a designated
+--  type with convention Java, since this is used when binding to
+--  Java API specs, where there's no equivalent of a finalization
+--  list and we don't want to pull in the finalization support if
+--  not needed.
+if not Comes_From_Source (Def_Id)
+and then not Has_Private_Declaration (Def_Id)
+then
+null;
+--  An exception is made for types defined in the run-time because
+--  Ada.Tags.Tag itself is such a type and cannot afford this
+--  unnecessary overhead that would generates a loop in the
+--  expansion scheme. Another exception is if Restrictions
+--  (No_Finalization) is active, since then we know nothing is
+--  controlled.
+elsif Restriction_Active (No_Finalization)
+or else In_Runtime (Def_Id)
+then
+null;
+--  Create a finalization master for an access-to-controlled type
+--  or an access-to-incomplete type. It is assumed that the full
+--  view will be controlled.
+elsif Needs_Finalization (Desig_Type)
+or else (Is_Incomplete_Type (Desig_Type)
+and then No (Full_View (Desig_Type)))
+then
+Build_Finalization_Master (Def_Id);
+--  Create a finalization master when the designated type contains
+--  a private component. It is assumed that the full view will be
+--  controlled.
+elsif Has_Private_Component (Desig_Type) then
+Build_Finalization_Master
+(Typ            => Def_Id,
+For_Private    => True,
+Context_Scope  => Scope (Def_Id),
+Insertion_Node => Declaration_Node (Desig_Type));
+end if;
+end;
+--  Freeze processing for enumeration types
+elsif Ekind (Def_Id) = E_Enumeration_Type then
+--  We only have something to do if we have a non-standard
+--  representation (i.e. at least one literal whose pos value
+--  is not the same as its representation)
+if Has_Non_Standard_Rep (Def_Id) then
+Expand_Freeze_Enumeration_Type (N);
+end if;
+--  Private types that are completed by a derivation from a private
+--  type have an internally generated full view, that needs to be
+--  frozen. This must be done explicitly because the two views share
+--  the freeze node, and the underlying full view is not visible when
+--  the freeze node is analyzed.
+elsif Is_Private_Type (Def_Id)
+and then Is_Derived_Type (Def_Id)
+and then Present (Full_View (Def_Id))
+and then Is_Itype (Full_View (Def_Id))
+and then Has_Private_Declaration (Full_View (Def_Id))
+and then Freeze_Node (Full_View (Def_Id)) = N
+then
+Set_Entity (N, Full_View (Def_Id));
+Result := Freeze_Type (N);
+Set_Entity (N, Def_Id);
+--  All other types require no expander action. There are such cases
+--  (e.g. task types and protected types). In such cases, the freeze
+--  nodes are there for use by Gigi.
+end if;
+--  Complete the initialization of all pending access types' finalization
+--  masters now that the designated type has been is frozen and primitive
+--  Finalize_Address generated.
+Process_Pending_Access_Types (Def_Id);
+Freeze_Stream_Operations (N, Def_Id);
+--  Generate the [spec and] body of the procedure tasked with the runtime
+--  verification of pragma Default_Initial_Condition's expression.
+if Has_DIC (Def_Id) then
+Build_DIC_Procedure_Body (Def_Id, For_Freeze => True);
+end if;
+--  Generate the [spec and] body of the invariant procedure tasked with
+--  the runtime verification of all invariants that pertain to the type.
+--  This includes invariants on the partial and full view, inherited
+--  class-wide invariants from parent types or interfaces, and invariants
+--  on array elements or record components.
+if Is_Interface (Def_Id) then
+--  Interfaces are treated as the partial view of a private type in
+--  order to achieve uniformity with the general case. As a result, an
+--  interface receives only a "partial" invariant procedure which is
+--  never called.
+if Has_Own_Invariants (Def_Id) then
+Build_Invariant_Procedure_Body
+(Typ               => Def_Id,
+Partial_Invariant => Is_Interface (Def_Id));
+end if;
+--  Non-interface types
+--  Do not generate invariant procedure within other assertion
+--  subprograms, which may involve local declarations of local
+--  subtypes to which these checks do not apply.
+elsif Has_Invariants (Def_Id) then
+if Within_Internal_Subprogram
+or else (Ekind (Current_Scope) = E_Function
+and then Is_Predicate_Function (Current_Scope))
+then
+null;
+else
+Build_Invariant_Procedure_Body (Def_Id);
+end if;
+end if;
+Restore_Ghost_Mode (Saved_GM);
+return Result;
+exception
+when RE_Not_Available =>
+Restore_Ghost_Mode (Saved_GM);
+return False;
+end Freeze_Type;
+-------------------------
+-- Get_Simple_Init_Val --
+-------------------------
+function Get_Simple_Init_Val
+(T    : Entity_Id;
+N    : Node_Id;
+Size : Uint := No_Uint) return Node_Id
+is
+Loc    : constant Source_Ptr := Sloc (N);
+Val    : Node_Id;
+Result : Node_Id;
+Val_RE : RE_Id;
+Size_To_Use : Uint;
+--  This is the size to be used for computation of the appropriate
+--  initial value for the Normalize_Scalars and Initialize_Scalars case.
+IV_Attribute : constant Boolean :=
+Nkind (N) = N_Attribute_Reference
+and then Attribute_Name (N) = Name_Invalid_Value;
+Lo_Bound : Uint;
+Hi_Bound : Uint;
+--  These are the values computed by the procedure Check_Subtype_Bounds
+procedure Check_Subtype_Bounds;
+--  This procedure examines the subtype T, and its ancestor subtypes and
+--  derived types to determine the best known information about the
+--  bounds of the subtype. After the call Lo_Bound is set either to
+--  No_Uint if no information can be determined, or to a value which
+--  represents a known low bound, i.e. a valid value of the subtype can
+--  not be less than this value. Hi_Bound is similarly set to a known
+--  high bound (valid value cannot be greater than this).
+--------------------------
+-- Check_Subtype_Bounds --
+--------------------------
+procedure Check_Subtype_Bounds is
+ST1  : Entity_Id;
+ST2  : Entity_Id;
+Lo   : Node_Id;
+Hi   : Node_Id;
+Loval : Uint;
+Hival : Uint;
+begin
+Lo_Bound := No_Uint;
+Hi_Bound := No_Uint;
+--  Loop to climb ancestor subtypes and derived types
+ST1 := T;
+loop
+if not Is_Discrete_Type (ST1) then
+return;
+end if;
+Lo := Type_Low_Bound (ST1);
+Hi := Type_High_Bound (ST1);
+if Compile_Time_Known_Value (Lo) then
+Loval := Expr_Value (Lo);
+if Lo_Bound = No_Uint or else Lo_Bound < Loval then
+Lo_Bound := Loval;
+end if;
+end if;
+if Compile_Time_Known_Value (Hi) then
+Hival := Expr_Value (Hi);
+if Hi_Bound = No_Uint or else Hi_Bound > Hival then
+Hi_Bound := Hival;
+end if;
+end if;
+ST2 := Ancestor_Subtype (ST1);
+if No (ST2) then
+ST2 := Etype (ST1);
+end if;
+exit when ST1 = ST2;
+ST1 := ST2;
+end loop;
+end Check_Subtype_Bounds;
+--  Start of processing for Get_Simple_Init_Val
+begin
+--  For a private type, we should always have an underlying type (because
+--  this was already checked in Needs_Simple_Initialization). What we do
+--  is to get the value for the underlying type and then do an unchecked
+--  conversion to the private type.
+if Is_Private_Type (T) then
+Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
+--  A special case, if the underlying value is null, then qualify it
+--  with the underlying type, so that the null is properly typed.
+--  Similarly, if it is an aggregate it must be qualified, because an
+--  unchecked conversion does not provide a context for it.
+if Nkind_In (Val, N_Null, N_Aggregate) then
+Val :=
+Make_Qualified_Expression (Loc,
+Subtype_Mark =>
+New_Occurrence_Of (Underlying_Type (T), Loc),
+Expression => Val);
+end if;
+Result := Unchecked_Convert_To (T, Val);
+--  Don't truncate result (important for Initialize/Normalize_Scalars)
+if Nkind (Result) = N_Unchecked_Type_Conversion
+and then Is_Scalar_Type (Underlying_Type (T))
+then
+Set_No_Truncation (Result);
+end if;
+return Result;
+--  Scalars with Default_Value aspect. The first subtype may now be
+--  private, so retrieve value from underlying type.
+elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
+if Is_Private_Type (First_Subtype (T)) then
+return Unchecked_Convert_To (T,
+Default_Aspect_Value (Full_View (First_Subtype (T))));
+else
+return
+Convert_To (T, Default_Aspect_Value (First_Subtype (T)));
+end if;
+--  Otherwise, for scalars, we must have normalize/initialize scalars
+--  case, or if the node N is an 'Invalid_Value attribute node.
+elsif Is_Scalar_Type (T) then
+pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
+--  Compute size of object. If it is given by the caller, we can use
+--  it directly, otherwise we use Esize (T) as an estimate. As far as
+--  we know this covers all cases correctly.
+if Size = No_Uint or else Size <= Uint_0 then
+Size_To_Use := UI_Max (Uint_1, Esize (T));
+else
+Size_To_Use := Size;
+end if;
+--  Maximum size to use is 64 bits, since we will create values of
+--  type Unsigned_64 and the range must fit this type.
+if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
+Size_To_Use := Uint_64;
+end if;
+--  Check known bounds of subtype
+Check_Subtype_Bounds;
+--  Processing for Normalize_Scalars case
+if Normalize_Scalars and then not IV_Attribute then
+--  If zero is invalid, it is a convenient value to use that is
+--  for sure an appropriate invalid value in all situations.
+if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
+Val := Make_Integer_Literal (Loc, 0);
+--  Cases where all one bits is the appropriate invalid value
+--  For modular types, all 1 bits is either invalid or valid. If
+--  it is valid, then there is nothing that can be done since there
+--  are no invalid values (we ruled out zero already).
+--  For signed integer types that have no negative values, either
+--  there is room for negative values, or there is not. If there
+--  is, then all 1-bits may be interpreted as minus one, which is
+--  certainly invalid. Alternatively it is treated as the largest
+--  positive value, in which case the observation for modular types
+--  still applies.
+--  For float types, all 1-bits is a NaN (not a number), which is
+--  certainly an appropriately invalid value.
+elsif Is_Unsigned_Type (T)
+or else Is_Floating_Point_Type (T)
+or else Is_Enumeration_Type (T)
+then
+Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
+--  Resolve as Unsigned_64, because the largest number we can
+--  generate is out of range of universal integer.
+Analyze_And_Resolve (Val, RTE (RE_Unsigned_64));
+--  Case of signed types
+else
+declare
+Signed_Size : constant Uint :=
+UI_Min (Uint_63, Size_To_Use - 1);
+begin
+--  Normally we like to use the most negative number. The one
+--  exception is when this number is in the known subtype
+--  range and the largest positive number is not in the known
+--  subtype range.
+--  For this exceptional case, use largest positive value
+if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint
+and then Lo_Bound <= (-(2 ** Signed_Size))
+and then Hi_Bound < 2 ** Signed_Size
+then
+Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
+--  Normal case of largest negative value
+else
+Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
+end if;
+end;
+end if;
+--  Here for Initialize_Scalars case (or Invalid_Value attribute used)
+else
+--  For float types, use float values from System.Scalar_Values
+if Is_Floating_Point_Type (T) then
+if Root_Type (T) = Standard_Short_Float then
+Val_RE := RE_IS_Isf;
+elsif Root_Type (T) = Standard_Float then
+Val_RE := RE_IS_Ifl;
+elsif Root_Type (T) = Standard_Long_Float then
+Val_RE := RE_IS_Ilf;
+else pragma Assert (Root_Type (T) = Standard_Long_Long_Float);
+Val_RE := RE_IS_Ill;
+end if;
+--  If zero is invalid, use zero values from System.Scalar_Values
+elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
+if Size_To_Use <= 8 then
+Val_RE := RE_IS_Iz1;
+elsif Size_To_Use <= 16 then
+Val_RE := RE_IS_Iz2;
+elsif Size_To_Use <= 32 then
+Val_RE := RE_IS_Iz4;
+else
+Val_RE := RE_IS_Iz8;
+end if;
+--  For unsigned, use unsigned values from System.Scalar_Values
+elsif Is_Unsigned_Type (T) then
+if Size_To_Use <= 8 then
+Val_RE := RE_IS_Iu1;
+elsif Size_To_Use <= 16 then
+Val_RE := RE_IS_Iu2;
+elsif Size_To_Use <= 32 then
+Val_RE := RE_IS_Iu4;
+else
+Val_RE := RE_IS_Iu8;
+end if;
+--  For signed, use signed values from System.Scalar_Values
+else
+if Size_To_Use <= 8 then
+Val_RE := RE_IS_Is1;
+elsif Size_To_Use <= 16 then
+Val_RE := RE_IS_Is2;
+elsif Size_To_Use <= 32 then
+Val_RE := RE_IS_Is4;
+else
+Val_RE := RE_IS_Is8;
+end if;
+end if;
+Val := New_Occurrence_Of (RTE (Val_RE), Loc);
+end if;
+--  The final expression is obtained by doing an unchecked conversion
+--  of this result to the base type of the required subtype. Use the
+--  base type to prevent the unchecked conversion from chopping bits,
+--  and then we set Kill_Range_Check to preserve the "bad" value.
+Result := Unchecked_Convert_To (Base_Type (T), Val);
+--  Ensure result is not truncated, since we want the "bad" bits, and
+--  also kill range check on result.
+if Nkind (Result) = N_Unchecked_Type_Conversion then
+Set_No_Truncation (Result);
+Set_Kill_Range_Check (Result, True);
+end if;
+return Result;
+--  String or Wide_[Wide]_String (must have Initialize_Scalars set)
+elsif Is_Standard_String_Type (T) then
+pragma Assert (Init_Or_Norm_Scalars);
+return
+Make_Aggregate (Loc,
+Component_Associations => New_List (
+Make_Component_Association (Loc,
+Choices    => New_List (
+Make_Others_Choice (Loc)),
+Expression =>
+Get_Simple_Init_Val
+(Component_Type (T), N, Esize (Root_Type (T))))));
+--  Access type is initialized to null
+elsif Is_Access_Type (T) then
+return Make_Null (Loc);
+--  No other possibilities should arise, since we should only be calling
+--  Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
+--  indicating one of the above cases held.
+else
+raise Program_Error;
+end if;
+exception
+when RE_Not_Available =>
+return Empty;
+end Get_Simple_Init_Val;
+------------------------------
+-- Has_New_Non_Standard_Rep --
+------------------------------
+function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
+begin
+if not Is_Derived_Type (T) then
+return Has_Non_Standard_Rep (T)
+or else Has_Non_Standard_Rep (Root_Type (T));
+--  If Has_Non_Standard_Rep is not set on the derived type, the
+--  representation is fully inherited.
+elsif not Has_Non_Standard_Rep (T) then
+return False;
+else
+return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
+--  May need a more precise check here: the First_Rep_Item may be a
+--  stream attribute, which does not affect the representation of the
+--  type ???
+end if;
+end Has_New_Non_Standard_Rep;
+----------------------
+-- Inline_Init_Proc --
+----------------------
+function Inline_Init_Proc (Typ : Entity_Id) return Boolean is
+begin
+--  The initialization proc 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 proc of records that need finalization contains
+--  a nested clean-up procedure that makes it impractical to inline as
+--  well, except for simple controlled types themselves. And similar
+--  considerations apply to task types.
+if Is_Concurrent_Type (Typ) then
+return False;
+elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then
+return False;
+elsif Has_Task (Typ) then
+return False;
+else
+return True;
+end if;
+end Inline_Init_Proc;
+----------------
+-- In_Runtime --
+----------------
+function In_Runtime (E : Entity_Id) return Boolean is
+S1 : Entity_Id;
+begin
+S1 := Scope (E);
+while Scope (S1) /= Standard_Standard loop
+S1 := Scope (S1);
+end loop;
+return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
+end In_Runtime;
+----------------------------
+-- Initialization_Warning --
+----------------------------
+procedure Initialization_Warning (E : Entity_Id) is
+Warning_Needed : Boolean;
+begin
+Warning_Needed := False;
+if Ekind (Current_Scope) = E_Package
+and then Static_Elaboration_Desired (Current_Scope)
+then
+if Is_Type (E) then
+if Is_Record_Type (E) then
+if Has_Discriminants (E)
+or else Is_Limited_Type (E)
+or else Has_Non_Standard_Rep (E)
+then
+Warning_Needed := True;
+else
+--  Verify that at least one component has an initialization
+--  expression. No need for a warning on a type if all its
+--  components have no initialization.
+declare
+Comp : Entity_Id;
+begin
+Comp := First_Component (E);
+while Present (Comp) loop
+if Ekind (Comp) = E_Discriminant
+or else
+(Nkind (Parent (Comp)) = N_Component_Declaration
+and then Present (Expression (Parent (Comp))))
+then
+Warning_Needed := True;
+exit;
+end if;
+Next_Component (Comp);
+end loop;
+end;
+end if;
+if Warning_Needed then
+Error_Msg_N
+("Objects of the type cannot be initialized statically "
+& "by default??", Parent (E));
+end if;
+end if;
+else
+Error_Msg_N ("Object cannot be initialized statically??", E);
+end if;
+end if;
+end Initialization_Warning;
+------------------
+-- Init_Formals --
+------------------
+function Init_Formals (Typ : Entity_Id) return List_Id is
+Loc     : constant Source_Ptr := Sloc (Typ);
+Formals : List_Id;
+begin
+--  First parameter is always _Init : in out typ. Note that we need this
+--  to be in/out because in the case of the task record value, there
+--  are default record fields (_Priority, _Size, -Task_Info) that may
+--  be referenced in the generated initialization routine.
+Formals := New_List (
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit),
+In_Present          => True,
+Out_Present         => True,
+Parameter_Type      => New_Occurrence_Of (Typ, Loc)));
+--  For task record value, or type that contains tasks, add two more
+--  formals, _Master : Master_Id and _Chain : in out Activation_Chain
+--  We also add these parameters for the task record type case.
+if Has_Task (Typ)
+or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ))
+then
+Append_To (Formals,
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Name_uMaster),
+Parameter_Type      =>
+New_Occurrence_Of (RTE (RE_Master_Id), Loc)));
+--  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 (Formals,
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Name_uChain),
+In_Present          => True,
+Out_Present         => True,
+Parameter_Type      =>
+New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)));
+end if;
+Append_To (Formals,
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Name_uTask_Name),
+In_Present          => True,
+Parameter_Type      => New_Occurrence_Of (Standard_String, Loc)));
+end if;
+return Formals;
+exception
+when RE_Not_Available =>
+return Empty_List;
+end Init_Formals;
+-------------------------
+-- Init_Secondary_Tags --
+-------------------------
+procedure Init_Secondary_Tags
+(Typ            : Entity_Id;
+Target         : Node_Id;
+Init_Tags_List : List_Id;
+Stmts_List     : List_Id;
+Fixed_Comps    : Boolean := True;
+Variable_Comps : Boolean := True)
+is
+Loc : constant Source_Ptr := Sloc (Target);
+--  Inherit the C++ tag of the secondary dispatch table of Typ associated
+--  with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
+procedure Initialize_Tag
+(Typ       : Entity_Id;
+Iface     : Entity_Id;
+Tag_Comp  : Entity_Id;
+Iface_Tag : Node_Id);
+--  Initialize the tag of the secondary dispatch table of Typ associated
+--  with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
+--  Compiling under the CPP full ABI compatibility mode, if the ancestor
+--  of Typ CPP tagged type we generate code to inherit the contents of
+--  the dispatch table directly from the ancestor.
+--------------------
+-- Initialize_Tag --
+--------------------
+procedure Initialize_Tag
+(Typ       : Entity_Id;
+Iface     : Entity_Id;
+Tag_Comp  : Entity_Id;
+Iface_Tag : Node_Id)
+is
+Comp_Typ           : Entity_Id;
+Offset_To_Top_Comp : Entity_Id := Empty;
+begin
+--  Initialize pointer to secondary DT associated with the interface
+if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
+Append_To (Init_Tags_List,
+Make_Assignment_Statement (Loc,
+Name       =>
+Make_Selected_Component (Loc,
+Prefix        => New_Copy_Tree (Target),
+Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
+Expression =>
+New_Occurrence_Of (Iface_Tag, Loc)));
+end if;
+Comp_Typ := Scope (Tag_Comp);
+--  Initialize the entries of the table of interfaces. We generate a
+--  different call when the parent of the type has variable size
+--  components.
+if Comp_Typ /= Etype (Comp_Typ)
+and then Is_Variable_Size_Record (Etype (Comp_Typ))
+and then Chars (Tag_Comp) /= Name_uTag
+then
+pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
+--  Issue error if Set_Dynamic_Offset_To_Top is not available in a
+--  configurable run-time environment.
+if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
+Error_Msg_CRT
+("variable size record with interface types", Typ);
+return;
+end if;
+--  Generate:
+--    Set_Dynamic_Offset_To_Top
+--      (This         => Init,
+--       Prim_T       => Typ'Tag,
+--       Interface_T  => Iface'Tag,
+--       Offset_Value => n,
+--       Offset_Func  => Fn'Address)
+Append_To (Stmts_List,
+Make_Procedure_Call_Statement (Loc,
+Name                   =>
+New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
+Parameter_Associations => New_List (
+Make_Attribute_Reference (Loc,
+Prefix         => New_Copy_Tree (Target),
+Attribute_Name => Name_Address),
+Unchecked_Convert_To (RTE (RE_Tag),
+New_Occurrence_Of
+(Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
+Unchecked_Convert_To (RTE (RE_Tag),
+New_Occurrence_Of
+(Node (First_Elmt (Access_Disp_Table (Iface))),
+Loc)),
+Unchecked_Convert_To
+(RTE (RE_Storage_Offset),
+Make_Attribute_Reference (Loc,
+Prefix         =>
+Make_Selected_Component (Loc,
+Prefix        => New_Copy_Tree (Target),
+Selector_Name =>
+New_Occurrence_Of (Tag_Comp, Loc)),
+Attribute_Name => Name_Position)),
+Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
+Make_Attribute_Reference (Loc,
+Prefix => New_Occurrence_Of
+(DT_Offset_To_Top_Func (Tag_Comp), Loc),
+Attribute_Name => Name_Address)))));
+--  In this case the next component stores the value of the offset
+--  to the top.
+Offset_To_Top_Comp := Next_Entity (Tag_Comp);
+pragma Assert (Present (Offset_To_Top_Comp));
+Append_To (Init_Tags_List,
+Make_Assignment_Statement (Loc,
+Name       =>
+Make_Selected_Component (Loc,
+Prefix        => New_Copy_Tree (Target),
+Selector_Name =>
+New_Occurrence_Of (Offset_To_Top_Comp, Loc)),
+Expression =>
+Make_Attribute_Reference (Loc,
+Prefix       =>
+Make_Selected_Component (Loc,
+Prefix        => New_Copy_Tree (Target),
+Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
+Attribute_Name => Name_Position)));
+--  Normal case: No discriminants in the parent type
+else
+--  Don't need to set any value if the offset-to-top field is
+--  statically set or if this interface shares the primary
+--  dispatch table.
+if not Building_Static_Secondary_DT (Typ)
+and then not Is_Ancestor (Iface, Typ, Use_Full_View => True)
+then
+Append_To (Stmts_List,
+Build_Set_Static_Offset_To_Top (Loc,
+Iface_Tag    => New_Occurrence_Of (Iface_Tag, Loc),
+Offset_Value =>
+Unchecked_Convert_To (RTE (RE_Storage_Offset),
+Make_Attribute_Reference (Loc,
+Prefix         =>
+Make_Selected_Component (Loc,
+Prefix        => New_Copy_Tree (Target),
+Selector_Name =>
+New_Occurrence_Of (Tag_Comp, Loc)),
+Attribute_Name => Name_Position))));
+end if;
+--  Generate:
+--    Register_Interface_Offset
+--      (Prim_T       => Typ'Tag,
+--       Interface_T  => Iface'Tag,
+--       Is_Constant  => True,
+--       Offset_Value => n,
+--       Offset_Func  => null);
+if RTE_Available (RE_Register_Interface_Offset) then
+Append_To (Stmts_List,
+Make_Procedure_Call_Statement (Loc,
+Name                   =>
+New_Occurrence_Of
+(RTE (RE_Register_Interface_Offset), Loc),
+Parameter_Associations => New_List (
+Unchecked_Convert_To (RTE (RE_Tag),
+New_Occurrence_Of
+(Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
+Unchecked_Convert_To (RTE (RE_Tag),
+New_Occurrence_Of
+(Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
+New_Occurrence_Of (Standard_True, Loc),
+Unchecked_Convert_To (RTE (RE_Storage_Offset),
+Make_Attribute_Reference (Loc,
+Prefix         =>
+Make_Selected_Component (Loc,
+Prefix         => New_Copy_Tree (Target),
+Selector_Name  =>
+New_Occurrence_Of (Tag_Comp, Loc)),
+Attribute_Name => Name_Position)),
+Make_Null (Loc))));
+end if;
+end if;
+end Initialize_Tag;
+--  Local variables
+Full_Typ         : Entity_Id;
+Ifaces_List      : Elist_Id;
+Ifaces_Comp_List : Elist_Id;
+Ifaces_Tag_List  : Elist_Id;
+Iface_Elmt       : Elmt_Id;
+Iface_Comp_Elmt  : Elmt_Id;
+Iface_Tag_Elmt   : Elmt_Id;
+Tag_Comp         : Node_Id;
+In_Variable_Pos  : Boolean;
+--  Start of processing for Init_Secondary_Tags
+begin
+--  Handle private types
+if Present (Full_View (Typ)) then
+Full_Typ := Full_View (Typ);
+else
+Full_Typ := Typ;
+end if;
+Collect_Interfaces_Info
+(Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
+Iface_Elmt      := First_Elmt (Ifaces_List);
+Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
+Iface_Tag_Elmt  := First_Elmt (Ifaces_Tag_List);
+while Present (Iface_Elmt) loop
+Tag_Comp := Node (Iface_Comp_Elmt);
+--  Check if parent of record type has variable size components
+In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
+and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
+--  If we are compiling under the CPP full ABI compatibility mode and
+--  the ancestor is a CPP_Pragma tagged type then we generate code to
+--  initialize the secondary tag components from tags that reference
+--  secondary tables filled with copy of parent slots.
+if Is_CPP_Class (Root_Type (Full_Typ)) then
+--  Reject interface components located at variable offset in
+--  C++ derivations. This is currently unsupported.
+if not Fixed_Comps and then In_Variable_Pos then
+--  Locate the first dynamic component of the record. Done to
+--  improve the text of the warning.
+declare
+Comp     : Entity_Id;
+Comp_Typ : Entity_Id;
+begin
+Comp := First_Entity (Typ);
+while Present (Comp) loop
+Comp_Typ := Etype (Comp);
+if Ekind (Comp) /= E_Discriminant
+and then not Is_Tag (Comp)
+then
+exit when
+(Is_Record_Type (Comp_Typ)
+and then
+Is_Variable_Size_Record (Base_Type (Comp_Typ)))
+or else
+(Is_Array_Type (Comp_Typ)
+and then Is_Variable_Size_Array (Comp_Typ));
+end if;
+Next_Entity (Comp);
+end loop;
+pragma Assert (Present (Comp));
+Error_Msg_Node_2 := Comp;
+Error_Msg_NE
+("parent type & with dynamic component & cannot be parent"
+& " of 'C'P'P derivation if new interfaces are present",
+Typ, Scope (Original_Record_Component (Comp)));
+Error_Msg_Sloc :=
+Sloc (Scope (Original_Record_Component (Comp)));
+Error_Msg_NE
+("type derived from 'C'P'P type & defined #",
+Typ, Scope (Original_Record_Component (Comp)));
+--  Avoid duplicated warnings
+exit;
+end;
+--  Initialize secondary tags
+else
+Append_To (Init_Tags_List,
+Make_Assignment_Statement (Loc,
+Name =>
+Make_Selected_Component (Loc,
+Prefix => New_Copy_Tree (Target),
+Selector_Name =>
+New_Occurrence_Of (Node (Iface_Comp_Elmt), Loc)),
+Expression =>
+New_Occurrence_Of (Node (Iface_Tag_Elmt), Loc)));
+end if;
+--  Otherwise generate code to initialize the tag
+else
+if (In_Variable_Pos and then Variable_Comps)
+or else (not In_Variable_Pos and then Fixed_Comps)
+then
+Initialize_Tag (Full_Typ,
+Iface     => Node (Iface_Elmt),
+Tag_Comp  => Tag_Comp,
+Iface_Tag => Node (Iface_Tag_Elmt));
+end if;
+end if;
+Next_Elmt (Iface_Elmt);
+Next_Elmt (Iface_Comp_Elmt);
+Next_Elmt (Iface_Tag_Elmt);
+end loop;
+end Init_Secondary_Tags;
+------------------------
+-- Is_User_Defined_Eq --
+------------------------
+function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
+begin
+return Chars (Prim) = Name_Op_Eq
+and then Etype (First_Formal (Prim)) =
+Etype (Next_Formal (First_Formal (Prim)))
+and then Base_Type (Etype (Prim)) = Standard_Boolean;
+end Is_User_Defined_Equality;
+----------------------------------------
+-- Make_Controlling_Function_Wrappers --
+----------------------------------------
+procedure Make_Controlling_Function_Wrappers
+(Tag_Typ   : Entity_Id;
+Decl_List : out List_Id;
+Body_List : out List_Id)
+is
+Loc         : constant Source_Ptr := Sloc (Tag_Typ);
+Prim_Elmt   : Elmt_Id;
+Subp        : Entity_Id;
+Actual_List : List_Id;
+Formal_List : List_Id;
+Formal      : Entity_Id;
+Par_Formal  : Entity_Id;
+Formal_Node : Node_Id;
+Func_Body   : Node_Id;
+Func_Decl   : Node_Id;
+Func_Spec   : Node_Id;
+Return_Stmt : Node_Id;
+begin
+Decl_List := New_List;
+Body_List := New_List;
+Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+while Present (Prim_Elmt) loop
+Subp := Node (Prim_Elmt);
+--  If a primitive function with a controlling result of the type has
+--  not been overridden by the user, then we must create a wrapper
+--  function here that effectively overrides it and invokes the
+--  (non-abstract) parent function. This can only occur for a null
+--  extension. Note that functions with anonymous controlling access
+--  results don't qualify and must be overridden. We also exclude
+--  Input attributes, since each type will have its own version of
+--  Input constructed by the expander. The test for Comes_From_Source
+--  is needed to distinguish inherited operations from renamings
+--  (which also have Alias set). We exclude internal entities with
+--  Interface_Alias to avoid generating duplicated wrappers since
+--  the primitive which covers the interface is also available in
+--  the list of primitive operations.
+--  The function may be abstract, or require_Overriding may be set
+--  for it, because tests for null extensions may already have reset
+--  the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
+--  set, functions that need wrappers are recognized by having an
+--  alias that returns the parent type.
+if Comes_From_Source (Subp)
+or else No (Alias (Subp))
+or else Present (Interface_Alias (Subp))
+or else Ekind (Subp) /= E_Function
+or else not Has_Controlling_Result (Subp)
+or else Is_Access_Type (Etype (Subp))
+or else Is_Abstract_Subprogram (Alias (Subp))
+or else Is_TSS (Subp, TSS_Stream_Input)
+then
+goto Next_Prim;
+elsif Is_Abstract_Subprogram (Subp)
+or else Requires_Overriding (Subp)
+or else
+(Is_Null_Extension (Etype (Subp))
+and then Etype (Alias (Subp)) /= Etype (Subp))
+then
+Formal_List := No_List;
+Formal := First_Formal (Subp);
+if Present (Formal) then
+Formal_List := New_List;
+while Present (Formal) loop
+Append
+(Make_Parameter_Specification
+(Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Sloc (Formal),
+Chars => Chars (Formal)),
+In_Present  => In_Present (Parent (Formal)),
+Out_Present => Out_Present (Parent (Formal)),
+Null_Exclusion_Present =>
+Null_Exclusion_Present (Parent (Formal)),
+Parameter_Type =>
+New_Occurrence_Of (Etype (Formal), Loc),
+Expression =>
+New_Copy_Tree (Expression (Parent (Formal)))),
+Formal_List);
+Next_Formal (Formal);
+end loop;
+end if;
+Func_Spec :=
+Make_Function_Specification (Loc,
+Defining_Unit_Name       =>
+Make_Defining_Identifier (Loc,
+Chars => Chars (Subp)),
+Parameter_Specifications => Formal_List,
+Result_Definition        =>
+New_Occurrence_Of (Etype (Subp), Loc));
+Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
+Append_To (Decl_List, Func_Decl);
+--  Build a wrapper body that calls the parent function. The body
+--  contains a single return statement that returns an extension
+--  aggregate whose ancestor part is a call to the parent function,
+--  passing the formals as actuals (with any controlling arguments
+--  converted to the types of the corresponding formals of the
+--  parent function, which might be anonymous access types), and
+--  having a null extension.
+Formal      := First_Formal (Subp);
+Par_Formal  := First_Formal (Alias (Subp));
+Formal_Node := First (Formal_List);
+if Present (Formal) then
+Actual_List := New_List;
+else
+Actual_List := No_List;
+end if;
+while Present (Formal) loop
+if Is_Controlling_Formal (Formal) then
+Append_To (Actual_List,
+Make_Type_Conversion (Loc,
+Subtype_Mark =>
+New_Occurrence_Of (Etype (Par_Formal), Loc),
+Expression   =>
+New_Occurrence_Of
+(Defining_Identifier (Formal_Node), Loc)));
+else
+Append_To
+(Actual_List,
+New_Occurrence_Of
+(Defining_Identifier (Formal_Node), Loc));
+end if;
+Next_Formal (Formal);
+Next_Formal (Par_Formal);
+Next (Formal_Node);
+end loop;
+Return_Stmt :=
+Make_Simple_Return_Statement (Loc,
+Expression =>
+Make_Extension_Aggregate (Loc,
+Ancestor_Part       =>
+Make_Function_Call (Loc,
+Name                   =>
+New_Occurrence_Of (Alias (Subp), Loc),
+Parameter_Associations => Actual_List),
+Null_Record_Present => True));
+Func_Body :=
+Make_Subprogram_Body (Loc,
+Specification              => New_Copy_Tree (Func_Spec),
+Declarations               => Empty_List,
+Handled_Statement_Sequence =>
+Make_Handled_Sequence_Of_Statements (Loc,
+Statements => New_List (Return_Stmt)));
+Set_Defining_Unit_Name
+(Specification (Func_Body),
+Make_Defining_Identifier (Loc, Chars (Subp)));
+Append_To (Body_List, Func_Body);
+--  Replace the inherited function with the wrapper function in the
+--  primitive operations list. We add the minimum decoration needed
+--  to override interface primitives.
+Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
+Override_Dispatching_Operation
+(Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
+Is_Wrapper => True);
+end if;
+<<Next_Prim>>
+Next_Elmt (Prim_Elmt);
+end loop;
+end Make_Controlling_Function_Wrappers;
+-------------------
+--  Make_Eq_Body --
+-------------------
+function Make_Eq_Body
+(Typ     : Entity_Id;
+Eq_Name : Name_Id) return Node_Id
+is
+Loc          : constant Source_Ptr := Sloc (Parent (Typ));
+Decl         : Node_Id;
+Def          : constant Node_Id := Parent (Typ);
+Stmts        : constant List_Id := New_List;
+Variant_Case : Boolean := Has_Discriminants (Typ);
+Comps        : Node_Id := Empty;
+Typ_Def      : Node_Id := Type_Definition (Def);
+begin
+Decl :=
+Predef_Spec_Or_Body (Loc,
+Tag_Typ => Typ,
+Name    => Eq_Name,
+Profile => New_List (
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Name_X),
+Parameter_Type      => New_Occurrence_Of (Typ, Loc)),
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Name_Y),
+Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
+Ret_Type => Standard_Boolean,
+For_Body => True);
+if Variant_Case then
+if Nkind (Typ_Def) = N_Derived_Type_Definition then
+Typ_Def := Record_Extension_Part (Typ_Def);
+end if;
+if Present (Typ_Def) then
+Comps := Component_List (Typ_Def);
+end if;
+Variant_Case :=
+Present (Comps) and then Present (Variant_Part (Comps));
+end if;
+if Variant_Case then
+Append_To (Stmts,
+Make_Eq_If (Typ, Discriminant_Specifications (Def)));
+Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
+Append_To (Stmts,
+Make_Simple_Return_Statement (Loc,
+Expression => New_Occurrence_Of (Standard_True, Loc)));
+else
+Append_To (Stmts,
+Make_Simple_Return_Statement (Loc,
+Expression =>
+Expand_Record_Equality
+(Typ,
+Typ    => Typ,
+Lhs    => Make_Identifier (Loc, Name_X),
+Rhs    => Make_Identifier (Loc, Name_Y),
+Bodies => Declarations (Decl))));
+end if;
+Set_Handled_Statement_Sequence
+(Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+return Decl;
+end Make_Eq_Body;
+------------------
+-- Make_Eq_Case --
+------------------
+--  <Make_Eq_If shared components>
+--  case X.D1 is
+--     when V1 => <Make_Eq_Case> on subcomponents
+--     ...
+--     when Vn => <Make_Eq_Case> on subcomponents
+--  end case;
+function Make_Eq_Case
+(E      : Entity_Id;
+CL     : Node_Id;
+Discrs : Elist_Id := New_Elmt_List) return List_Id
+is
+Loc      : constant Source_Ptr := Sloc (E);
+Result   : constant List_Id    := New_List;
+Variant  : Node_Id;
+Alt_List : List_Id;
+function Corresponding_Formal (C : Node_Id) return Entity_Id;
+--  Given the discriminant that controls a given variant of an unchecked
+--  union, find the formal of the equality function that carries the
+--  inferred value of the discriminant.
+function External_Name (E : Entity_Id) return Name_Id;
+--  The value of a given discriminant is conveyed in the corresponding
+--  formal parameter of the equality routine. The name of this formal
+--  parameter carries a one-character suffix which is removed here.
+--------------------------
+-- Corresponding_Formal --
+--------------------------
+function Corresponding_Formal (C : Node_Id) return Entity_Id is
+Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
+Elm   : Elmt_Id;
+begin
+Elm := First_Elmt (Discrs);
+while Present (Elm) loop
+if Chars (Discr) = External_Name (Node (Elm)) then
+return Node (Elm);
+end if;
+Next_Elmt (Elm);
+end loop;
+--  A formal of the proper name must be found
+raise Program_Error;
+end Corresponding_Formal;
+-------------------
+-- External_Name --
+-------------------
+function External_Name (E : Entity_Id) return Name_Id is
+begin
+Get_Name_String (Chars (E));
+Name_Len := Name_Len - 1;
+return Name_Find;
+end External_Name;
+--  Start of processing for Make_Eq_Case
+begin
+Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
+if No (Variant_Part (CL)) then
+return Result;
+end if;
+Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
+if No (Variant) then
+return Result;
+end if;
+Alt_List := New_List;
+while Present (Variant) loop
+Append_To (Alt_List,
+Make_Case_Statement_Alternative (Loc,
+Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
+Statements =>
+Make_Eq_Case (E, Component_List (Variant), Discrs)));
+Next_Non_Pragma (Variant);
+end loop;
+--  If we have an Unchecked_Union, use one of the parameters of the
+--  enclosing equality routine that captures the discriminant, to use
+--  as the expression in the generated case statement.
+if Is_Unchecked_Union (E) then
+Append_To (Result,
+Make_Case_Statement (Loc,
+Expression =>
+New_Occurrence_Of (Corresponding_Formal (CL), Loc),
+Alternatives => Alt_List));
+else
+Append_To (Result,
+Make_Case_Statement (Loc,
+Expression =>
+Make_Selected_Component (Loc,
+Prefix        => Make_Identifier (Loc, Name_X),
+Selector_Name => New_Copy (Name (Variant_Part (CL)))),
+Alternatives => Alt_List));
+end if;
+return Result;
+end Make_Eq_Case;
+----------------
+-- Make_Eq_If --
+----------------
+--  Generates:
+--    if
+--      X.C1 /= Y.C1
+--        or else
+--      X.C2 /= Y.C2
+--        ...
+--    then
+--       return False;
+--    end if;
+--  or a null statement if the list L is empty
+function Make_Eq_If
+(E : Entity_Id;
+L : List_Id) return Node_Id
+is
+Loc        : constant Source_Ptr := Sloc (E);
+C          : Node_Id;
+Field_Name : Name_Id;
+Cond       : Node_Id;
+begin
+if No (L) then
+return Make_Null_Statement (Loc);
+else
+Cond := Empty;
+C := First_Non_Pragma (L);
+while Present (C) loop
+Field_Name := Chars (Defining_Identifier (C));
+--  The tags must not be compared: they are not part of the value.
+--  Ditto for parent interfaces because their equality operator is
+--  abstract.
+--  Note also that in the following, we use Make_Identifier for
+--  the component names. Use of New_Occurrence_Of to identify the
+--  components would be incorrect because the wrong entities for
+--  discriminants could be picked up in the private type case.
+if Field_Name = Name_uParent
+and then Is_Interface (Etype (Defining_Identifier (C)))
+then
+null;
+elsif Field_Name /= Name_uTag then
+Evolve_Or_Else (Cond,
+Make_Op_Ne (Loc,
+Left_Opnd =>
+Make_Selected_Component (Loc,
+Prefix        => Make_Identifier (Loc, Name_X),
+Selector_Name => Make_Identifier (Loc, Field_Name)),
+Right_Opnd =>
+Make_Selected_Component (Loc,
+Prefix        => Make_Identifier (Loc, Name_Y),
+Selector_Name => Make_Identifier (Loc, Field_Name))));
+end if;
+Next_Non_Pragma (C);
+end loop;
+if No (Cond) then
+return Make_Null_Statement (Loc);
+else
+return
+Make_Implicit_If_Statement (E,
+Condition       => Cond,
+Then_Statements => New_List (
+Make_Simple_Return_Statement (Loc,
+Expression => New_Occurrence_Of (Standard_False, Loc))));
+end if;
+end if;
+end Make_Eq_If;
+-------------------
+-- Make_Neq_Body --
+-------------------
+function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
+function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
+--  Returns true if Prim is a renaming of an unresolved predefined
+--  inequality operation.
+--------------------------------
+-- Is_Predefined_Neq_Renaming --
+--------------------------------
+function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
+begin
+return Chars (Prim) /= Name_Op_Ne
+and then Present (Alias (Prim))
+and then Comes_From_Source (Prim)
+and then Is_Intrinsic_Subprogram (Alias (Prim))
+and then Chars (Alias (Prim)) = Name_Op_Ne;
+end Is_Predefined_Neq_Renaming;
+--  Local variables
+Loc           : constant Source_Ptr := Sloc (Parent (Tag_Typ));
+Stmts         : constant List_Id    := New_List;
+Decl          : Node_Id;
+Eq_Prim       : Entity_Id;
+Left_Op       : Entity_Id;
+Renaming_Prim : Entity_Id;
+Right_Op      : Entity_Id;
+Target        : Entity_Id;
+--  Start of processing for Make_Neq_Body
+begin
+--  For a call on a renaming of a dispatching subprogram that is
+--  overridden, if the overriding occurred before the renaming, then
+--  the body executed is that of the overriding declaration, even if the
+--  overriding declaration is not visible at the place of the renaming;
+--  otherwise, the inherited or predefined subprogram is called, see
+--  (RM 8.5.4(8))
+--  Stage 1: Search for a renaming of the inequality primitive and also
+--  search for an overriding of the equality primitive located before the
+--  renaming declaration.
+declare
+Elmt : Elmt_Id;
+Prim : Node_Id;
+begin
+Eq_Prim       := Empty;
+Renaming_Prim := Empty;
+Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+while Present (Elmt) loop
+Prim := Node (Elmt);
+if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then
+if No (Renaming_Prim) then
+pragma Assert (No (Eq_Prim));
+Eq_Prim := Prim;
+end if;
+elsif Is_Predefined_Neq_Renaming (Prim) then
+Renaming_Prim := Prim;
+end if;
+Next_Elmt (Elmt);
+end loop;
+end;
+--  No further action needed if no renaming was found
+if No (Renaming_Prim) then
+return Empty;
+end if;
+--  Stage 2: Replace the renaming declaration by a subprogram declaration
+--  (required to add its body)
+Decl := Parent (Parent (Renaming_Prim));
+Rewrite (Decl,
+Make_Subprogram_Declaration (Loc,
+Specification => Specification (Decl)));
+Set_Analyzed (Decl);
+--  Remove the decoration of intrinsic renaming subprogram
+Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
+Set_Convention (Renaming_Prim, Convention_Ada);
+Set_Alias (Renaming_Prim, Empty);
+Set_Has_Completion (Renaming_Prim, False);
+--  Stage 3: Build the corresponding body
+Left_Op  := First_Formal (Renaming_Prim);
+Right_Op := Next_Formal (Left_Op);
+Decl :=
+Predef_Spec_Or_Body (Loc,
+Tag_Typ => Tag_Typ,
+Name    => Chars (Renaming_Prim),
+Profile => New_List (
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Chars (Left_Op)),
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)),
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Chars (Right_Op)),
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc))),
+Ret_Type => Standard_Boolean,
+For_Body => True);
+--  If the overriding of the equality primitive occurred before the
+--  renaming, then generate:
+--    function <Neq_Name> (X : Y : Typ) return Boolean is
+--    begin
+--       return not Oeq (X, Y);
+--    end;
+if Present (Eq_Prim) then
+Target := Eq_Prim;
+--  Otherwise build a nested subprogram which performs the predefined
+--  evaluation of the equality operator. That is, generate:
+--    function <Neq_Name> (X : Y : Typ) return Boolean is
+--       function Oeq (X : Y) return Boolean is
+--       begin
+--          <<body of default implementation>>
+--       end;
+--    begin
+--       return not Oeq (X, Y);
+--    end;
+else
+declare
+Local_Subp : Node_Id;
+begin
+Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
+Set_Declarations (Decl, New_List (Local_Subp));
+Target := Defining_Entity (Local_Subp);
+end;
+end if;
+Append_To (Stmts,
+Make_Simple_Return_Statement (Loc,
+Expression =>
+Make_Op_Not (Loc,
+Make_Function_Call (Loc,
+Name                   => New_Occurrence_Of (Target, Loc),
+Parameter_Associations => New_List (
+Make_Identifier (Loc, Chars (Left_Op)),
+Make_Identifier (Loc, Chars (Right_Op)))))));
+Set_Handled_Statement_Sequence
+(Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+return Decl;
+end Make_Neq_Body;
+-------------------------------
+-- Make_Null_Procedure_Specs --
+-------------------------------
+function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
+Decl_List      : constant List_Id    := New_List;
+Loc            : constant Source_Ptr := Sloc (Tag_Typ);
+Formal         : Entity_Id;
+Formal_List    : List_Id;
+New_Param_Spec : Node_Id;
+Parent_Subp    : Entity_Id;
+Prim_Elmt      : Elmt_Id;
+Subp           : Entity_Id;
+begin
+Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+while Present (Prim_Elmt) loop
+Subp := Node (Prim_Elmt);
+--  If a null procedure inherited from an interface has not been
+--  overridden, then we build a null procedure declaration to
+--  override the inherited procedure.
+Parent_Subp := Alias (Subp);
+if Present (Parent_Subp)
+and then Is_Null_Interface_Primitive (Parent_Subp)
+then
+Formal_List := No_List;
+Formal := First_Formal (Subp);
+if Present (Formal) then
+Formal_List := New_List;
+while Present (Formal) loop
+--  Copy the parameter spec including default expressions
+New_Param_Spec :=
+New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
+--  Generate a new defining identifier for the new formal.
+--  required because New_Copy_Tree does not duplicate
+--  semantic fields (except itypes).
+Set_Defining_Identifier (New_Param_Spec,
+Make_Defining_Identifier (Sloc (Formal),
+Chars => Chars (Formal)));
+--  For controlling arguments we must change their
+--  parameter type to reference the tagged type (instead
+--  of the interface type)
+if Is_Controlling_Formal (Formal) then
+if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
+then
+Set_Parameter_Type (New_Param_Spec,
+New_Occurrence_Of (Tag_Typ, Loc));
+else pragma Assert
+(Nkind (Parameter_Type (Parent (Formal))) =
+N_Access_Definition);
+Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
+New_Occurrence_Of (Tag_Typ, Loc));
+end if;
+end if;
+Append (New_Param_Spec, Formal_List);
+Next_Formal (Formal);
+end loop;
+end if;
+Append_To (Decl_List,
+Make_Subprogram_Declaration (Loc,
+Make_Procedure_Specification (Loc,
+Defining_Unit_Name       =>
+Make_Defining_Identifier (Loc, Chars (Subp)),
+Parameter_Specifications => Formal_List,
+Null_Present             => True)));
+end if;
+Next_Elmt (Prim_Elmt);
+end loop;
+return Decl_List;
+end Make_Null_Procedure_Specs;
+-------------------------------------
+-- Make_Predefined_Primitive_Specs --
+-------------------------------------
+procedure Make_Predefined_Primitive_Specs
+(Tag_Typ     : Entity_Id;
+Predef_List : out List_Id;
+Renamed_Eq  : out Entity_Id)
+is
+function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
+--  Returns true if Prim is a renaming of an unresolved predefined
+--  equality operation.
+-------------------------------
+-- Is_Predefined_Eq_Renaming --
+-------------------------------
+function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
+begin
+return Chars (Prim) /= Name_Op_Eq
+and then Present (Alias (Prim))
+and then Comes_From_Source (Prim)
+and then Is_Intrinsic_Subprogram (Alias (Prim))
+and then Chars (Alias (Prim)) = Name_Op_Eq;
+end Is_Predefined_Eq_Renaming;
+--  Local variables
+Loc       : constant Source_Ptr := Sloc (Tag_Typ);
+Res       : constant List_Id    := New_List;
+Eq_Name   : Name_Id             := Name_Op_Eq;
+Eq_Needed : Boolean;
+Eq_Spec   : Node_Id;
+Prim      : Elmt_Id;
+Has_Predef_Eq_Renaming : Boolean := False;
+--  Set to True if Tag_Typ has a primitive that renames the predefined
+--  equality operator. Used to implement (RM 8-5-4(8)).
+--  Start of processing for Make_Predefined_Primitive_Specs
+begin
+Renamed_Eq := Empty;
+--  Spec of _Size
+Append_To (Res, Predef_Spec_Or_Body (Loc,
+Tag_Typ => Tag_Typ,
+Name    => Name_uSize,
+Profile => New_List (
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc))),
+Ret_Type => Standard_Long_Long_Integer));
+--  Specs for dispatching stream attributes
+declare
+Stream_Op_TSS_Names :
+constant array (Positive range <>) of TSS_Name_Type :=
+(TSS_Stream_Read,
+TSS_Stream_Write,
+TSS_Stream_Input,
+TSS_Stream_Output);
+begin
+for Op in Stream_Op_TSS_Names'Range loop
+if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
+Append_To (Res,
+Predef_Stream_Attr_Spec (Loc, Tag_Typ,
+Stream_Op_TSS_Names (Op)));
+end if;
+end loop;
+end;
+--  Spec of "=" is expanded if the type is not limited and if a user
+--  defined "=" was not already declared for the non-full view of a
+--  private extension
+if not Is_Limited_Type (Tag_Typ) then
+Eq_Needed := True;
+Prim := First_Elmt (Primitive_Operations (Tag_Typ));
+while Present (Prim) loop
+--  If a primitive is encountered that renames the predefined
+--  equality operator before reaching any explicit equality
+--  primitive, then we still need to create a predefined equality
+--  function, because calls to it can occur via the renaming. A
+--  new name is created for the equality to avoid conflicting with
+--  any user-defined equality. (Note that this doesn't account for
+--  renamings of equality nested within subpackages???)
+if Is_Predefined_Eq_Renaming (Node (Prim)) then
+Has_Predef_Eq_Renaming := True;
+Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
+--  User-defined equality
+elsif Is_User_Defined_Equality (Node (Prim)) then
+if No (Alias (Node (Prim)))
+or else Nkind (Unit_Declaration_Node (Node (Prim))) =
+N_Subprogram_Renaming_Declaration
+then
+Eq_Needed := False;
+exit;
+--  If the parent is not an interface type and has an abstract
+--  equality function explicitly defined in the sources, then
+--  the inherited equality is abstract as well, and no body can
+--  be created for it.
+elsif not Is_Interface (Etype (Tag_Typ))
+and then Present (Alias (Node (Prim)))
+and then Comes_From_Source (Alias (Node (Prim)))
+and then Is_Abstract_Subprogram (Alias (Node (Prim)))
+then
+Eq_Needed := False;
+exit;
+--  If the type has an equality function corresponding with
+--  a primitive defined in an interface type, the inherited
+--  equality is abstract as well, and no body can be created
+--  for it.
+elsif Present (Alias (Node (Prim)))
+and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
+and then
+Is_Interface
+(Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
+then
+Eq_Needed := False;
+exit;
+end if;
+end if;
+Next_Elmt (Prim);
+end loop;
+--  If a renaming of predefined equality was found but there was no
+--  user-defined equality (so Eq_Needed is still true), then set the
+--  name back to Name_Op_Eq. But in the case where a user-defined
+--  equality was located after such a renaming, then the predefined
+--  equality function is still needed, so Eq_Needed must be set back
+--  to True.
+if Eq_Name /= Name_Op_Eq then
+if Eq_Needed then
+Eq_Name := Name_Op_Eq;
+else
+Eq_Needed := True;
+end if;
+end if;
+if Eq_Needed then
+Eq_Spec := Predef_Spec_Or_Body (Loc,
+Tag_Typ => Tag_Typ,
+Name    => Eq_Name,
+Profile => New_List (
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Name_X),
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)),
+Make_Parameter_Specification (Loc,
+Defining_Identifier =>
+Make_Defining_Identifier (Loc, Name_Y),
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc))),
+Ret_Type => Standard_Boolean);
+Append_To (Res, Eq_Spec);
+if Has_Predef_Eq_Renaming then
+Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
+Prim := First_Elmt (Primitive_Operations (Tag_Typ));
+while Present (Prim) loop
+--  Any renamings of equality that appeared before an
+--  overriding equality must be updated to refer to the
+--  entity for the predefined equality, otherwise calls via
+--  the renaming would get incorrectly resolved to call the
+--  user-defined equality function.
+if Is_Predefined_Eq_Renaming (Node (Prim)) then
+Set_Alias (Node (Prim), Renamed_Eq);
+--  Exit upon encountering a user-defined equality
+elsif Chars (Node (Prim)) = Name_Op_Eq
+and then No (Alias (Node (Prim)))
+then
+exit;
+end if;
+Next_Elmt (Prim);
+end loop;
+end if;
+end if;
+--  Spec for dispatching assignment
+Append_To (Res, Predef_Spec_Or_Body (Loc,
+Tag_Typ => Tag_Typ,
+Name    => Name_uAssign,
+Profile => New_List (
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
+Out_Present         => True,
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)),
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)))));
+end if;
+--  Ada 2005: Generate declarations for the following primitive
+--  operations for limited interfaces and synchronized types that
+--  implement a limited interface.
+--    Disp_Asynchronous_Select
+--    Disp_Conditional_Select
+--    Disp_Get_Prim_Op_Kind
+--    Disp_Get_Task_Id
+--    Disp_Requeue
+--    Disp_Timed_Select
+--  Disable the generation of these bodies if No_Dispatching_Calls,
+--  Ravenscar or ZFP is active.
+if Ada_Version >= Ada_2005
+and then not Restriction_Active (No_Dispatching_Calls)
+and then not Restriction_Active (No_Select_Statements)
+and then RTE_Available (RE_Select_Specific_Data)
+then
+--  These primitives are defined abstract in interface types
+if Is_Interface (Tag_Typ)
+and then Is_Limited_Record (Tag_Typ)
+then
+Append_To (Res,
+Make_Abstract_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+Append_To (Res,
+Make_Abstract_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+Append_To (Res,
+Make_Abstract_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+Append_To (Res,
+Make_Abstract_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
+Append_To (Res,
+Make_Abstract_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Requeue_Spec (Tag_Typ)));
+Append_To (Res,
+Make_Abstract_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Timed_Select_Spec (Tag_Typ)));
+--  If ancestor is an interface type, declare non-abstract primitives
+--  to override the abstract primitives of the interface type.
+--  In VM targets we define these primitives in all root tagged types
+--  that are not interface types. Done because in VM targets we don't
+--  have secondary dispatch tables and any derivation of Tag_Typ may
+--  cover limited interfaces (which always have these primitives since
+--  they may be ancestors of synchronized interface types).
+elsif (not Is_Interface (Tag_Typ)
+and then Is_Interface (Etype (Tag_Typ))
+and then Is_Limited_Record (Etype (Tag_Typ)))
+or else
+(Is_Concurrent_Record_Type (Tag_Typ)
+and then Has_Interfaces (Tag_Typ))
+or else
+(not Tagged_Type_Expansion
+and then not Is_Interface (Tag_Typ)
+and then Tag_Typ = Root_Type (Tag_Typ))
+then
+Append_To (Res,
+Make_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+Append_To (Res,
+Make_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+Append_To (Res,
+Make_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+Append_To (Res,
+Make_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
+Append_To (Res,
+Make_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Requeue_Spec (Tag_Typ)));
+Append_To (Res,
+Make_Subprogram_Declaration (Loc,
+Specification =>
+Make_Disp_Timed_Select_Spec (Tag_Typ)));
+end if;
+end if;
+--  All tagged types receive their own Deep_Adjust and Deep_Finalize
+--  regardless of whether they are controlled or may contain controlled
+--  components.
+--  Do not generate the routines if finalization is disabled
+if Restriction_Active (No_Finalization) then
+null;
+else
+if not Is_Limited_Type (Tag_Typ) then
+Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
+end if;
+Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
+end if;
+Predef_List := Res;
+end Make_Predefined_Primitive_Specs;
+-------------------------
+-- Make_Tag_Assignment --
+-------------------------
+function Make_Tag_Assignment (N : Node_Id) return Node_Id is
+Loc      : constant Source_Ptr := Sloc (N);
+Def_If   : constant Entity_Id := Defining_Identifier (N);
+Expr     : constant Node_Id := Expression (N);
+Typ      : constant Entity_Id := Etype (Def_If);
+Full_Typ : constant Entity_Id := Underlying_Type (Typ);
+New_Ref  : Node_Id;
+begin
+--  This expansion activity is called during analysis, but cannot
+--  be applied in ASIS mode when other expansion is disabled.
+if Is_Tagged_Type (Typ)
+and then not Is_Class_Wide_Type (Typ)
+and then not Is_CPP_Class (Typ)
+and then Tagged_Type_Expansion
+and then Nkind (Expr) /= N_Aggregate
+and then not ASIS_Mode
+and then (Nkind (Expr) /= N_Qualified_Expression
+or else Nkind (Expression (Expr)) /= N_Aggregate)
+then
+New_Ref :=
+Make_Selected_Component (Loc,
+Prefix        => New_Occurrence_Of (Def_If, Loc),
+Selector_Name =>
+New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
+Set_Assignment_OK (New_Ref);
+return
+Make_Assignment_Statement (Loc,
+Name       => New_Ref,
+Expression =>
+Unchecked_Convert_To (RTE (RE_Tag),
+New_Occurrence_Of (Node
+(First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
+else
+return Empty;
+end if;
+end Make_Tag_Assignment;
+---------------------------------
+-- Needs_Simple_Initialization --
+---------------------------------
+function Needs_Simple_Initialization
+(T           : Entity_Id;
+Consider_IS : Boolean := True) return Boolean
+is
+Consider_IS_NS : constant Boolean :=
+Normalize_Scalars or (Initialize_Scalars and Consider_IS);
+begin
+--  Never need initialization if it is suppressed
+if Initialization_Suppressed (T) then
+return False;
+end if;
+--  Check for private type, in which case test applies to the underlying
+--  type of the private type.
+if Is_Private_Type (T) then
+declare
+RT : constant Entity_Id := Underlying_Type (T);
+begin
+if Present (RT) then
+return Needs_Simple_Initialization (RT);
+else
+return False;
+end if;
+end;
+--  Scalar type with Default_Value aspect requires initialization
+elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
+return True;
+--  Cases needing simple initialization are access types, and, if pragma
+--  Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
+--  types.
+elsif Is_Access_Type (T)
+or else (Consider_IS_NS and then (Is_Scalar_Type (T)))
+then
+return True;
+--  If Initialize/Normalize_Scalars is in effect, string objects also
+--  need initialization, unless they are created in the course of
+--  expanding an aggregate (since in the latter case they will be
+--  filled with appropriate initializing values before they are used).
+elsif Consider_IS_NS
+and then Is_Standard_String_Type (T)
+and then
+(not Is_Itype (T)
+or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
+then
+return True;
+else
+return False;
+end if;
+end Needs_Simple_Initialization;
+----------------------
+-- Predef_Deep_Spec --
+----------------------
+function Predef_Deep_Spec
+(Loc      : Source_Ptr;
+Tag_Typ  : Entity_Id;
+Name     : TSS_Name_Type;
+For_Body : Boolean := False) return Node_Id
+is
+Formals : List_Id;
+begin
+--  V : in out Tag_Typ
+Formals := New_List (
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
+In_Present          => True,
+Out_Present         => True,
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)));
+--  F : Boolean := True
+if Name = TSS_Deep_Adjust
+or else Name = TSS_Deep_Finalize
+then
+Append_To (Formals,
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
+Parameter_Type      => New_Occurrence_Of (Standard_Boolean, Loc),
+Expression          => New_Occurrence_Of (Standard_True, Loc)));
+end if;
+return
+Predef_Spec_Or_Body (Loc,
+Name     => Make_TSS_Name (Tag_Typ, Name),
+Tag_Typ  => Tag_Typ,
+Profile  => Formals,
+For_Body => For_Body);
+exception
+when RE_Not_Available =>
+return Empty;
+end Predef_Deep_Spec;
+-------------------------
+-- Predef_Spec_Or_Body --
+-------------------------
+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
+is
+Id   : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
+Spec : Node_Id;
+begin
+Set_Is_Public (Id, Is_Public (Tag_Typ));
+--  The internal flag is set to mark these declarations because they have
+--  specific properties. First, they are primitives even if they are not
+--  defined in the type scope (the freezing point is not necessarily in
+--  the same scope). Second, the predefined equality can be overridden by
+--  a user-defined equality, no body will be generated in this case.
+Set_Is_Internal (Id);
+if not Debug_Generated_Code then
+Set_Debug_Info_Off (Id);
+end if;
+if No (Ret_Type) then
+Spec :=
+Make_Procedure_Specification (Loc,
+Defining_Unit_Name       => Id,
+Parameter_Specifications => Profile);
+else
+Spec :=
+Make_Function_Specification (Loc,
+Defining_Unit_Name       => Id,
+Parameter_Specifications => Profile,
+Result_Definition        => New_Occurrence_Of (Ret_Type, Loc));
+end if;
+if Is_Interface (Tag_Typ) then
+return Make_Abstract_Subprogram_Declaration (Loc, Spec);
+--  If body case, return empty subprogram body. Note that this is ill-
+--  formed, because there is not even a null statement, and certainly not
+--  a return in the function case. The caller is expected to do surgery
+--  on the body to add the appropriate stuff.
+elsif For_Body then
+return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
+--  For the case of an Input attribute predefined for an abstract type,
+--  generate an abstract specification. This will never be called, but we
+--  need the slot allocated in the dispatching table so that attributes
+--  typ'Class'Input and typ'Class'Output will work properly.
+elsif Is_TSS (Name, TSS_Stream_Input)
+and then Is_Abstract_Type (Tag_Typ)
+then
+return Make_Abstract_Subprogram_Declaration (Loc, Spec);
+--  Normal spec case, where we return a subprogram declaration
+else
+return Make_Subprogram_Declaration (Loc, Spec);
+end if;
+end Predef_Spec_Or_Body;
+-----------------------------
+-- Predef_Stream_Attr_Spec --
+-----------------------------
+function Predef_Stream_Attr_Spec
+(Loc      : Source_Ptr;
+Tag_Typ  : Entity_Id;
+Name     : TSS_Name_Type;
+For_Body : Boolean := False) return Node_Id
+is
+Ret_Type : Entity_Id;
+begin
+if Name = TSS_Stream_Input then
+Ret_Type := Tag_Typ;
+else
+Ret_Type := Empty;
+end if;
+return
+Predef_Spec_Or_Body
+(Loc,
+Name     => Make_TSS_Name (Tag_Typ, Name),
+Tag_Typ  => Tag_Typ,
+Profile  => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
+Ret_Type => Ret_Type,
+For_Body => For_Body);
+end Predef_Stream_Attr_Spec;
+---------------------------------
+-- Predefined_Primitive_Bodies --
+---------------------------------
+function Predefined_Primitive_Bodies
+(Tag_Typ    : Entity_Id;
+Renamed_Eq : Entity_Id) return List_Id
+is
+Loc       : constant Source_Ptr := Sloc (Tag_Typ);
+Res       : constant List_Id    := New_List;
+Adj_Call  : Node_Id;
+Decl      : Node_Id;
+Fin_Call  : Node_Id;
+Prim      : Elmt_Id;
+Eq_Needed : Boolean;
+Eq_Name   : Name_Id;
+Ent       : Entity_Id;
+pragma Warnings (Off, Ent);
+begin
+pragma Assert (not Is_Interface (Tag_Typ));
+--  See if we have a predefined "=" operator
+if Present (Renamed_Eq) then
+Eq_Needed := True;
+Eq_Name   := Chars (Renamed_Eq);
+--  If the parent is an interface type then it has defined all the
+--  predefined primitives abstract and we need to check if the type
+--  has some user defined "=" function which matches the profile of
+--  the Ada predefined equality operator to avoid generating it.
+elsif Is_Interface (Etype (Tag_Typ)) then
+Eq_Needed := True;
+Eq_Name := Name_Op_Eq;
+Prim := First_Elmt (Primitive_Operations (Tag_Typ));
+while Present (Prim) loop
+if Chars (Node (Prim)) = Name_Op_Eq
+and then not Is_Internal (Node (Prim))
+and then Present (First_Entity (Node (Prim)))
+--  The predefined equality primitive must have exactly two
+--  formals whose type is this tagged type
+and then Present (Last_Entity (Node (Prim)))
+and then Next_Entity (First_Entity (Node (Prim)))
+= Last_Entity (Node (Prim))
+and then Etype (First_Entity (Node (Prim))) = Tag_Typ
+and then Etype (Last_Entity (Node (Prim))) = Tag_Typ
+then
+Eq_Needed := False;
+Eq_Name := No_Name;
+exit;
+end if;
+Next_Elmt (Prim);
+end loop;
+else
+Eq_Needed := False;
+Eq_Name   := No_Name;
+Prim := First_Elmt (Primitive_Operations (Tag_Typ));
+while Present (Prim) loop
+if Chars (Node (Prim)) = Name_Op_Eq
+and then Is_Internal (Node (Prim))
+then
+Eq_Needed := True;
+Eq_Name := Name_Op_Eq;
+exit;
+end if;
+Next_Elmt (Prim);
+end loop;
+end if;
+--  Body of _Size
+Decl := Predef_Spec_Or_Body (Loc,
+Tag_Typ => Tag_Typ,
+Name    => Name_uSize,
+Profile => New_List (
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc))),
+Ret_Type => Standard_Long_Long_Integer,
+For_Body => True);
+Set_Handled_Statement_Sequence (Decl,
+Make_Handled_Sequence_Of_Statements (Loc, New_List (
+Make_Simple_Return_Statement (Loc,
+Expression =>
+Make_Attribute_Reference (Loc,
+Prefix          => Make_Identifier (Loc, Name_X),
+Attribute_Name  => Name_Size)))));
+Append_To (Res, Decl);
+--  Bodies for Dispatching stream IO routines. We need these only for
+--  non-limited types (in the limited case there is no dispatching).
+--  We also skip them if dispatching or finalization are not available
+--  or if stream operations are prohibited by restriction No_Streams or
+--  from use of pragma/aspect No_Tagged_Streams.
+if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
+and then No (TSS (Tag_Typ, TSS_Stream_Read))
+then
+Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
+Append_To (Res, Decl);
+end if;
+if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
+and then No (TSS (Tag_Typ, TSS_Stream_Write))
+then
+Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
+Append_To (Res, Decl);
+end if;
+--  Skip body of _Input for the abstract case, since the corresponding
+--  spec is abstract (see Predef_Spec_Or_Body).
+if not Is_Abstract_Type (Tag_Typ)
+and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
+and then No (TSS (Tag_Typ, TSS_Stream_Input))
+then
+Build_Record_Or_Elementary_Input_Function
+(Loc, Tag_Typ, Decl, Ent);
+Append_To (Res, Decl);
+end if;
+if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
+and then No (TSS (Tag_Typ, TSS_Stream_Output))
+then
+Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
+Append_To (Res, Decl);
+end if;
+--  Ada 2005: Generate bodies for the following primitive operations for
+--  limited interfaces and synchronized types that implement a limited
+--  interface.
+--    disp_asynchronous_select
+--    disp_conditional_select
+--    disp_get_prim_op_kind
+--    disp_get_task_id
+--    disp_timed_select
+--  The interface versions will have null bodies
+--  Disable the generation of these bodies if No_Dispatching_Calls,
+--  Ravenscar or ZFP is active.
+--  In VM targets we define these primitives in all root tagged types
+--  that are not interface types. Done because in VM targets we don't
+--  have secondary dispatch tables and any derivation of Tag_Typ may
+--  cover limited interfaces (which always have these primitives since
+--  they may be ancestors of synchronized interface types).
+if Ada_Version >= Ada_2005
+and then not Is_Interface (Tag_Typ)
+and then
+((Is_Interface (Etype (Tag_Typ))
+and then Is_Limited_Record (Etype (Tag_Typ)))
+or else
+(Is_Concurrent_Record_Type (Tag_Typ)
+and then Has_Interfaces (Tag_Typ))
+or else
+(not Tagged_Type_Expansion
+and then Tag_Typ = Root_Type (Tag_Typ)))
+and then not Restriction_Active (No_Dispatching_Calls)
+and then not Restriction_Active (No_Select_Statements)
+and then RTE_Available (RE_Select_Specific_Data)
+then
+Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
+Append_To (Res, Make_Disp_Conditional_Select_Body  (Tag_Typ));
+Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body    (Tag_Typ));
+Append_To (Res, Make_Disp_Get_Task_Id_Body         (Tag_Typ));
+Append_To (Res, Make_Disp_Requeue_Body             (Tag_Typ));
+Append_To (Res, Make_Disp_Timed_Select_Body        (Tag_Typ));
+end if;
+if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then
+--  Body for equality
+if Eq_Needed then
+Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
+Append_To (Res, Decl);
+end if;
+--  Body for inequality (if required)
+Decl := Make_Neq_Body (Tag_Typ);
+if Present (Decl) then
+Append_To (Res, Decl);
+end if;
+--  Body for dispatching assignment
+Decl :=
+Predef_Spec_Or_Body (Loc,
+Tag_Typ => Tag_Typ,
+Name    => Name_uAssign,
+Profile => New_List (
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
+Out_Present         => True,
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)),
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
+Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc))),
+For_Body => True);
+Set_Handled_Statement_Sequence (Decl,
+Make_Handled_Sequence_Of_Statements (Loc, New_List (
+Make_Assignment_Statement (Loc,
+Name       => Make_Identifier (Loc, Name_X),
+Expression => Make_Identifier (Loc, Name_Y)))));
+Append_To (Res, Decl);
+end if;
+--  Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
+--  tagged types which do not contain controlled components.
+--  Do not generate the routines if finalization is disabled
+if Restriction_Active (No_Finalization) then
+null;
+elsif not Has_Controlled_Component (Tag_Typ) then
+if not Is_Limited_Type (Tag_Typ) then
+Adj_Call := Empty;
+Decl     := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
+if Is_Controlled (Tag_Typ) then
+Adj_Call :=
+Make_Adjust_Call (
+Obj_Ref => Make_Identifier (Loc, Name_V),
+Typ     => Tag_Typ);
+end if;
+if No (Adj_Call) then
+Adj_Call := Make_Null_Statement (Loc);
+end if;
+Set_Handled_Statement_Sequence (Decl,
+Make_Handled_Sequence_Of_Statements (Loc,
+Statements => New_List (Adj_Call)));
+Append_To (Res, Decl);
+end if;
+Fin_Call := Empty;
+Decl     := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
+if Is_Controlled (Tag_Typ) then
+Fin_Call :=
+Make_Final_Call
+(Obj_Ref => Make_Identifier (Loc, Name_V),
+Typ     => Tag_Typ);
+end if;
+if No (Fin_Call) then
+Fin_Call := Make_Null_Statement (Loc);
+end if;
+Set_Handled_Statement_Sequence (Decl,
+Make_Handled_Sequence_Of_Statements (Loc,
+Statements => New_List (Fin_Call)));
+Append_To (Res, Decl);
+end if;
+return Res;
+end Predefined_Primitive_Bodies;
+---------------------------------
+-- Predefined_Primitive_Freeze --
+---------------------------------
+function Predefined_Primitive_Freeze
+(Tag_Typ : Entity_Id) return List_Id
+is
+Res     : constant List_Id := New_List;
+Prim    : Elmt_Id;
+Frnodes : List_Id;
+begin
+Prim := First_Elmt (Primitive_Operations (Tag_Typ));
+while Present (Prim) loop
+if Is_Predefined_Dispatching_Operation (Node (Prim)) then
+Frnodes := Freeze_Entity (Node (Prim), Tag_Typ);
+if Present (Frnodes) then
+Append_List_To (Res, Frnodes);
+end if;
+end if;
+Next_Elmt (Prim);
+end loop;
+return Res;
+end Predefined_Primitive_Freeze;
+-------------------------
+-- Stream_Operation_OK --
+-------------------------
+function Stream_Operation_OK
+(Typ       : Entity_Id;
+Operation : TSS_Name_Type) return Boolean
+is
+Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
+begin
+--  Special case of a limited type extension: a default implementation
+--  of the stream attributes Read or Write exists if that attribute
+--  has been specified or is available for an ancestor type; a default
+--  implementation of the attribute Output (resp. Input) exists if the
+--  attribute has been specified or Write (resp. Read) is available for
+--  an ancestor type. The last condition only applies under Ada 2005.
+if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then
+if Operation = TSS_Stream_Read then
+Has_Predefined_Or_Specified_Stream_Attribute :=
+Has_Specified_Stream_Read (Typ);
+elsif Operation = TSS_Stream_Write then
+Has_Predefined_Or_Specified_Stream_Attribute :=
+Has_Specified_Stream_Write (Typ);
+elsif Operation = TSS_Stream_Input then
+Has_Predefined_Or_Specified_Stream_Attribute :=
+Has_Specified_Stream_Input (Typ)
+or else
+(Ada_Version >= Ada_2005
+and then Stream_Operation_OK (Typ, TSS_Stream_Read));
+elsif Operation = TSS_Stream_Output then
+Has_Predefined_Or_Specified_Stream_Attribute :=
+Has_Specified_Stream_Output (Typ)
+or else
+(Ada_Version >= Ada_2005
+and then Stream_Operation_OK (Typ, TSS_Stream_Write));
+end if;
+--  Case of inherited TSS_Stream_Read or TSS_Stream_Write
+if not Has_Predefined_Or_Specified_Stream_Attribute
+and then Is_Derived_Type (Typ)
+and then (Operation = TSS_Stream_Read
+or else Operation = TSS_Stream_Write)
+then
+Has_Predefined_Or_Specified_Stream_Attribute :=
+Present
+(Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
+end if;
+end if;
+--  If the type is not limited, or else is limited but the attribute is
+--  explicitly specified or is predefined for the type, then return True,
+--  unless other conditions prevail, such as restrictions prohibiting
+--  streams or dispatching operations. We also return True for limited
+--  interfaces, because they may be extended by nonlimited types and
+--  permit inheritance in this case (addresses cases where an abstract
+--  extension doesn't get 'Input declared, as per comments below, but
+--  'Class'Input must still be allowed). Note that attempts to apply
+--  stream attributes to a limited interface or its class-wide type
+--  (or limited extensions thereof) will still get properly rejected
+--  by Check_Stream_Attribute.
+--  We exclude the Input operation from being a predefined subprogram in
+--  the case where the associated type is an abstract extension, because
+--  the attribute is not callable in that case, per 13.13.2(49/2). Also,
+--  we don't want an abstract version created because types derived from
+--  the abstract type may not even have Input available (for example if
+--  derived from a private view of the abstract type that doesn't have
+--  a visible Input).
+--  Do not generate stream routines for type Finalization_Master because
+--  a master may never appear in types and therefore cannot be read or
+--  written.
+return
+(not Is_Limited_Type (Typ)
+or else Is_Interface (Typ)
+or else Has_Predefined_Or_Specified_Stream_Attribute)
+and then
+(Operation /= TSS_Stream_Input
+or else not Is_Abstract_Type (Typ)
+or else not Is_Derived_Type (Typ))
+and then not Has_Unknown_Discriminants (Typ)
+and then not
+(Is_Interface (Typ)
+and then
+(Is_Task_Interface (Typ)
+or else Is_Protected_Interface (Typ)
+or else Is_Synchronized_Interface (Typ)))
+and then not Restriction_Active (No_Streams)
+and then not Restriction_Active (No_Dispatch)
+and then No (No_Tagged_Streams_Pragma (Typ))
+and then not No_Run_Time_Mode
+and then RTE_Available (RE_Tag)
+and then No (Type_Without_Stream_Operation (Typ))
+and then RTE_Available (RE_Root_Stream_Type)
+and then not Is_RTE (Typ, RE_Finalization_Master);
+end Stream_Operation_OK;
+end Exp_Ch3;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/exp_ch3.adb @ 111:04ced10e8804