ada: Fix too small secondary stack allocation for returned conversion

[thirdparty/gcc.git] / gcc / ada / exp_ch3.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              E X P _ C H 3                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2023, 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 Accessibility;  use Accessibility;
with Aspects;        use Aspects;
with Atree;          use Atree;
with Checks;         use Checks;
with Contracts;      use Contracts;
with Einfo;          use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils;    use Einfo.Utils;
with Errout;         use Errout;
with Expander;       use Expander;
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_Put_Image;
with Exp_Smem;       use Exp_Smem;
with Exp_Strm;       use Exp_Strm;
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 Sinfo.Nodes;    use Sinfo.Nodes;
with Sinfo.Utils;    use Sinfo.Utils;
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.

   procedure Build_Discr_Checking_Funcs (N : Node_Id);
   --  For each variant component, builds a function which checks whether
   --  the component name is consistent with the current discriminants
   --  and sets the component's Dcheck_Function attribute to refer to it.
   --  N is the full type declaration node; the discriminant checking
   --  functions are inserted after this node.

   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 GCC 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 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 Copy_Discr_Checking_Funcs (N : Node_Id);
   --  For a derived untagged type, copy the attributes that were set
   --  for the components of the parent type onto the components of the
   --  derived type. No new subprograms are constructed.
   --  N is the full type declaration node, as for Build_Discr_Checking_Funcs.

   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.

   package Initialization_Control is

      function Requires_Late_Init
        (Decl : Node_Id; Rec_Type : Entity_Id) return Boolean;
      --  Return True iff the given component declaration requires late
      --  initialization, as defined by 3.3.1 (8.1/5).

      function Has_Late_Init_Component
        (Tagged_Rec_Type : Entity_Id) return Boolean;
      --  Return True iff the given tagged record type has at least one
      --  component that requires late initialization; this includes
      --  components of ancestor types.

      type Initialization_Mode is
        (Full_Init, Full_Init_Except_Tag, Early_Init_Only, Late_Init_Only);
      --  The initialization routine for a tagged type is passed in a
      --  formal parameter of this type, indicating what initialization
      --  is to be performed. This parameter defaults to Full_Init in all
      --  cases except when the init proc of a type extension (let's call
      --  that type T2) calls the init proc of its parent (let's call that
      --  type T1). In that case, one of the other 3 values will
      --  be passed in. In all three of those cases, the Tag component has
      --  already been initialized before the call and is therefore not to be
      --  modified. T2's init proc will either call T1's init proc
      --  once (with Full_Init_Except_Tag as the parameter value) or twice
      --  (first with Early_Init_Only, then later with Late_Init_Only),
      --  depending on the result returned by Has_Late_Init_Component (T1).
      --  In the latter case, the first call does not initialize any
      --  components that require late initialization and the second call
      --  then performs that deferred initialization.
      --  Strictly speaking, the formal parameter subtype is actually Natural
      --  but calls will only pass in values corresponding to literals
      --  of this enumeration type.

      function Make_Mode_Literal
        (Loc : Source_Ptr; Mode : Initialization_Mode) return Node_Id
      is (Make_Integer_Literal (Loc, Initialization_Mode'Pos (Mode)));
      --  Generate an integer literal for a given mode value.

      function Tag_Init_Condition
        (Loc : Source_Ptr;
         Init_Control_Formal : Entity_Id) return Node_Id;
      function Early_Init_Condition
        (Loc : Source_Ptr;
         Init_Control_Formal : Entity_Id) return Node_Id;
      function Late_Init_Condition
        (Loc : Source_Ptr;
         Init_Control_Formal : Entity_Id) return Node_Id;
      --  These three functions each return a Boolean expression that
      --  can be used to determine whether a given call to the initialization
      --  expression for a tagged type should initialize (respectively)
      --  the Tag component, the non-Tag components that do not require late
      --  initialization, and the components that do require late
      --  initialization.

   end Initialization_Control;

   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; Proc_Id : 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 and Proc_Id is decorated with attribute Has_Master_Entity:
   --
   --    _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_Null_Statement_List (Stmts : List_Id) return Boolean;
   --  Returns true if Stmts is made of null statements only, possibly wrapped
   --  in a case statement, recursively. This latter pattern may occur for the
   --  initialization procedure of an unchecked union.

   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
   --     typPI          provides result of 'Put_Image 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 of specs is returned in Predef_List

   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.

   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) 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.

   --------------------------
   -- 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_Access_Subprogram_Wrapper_Body --
   ------------------------------------------

   procedure Build_Access_Subprogram_Wrapper_Body
     (Decl     : Node_Id;
      New_Decl : Node_Id)
   is
      Loc       : constant Source_Ptr := Sloc (Decl);
      Actuals   : constant List_Id    := New_List;
      Type_Def  : constant Node_Id    := Type_Definition (Decl);
      Type_Id   : constant Entity_Id  := Defining_Identifier (Decl);
      Spec_Node : constant Node_Id    :=
                    Copy_Subprogram_Spec (Specification (New_Decl));
      --  This copy creates new identifiers for formals and subprogram.

      Act       : Node_Id;
      Body_Node : Node_Id;
      Call_Stmt : Node_Id;
      Ptr       : Entity_Id;

   begin
      --  Create List of actuals for indirect call. The last parameter of the
      --  subprogram declaration is the access value for the indirect call.

      Act := First (Parameter_Specifications (Spec_Node));

      while Present (Act) loop
         exit when Act = Last (Parameter_Specifications (Spec_Node));
         Append_To (Actuals,
           Make_Identifier (Loc, Chars (Defining_Identifier (Act))));
         Next (Act);
      end loop;

      Ptr :=
        Defining_Identifier
          (Last (Parameter_Specifications (Specification (New_Decl))));

      if Nkind (Type_Def) = N_Access_Procedure_Definition then
         Call_Stmt := Make_Procedure_Call_Statement (Loc,
           Name =>
              Make_Explicit_Dereference
                (Loc, New_Occurrence_Of (Ptr, Loc)),
           Parameter_Associations => Actuals);
      else
         Call_Stmt := Make_Simple_Return_Statement (Loc,
           Expression =>
             Make_Function_Call (Loc,
           Name => Make_Explicit_Dereference
                    (Loc, New_Occurrence_Of (Ptr, Loc)),
           Parameter_Associations => Actuals));
      end if;

      Body_Node := Make_Subprogram_Body (Loc,
        Specification => Spec_Node,
        Declarations  => New_List,
        Handled_Statement_Sequence =>
          Make_Handled_Sequence_Of_Statements (Loc,
            Statements    => New_List (Call_Stmt)));

      --  Place body in list of freeze actions for the type.

      Append_Freeze_Action (Type_Id, Body_Node);
   end Build_Access_Subprogram_Wrapper_Body;

   ---------------------------
   -- 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
          (Typ         => 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;
      Parameters       : List_Id;
      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
                    (Typ  => Comp_Type,
                     N    => Nod,
                     Size => Component_Size (A_Type))));

         else
            Clean_Task_Names (Comp_Type, Proc_Id);
            return
              Build_Initialization_Call
                (Loc          => Loc,
                 Id_Ref       => Comp,
                 Typ          => 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;
         DIC_Call    : Node_Id;
         Result_List : List_Id;

         function Possible_DIC_Call return Node_Id;
         --  If the component type has Default_Initial_Conditions and a DIC
         --  procedure that is not an empty body, then builds a call to the
         --  DIC procedure and returns it.

         -----------------------
         -- Possible_DIC_Call --
         -----------------------

         function Possible_DIC_Call return Node_Id is
         begin
            --  When the component's type has a Default_Initial_Condition, then
            --  create a call for the DIC check.

            if Has_DIC (Comp_Type)
              --  In GNATprove mode, the component DICs are checked by other
              --  means. They should not be added to the record type DIC
              --  procedure, so that the procedure can be used to check the
              --  record type invariants or DICs if any.

              and then not GNATprove_Mode

              --  DIC checks for components of controlled types are done later
              --  (see Exp_Ch7.Make_Deep_Array_Body).

              and then not Is_Controlled (Comp_Type)

              and then Present (DIC_Procedure (Comp_Type))

              and then not Has_Null_Body (DIC_Procedure (Comp_Type))
            then
               return
                 Build_DIC_Call (Loc,
                   Make_Indexed_Component (Loc,
                     Prefix      => Make_Identifier (Loc, Name_uInit),
                     Expressions => Index_List),
                   Comp_Type);
            else
               return Empty;
            end if;
         end Possible_DIC_Call;

      --  Start of processing for Init_One_Dimension

      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.
         --  An exception is if component type has a Default_Initial_Condition,
         --  in which case we generate a call to the type's DIC procedure.

         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)
           and then (not Has_DIC (Comp_Type)
                      or else N > Number_Dimensions (A_Type))
         then
            DIC_Call := Possible_DIC_Call;

            if Present (DIC_Call) then
               return New_List (DIC_Call);
            else
               return New_List (Make_Null_Statement (Loc));
            end if;

         --  If all dimensions dealt with, we simply initialize the component
         --  and append a call to component type's DIC procedure when needed.

         elsif N > Number_Dimensions (A_Type) then
            DIC_Call := Possible_DIC_Call;

            if Present (DIC_Call) then
               Result_List := Init_Component;
               Append (DIC_Call, Result_List);
               return Result_List;

            else
               return Init_Component;
            end if;

         --  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
      --    6. The array component type has a Default_Initialization_Condition

      --  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)
                            or else Has_DIC (Comp_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);
         Parameters := Init_Formals (A_Type, Proc_Id);

         Discard_Node (
           Make_Subprogram_Body (Loc,
             Specification =>
               Make_Procedure_Specification (Loc,
                 Defining_Unit_Name => Proc_Id,
                 Parameter_Specifications => Parameters),
             Declarations => New_List,
             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc,
                 Statements => Body_Stmts)));

         Mutate_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. Kill also warnings for the _Init
         --  out parameter, which is left entirely uninitialized.

         Set_Init_Proc (A_Type, Proc_Id);

         if Is_Null_Statement_List (Body_Stmts) then
            Set_Is_Null_Init_Proc (Proc_Id);
            Set_Warnings_Off (Defining_Identifier (First (Parameters)));

         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 to the discrete choices given on the variant
      --  that 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 returns 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);
         Set_End_Span (Case_Node, Uint_0);

         --  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))));

         Mutate_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_Or_Copy_Discr_Checking_Funcs --
   ----------------------------------------

   procedure Build_Or_Copy_Discr_Checking_Funcs (N : Node_Id) is
      Typ : constant Entity_Id := Defining_Identifier (N);
   begin
      if Is_Unchecked_Union (Typ) or else not Has_Discriminants (Typ) then
         null;
      elsif not Is_Derived_Type (Typ)
        or else Has_New_Non_Standard_Rep (Typ)
        or else Is_Tagged_Type (Typ)
      then
         Build_Discr_Checking_Funcs (N);
      else
         Copy_Discr_Checking_Funcs (N);
      end if;
   end Build_Or_Copy_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;

   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;

               --  We need to return empty if the type has predicates because
               --  this would otherwise duplicate calls to the predicate
               --  function. If the type hasn't been frozen before being
               --  referenced in the current record, the extraneous call to
               --  the predicate function would be inserted somewhere before
               --  the predicate function is elaborated, which would result in
               --  an invalid tree.

            elsif Has_Predicates (Etype (Comp)) then
               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;

   ----------------------------
   -- Init_Proc_Level_Formal --
   ----------------------------

   function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id is
      Form : Entity_Id;
   begin
      --  Move through the formals of the initialization procedure Proc to find
      --  the extra accessibility level parameter associated with the object
      --  being initialized.

      Form := First_Formal (Proc);
      while Present (Form) loop
         if Chars (Form) = Name_uInit_Level then
            return Form;
         end if;

         Next_Formal (Form);
      end loop;

      --  No formal was found, return Empty

      return Empty;
   end Init_Proc_Level_Formal;

   -------------------------------
   -- 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;
      Init_Control_Actual : Entity_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 that a given variant and its nested variants have an others
         --  choice, and generate a constraint error raise when it does not.

         --------------------------
         -- 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, Make_Integer_Literal (Loc, Library_Task_Level));
         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;

      --  Handle the optionally generated formal *_skip_null_excluding_checks

      --  Look at the associated node for the object we are referencing and
      --  verify that we are expanding a call to an Init_Proc for an internally
      --  generated object declaration before passing True and skipping the
      --  relevant checks.

      if Needs_Conditional_Null_Excluding_Check (Full_Init_Type)
        and then Nkind (Id_Ref) in N_Has_Entity
        and then (Comes_From_Source (Id_Ref)
                   or else (Present (Associated_Node (Id_Ref))
                             and then Comes_From_Source
                                        (Associated_Node (Id_Ref))))
      then
         Append_To (Args, New_Occurrence_Of (Standard_True, Loc));
      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.
      --  This is done via the actual parameter value for the Init_Control
      --  formal parameter, which is also used to deal with late initialization
      --  requirements.
      --
      --  We pass in Full_Init_Except_Tag unless the caller tells us to do
      --  otherwise (by passing in a nonempty Init_Control_Actual parameter).

      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
         declare
            use Initialization_Control;
         begin
            Append_To (Args,
              (if Present (Init_Control_Actual)
               then Init_Control_Actual
               else Make_Mode_Literal (Loc, Full_Init_Except_Tag)));
         end;
      elsif Present (Constructor_Ref) then
         Append_List_To (Args,
           New_Copy_List (Parameter_Associations (Constructor_Ref)));
      end if;

      --  Pass the extra accessibility level parameter associated with the
      --  level of the object being initialized when required.

      if Is_Entity_Name (Id_Ref)
        and then Present (Init_Proc_Level_Formal (Proc))
      then
         Append_To (Args,
           Make_Parameter_Association (Loc,
             Selector_Name             =>
               Make_Identifier (Loc, Name_uInit_Level),
             Explicit_Actual_Parameter =>
               Accessibility_Level (Id_Ref, Dynamic_Level)));
      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;

      Init_Control_Formal : Entity_Id := Empty; -- set in Build_Init_Statements
      Has_Late_Init_Comp  : Boolean := False;   -- set in Build_Init_Statements

      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;
         Exp_Q    : Node_Id;
         Lhs      : Node_Id;
         Res      : List_Id;

      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);

         --  Take copy of Default 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.

         declare
            Map : Elist_Id := No_Elist;

         begin
            if Has_Late_Init_Comp then
               --  Map the type to the _Init parameter in order to
               --  handle "current instance" references.

               Map := New_Elmt_List
                        (Elmt1 => Rec_Type,
                         Elmt2 => Defining_Identifier (First
                                   (Parameter_Specifications
                                      (Parent (Proc_Id)))));

               --  If the type has an incomplete view, a current instance
               --  may have an incomplete type. In that case, it must also be
               --  replaced by the formal of the Init_Proc.

               if Nkind (Parent (Rec_Type)) = N_Full_Type_Declaration
                 and then Present (Incomplete_View (Parent (Rec_Type)))
               then
                  Append_Elmt (
                    N  => Incomplete_View (Parent (Rec_Type)),
                    To => Map);
                  Append_Elmt (
                    N  => Defining_Identifier
                            (First
                              (Parameter_Specifications
                                (Parent (Proc_Id)))),
                    To => Map);
               end if;
            end if;

            Exp := New_Copy_Tree (Default, New_Scope => Proc_Id, Map => Map);
         end;

         Res := New_List (
           Make_Assignment_Statement (Loc,
             Name       => Lhs,
             Expression => Exp));

         Set_No_Ctrl_Actions (First (Res));

         Exp_Q := Unqualify (Exp);

         --  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, and when the record is
         --  initialized with a raise expression.

         if Is_Tagged_Type (Typ)
           and then Tagged_Type_Expansion
           and then Nkind (Exp_Q) /= N_Raise_Expression
         then
            Append_To (Res,
              Make_Tag_Assignment_From_Type
                (Default_Loc,
                 New_Copy_Tree (Lhs, New_Scope => Proc_Id),
                 Underlying_Type (Typ)));
         end if;

         --  Adjust the component if controlled except if it is an aggregate
         --  that will be expanded inline.

         if Needs_Finalization (Typ)
           and then Nkind (Exp_Q) not in 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;

         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, Make_Integer_Literal (Loc, Library_Task_Level));
            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_Op_Minus (Loc,
                        Make_Attribute_Reference (Loc,
                          Prefix         =>
                            Make_Selected_Component (Loc,
                              Prefix        =>
                                Make_Explicit_Dereference (Loc,
                                  Unchecked_Convert_To (Acc_Type,
                                    Make_Identifier (Loc, Name_uO))),
                              Selector_Name =>
                                New_Occurrence_Of (Iface_Comp, Loc)),
                          Attribute_Name => Name_Position))))));

            Mutate_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));

         Mutate_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;

         use Initialization_Control;
      begin
         Body_Stmts := New_List;
         Body_Node := New_Node (N_Subprogram_Body, Loc);
         Mutate_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, Proc_Id);
         Append_List_To (Parameters,
           Build_Discriminant_Formals (Rec_Type, True));

         --  For tagged types, we add a parameter to indicate what
         --  portion of the object's initialization is to be performed.
         --  This is used for two purposes:
         --   1)  When a type extension's initialization procedure calls
         --       the initialization procedure of the parent type, we do
         --       not want the parent to initialize the Tag component;
         --       it has been set already.
         --   2)  If an ancestor type has at least one component that requires
         --       late initialization, then we need to be able to initialize
         --       those components separately after initializing any other
         --       components.

         if Is_Tagged_Type (Rec_Type) then
            Init_Control_Formal := Make_Temporary (Loc, 'P');

            Append_To (Parameters,
              Make_Parameter_Specification (Loc,
                Defining_Identifier => Init_Control_Formal,
                Parameter_Type =>
                  New_Occurrence_Of (Standard_Natural, Loc),
                Expression => Make_Mode_Literal (Loc, Full_Init)));
         end if;

         --  Create an extra accessibility parameter to capture the level of
         --  the object being initialized when its type is a limited record.

         if Is_Limited_Record (Rec_Type) then
            Append_To (Parameters,
              Make_Parameter_Specification (Loc,
                Defining_Identifier => Make_Defining_Identifier
                                         (Loc, Name_uInit_Level),
                Parameter_Type      =>
                  New_Occurrence_Of (Standard_Natural, Loc),
                Expression          =>
                  Make_Integer_Literal
                    (Loc, Scope_Depth (Standard_Standard))));
         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 := First (Stmts);
                        IP_Call   : Node_Id := Empty;
                     begin
                        --  Look for a call to the parent IP associated with
                        --  the record extension.
                        --  The call will be inside not one but two
                        --  if-statements (with the same condition). Testing
                        --  the same Early_Init condition twice might seem
                        --  redundant. However, as soon as we exit this loop,
                        --  we are going to hoist the inner if-statement out
                        --  of the outer one; the "redundant" test was built
                        --  in anticipation of this hoisting.

                        while Present (Stmt) loop
                           if Nkind (Stmt) = N_If_Statement then
                              declare
                                 Then_Stmt1 : Node_Id :=
                                   First (Then_Statements (Stmt));
                                 Then_Stmt2 : Node_Id;
                              begin
                                 while Present (Then_Stmt1) loop
                                    if Nkind (Then_Stmt1) = N_If_Statement then
                                       Then_Stmt2 :=
                                         First (Then_Statements (Then_Stmt1));

                                       if Nkind (Then_Stmt2) =
                                            N_Procedure_Call_Statement
                                         and then Chars (Name (Then_Stmt2)) =
                                           Parent_IP
                                       then
                                          --  IP_Call is a call wrapped in an
                                          --  if statement.
                                          IP_Call := Then_Stmt1;
                                          exit;
                                       end if;
                                    end if;
                                    Next (Then_Stmt1);
                                 end loop;
                              end;
                           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
                           Remove (IP_Call);
                           Prepend_List_To (Body_Stmts, New_List (IP_Call));
                        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_Tag_Assignment_From_Type
                   (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type));

               --  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;
                     Elab_List              : 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);

                     Elab_List := New_List (
                       Make_If_Statement (Loc,
                         Condition       =>
                           Tag_Init_Condition (Loc, Init_Control_Formal),
                         Then_Statements => Init_Tags_List));

                     if Elab_Flag_Needed (Rec_Type) then
                        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)));

                        Append_To (Elab_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 if;

                     Prepend_List_To (Body_Stmts, Elab_List);
                  end;
               else
                  Prepend_To (Body_Stmts,
                    Make_If_Statement (Loc,
                      Condition =>
                        Tag_Init_Condition (Loc, Init_Control_Formal),
                      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_Tag_Assignment_From_Type
                   (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type));

               --  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.
                  --  It is wrapped in an "if Early_Init_Condition"
                  --  if-statement.

                  Ins_Nod := First (Body_Stmts);
                  while Present (Next (Ins_Nod))
                    and then
                      (Nkind (Ins_Nod) /= N_If_Statement
                        or else Nkind (First (Then_Statements (Ins_Nod)))
                                  /= N_Procedure_Call_Statement
                        or else not Is_Init_Proc
                                      (Name (First (Then_Statements
                                         (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);

               Append_List_To (Body_Stmts, Init_Tags_List);
            end if;
         end if;

         Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
         Set_Statements (Handled_Stmt_Node, Body_Stmts);

         --  Generate:
         --    Deep_Finalize (_init, C1, ..., CN);
         --    raise;

         if Counter > 0
           and then Needs_Finalization (Rec_Type)
           and then not Is_Abstract_Type (Rec_Type)
           and then not Restriction_Active (No_Exception_Propagation)
         then
            declare
               DF_Call : Node_Id;
               DF_Id   : Entity_Id;

            begin
               --  Create a local version of Deep_Finalize which has indication
               --  of partial initialization state.

               DF_Id :=
                 Make_Defining_Identifier (Loc,
                   Chars => New_External_Name (Name_uFinalizer));

               Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));

               DF_Call :=
                 Make_Procedure_Call_Statement (Loc,
                   Name                   => New_Occurrence_Of (DF_Id, Loc),
                   Parameter_Associations => New_List (
                     Make_Identifier (Loc, Name_uInit),
                     New_Occurrence_Of (Standard_False, Loc)));

               --  Do not emit warnings related to the elaboration order when a
               --  controlled object is declared before the body of Finalize is
               --  seen.

               if Legacy_Elaboration_Checks then
                  Set_No_Elaboration_Check (DF_Call);
               end if;

               Set_Exception_Handlers (Handled_Stmt_Node, New_List (
                 Make_Exception_Handler (Loc,
                   Exception_Choices => New_List (
                     Make_Others_Choice (Loc)),
                   Statements        => New_List (
                     DF_Call,
                     Make_Raise_Statement (Loc)))));
            end;
         else
            Set_Exception_Handlers (Handled_Stmt_Node, No_List);
         end if;

         Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);

         if not Debug_Generated_Code then
            Set_Debug_Info_Off (Proc_Id);
         end if;

         --  Associate Init_Proc with type, and determine if the procedure
         --  is null (happens because of the Initialize_Scalars pragma case,
         --  where we have to generate a null procedure in case it is called
         --  by a client with Initialize_Scalars set). Such procedures have
         --  to be generated, but do not have to be called, so we mark them
         --  as null to suppress the call. Kill also warnings for the _Init
         --  out parameter, which is left entirely uninitialized.

         Set_Init_Proc (Rec_Type, Proc_Id);

         if Is_Null_Statement_List (Body_Stmts) then
            Set_Is_Null_Init_Proc (Proc_Id);
            Set_Warnings_Off (Defining_Identifier (First (Parameters)));
         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;
         Id                 : Entity_Id;
         Parent_Stmts       : List_Id;
         Parent_Id          : Entity_Id := Empty;
         Stmts, Late_Stmts  : List_Id := Empty_List;
         Typ                : Entity_Id;

         procedure Increment_Counter
           (Loc  : Source_Ptr; Late : Boolean := False);
         --  Generate an "increment by one" statement for the current counter
         --  and append it to the appropriate statement list.

         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; Late : Boolean := False) is
         begin
            --  Generate:
            --    Counter := Counter + 1;

            Append_To ((if Late then Late_Stmts else 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_Concurrent_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 require late initialization.

         --  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 component requiring late initialization
            --  for the second pass.

            if Initialization_Control.Requires_Late_Init (Decl, Rec_Type) then
               if not Has_Late_Init_Comp then
                  Late_Stmts := New_List;
               end if;
               Has_Late_Init_Comp := 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 Chars (Id) in 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 :=
                             Get_Pragma_Arg
                               (First (Pragma_Argument_Associations (Ritem)));

                           --  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
                  declare
                     use Initialization_Control;
                     Init_Control_Actual : Node_Id := Empty;
                     Is_Parent : constant Boolean := Chars (Id) = Name_uParent;
                     Init_Call_Stmts : List_Id;
                  begin
                     if Is_Parent and then Has_Late_Init_Component (Etype (Id))
                     then
                        Init_Control_Actual :=
                          Make_Mode_Literal (Comp_Loc, Early_Init_Only);
                        --  Parent_Id used later in second call to parent's
                        --  init proc to initialize late-init components.
                        Parent_Id := Id;
                     end if;

                     Init_Call_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,
                          Init_Control_Actual => Init_Control_Actual);

                     if Is_Parent then
                        --  This is tricky. At first it looks like
                        --  we are going to end up with nested
                        --  if-statements with the same condition:
                        --    if Early_Init_Condition then
                        --       if Early_Init_Condition then
                        --          Parent_TypeIP (...);
                        --       end if;
                        --    end if;
                        --  But later we will hoist the inner if-statement
                        --  out of the outer one; we do this  because the
                        --  init-proc call for the _Parent component of a type
                        --  extension has to precede any other initialization.
                        Actions :=
                          New_List (Make_If_Statement (Loc,
                            Condition =>
                              Early_Init_Condition (Loc, Init_Control_Formal),
                            Then_Statements => Init_Call_Stmts));
                     else
                        Actions := Init_Call_Stmts;
                     end if;
                  end;

                  Clean_Task_Names (Typ, Proc_Id);

               --  Simple initialization. If the Esize is not yet set, we pass
               --  Uint_0 as expected by Get_Simple_Init_Val.

               elsif Component_Needs_Simple_Initialization (Typ) then
                  Actions :=
                    Build_Assignment
                      (Id      => Id,
                       Default =>
                         Get_Simple_Init_Val
                           (Typ  => Typ,
                            N    => N,
                            Size =>
                              (if Known_Esize (Id) then Esize (Id)
                               else Uint_0)));

               --  Nothing needed for this case

               else
                  Actions := No_List;
               end if;

               --  When the component's type has a Default_Initial_Condition,
               --  and the component is default initialized, then check the
               --  DIC here.

               if Has_DIC (Typ)
                 and then No (Expression (Decl))
                 and then Present (DIC_Procedure (Typ))
                 and then not Has_Null_Body (DIC_Procedure (Typ))

                 --  The DICs of ancestors are checked as part of the type's
                 --  DIC procedure.

                 and then Chars (Id) /= Name_uParent

                 --  In GNATprove mode, the component DICs are checked by other
                 --  means. They should not be added to the record type DIC
                 --  procedure, so that the procedure can be used to check the
                 --  record type invariants or DICs if any.

                 and then not GNATprove_Mode
               then
                  Append_New_To (Actions,
                     Build_DIC_Call
                       (Comp_Loc,
                        Make_Selected_Component (Comp_Loc,
                          Prefix        =>
                            Make_Identifier (Comp_Loc, Name_uInit),
                          Selector_Name =>
                            New_Occurrence_Of (Id, Comp_Loc)),
                        Typ));
               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;

         --  For a protected type, add statements generated by
         --  Make_Initialize_Protection.

         elsif Is_Protected_Record_Type (Rec_Type) then
            Append_List_To (Stmts,
              Make_Initialize_Protection (Rec_Type));
         end if;

         --  Second pass: components that require late initialization

         if Present (Parent_Id) then
            declare
               Parent_Loc : constant Source_Ptr := Sloc (Parent (Parent_Id));
               use Initialization_Control;
            begin
               --  We are building the init proc for a type extension.
               --  Call the parent type's init proc a second time, this
               --  time to initialize the parent's components that require
               --  late initialization.

               Append_List_To (Late_Stmts,
                 Build_Initialization_Call
                   (Loc                  => Parent_Loc,
                    Id_Ref               =>
                      Make_Selected_Component (Parent_Loc,
                        Prefix        => Make_Identifier
                                           (Parent_Loc, Name_uInit),
                        Selector_Name => New_Occurrence_Of (Parent_Id,
                                                            Parent_Loc)),
                    Typ                 => Etype (Parent_Id),
                    In_Init_Proc        => True,
                    Enclos_Type         => Rec_Type,
                    Discr_Map           => Discr_Map,
                    Init_Control_Actual => Make_Mode_Literal
                                             (Parent_Loc, Late_Init_Only)));
            end;
         end if;

         if Has_Late_Init_Comp 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 Initialization_Control.Requires_Late_Init (Decl, Rec_Type)
               then
                  if Present (Expression (Decl)) then
                     Append_List_To (Late_Stmts,
                       Build_Assignment (Id, Expression (Decl)));

                  elsif Has_Non_Null_Base_Init_Proc (Typ) then
                     Append_List_To (Late_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, Late => True);
                     end if;
                  elsif Component_Needs_Simple_Initialization (Typ) then
                     Append_List_To (Late_Stmts,
                       Build_Assignment
                         (Id      => Id,
                          Default =>
                            Get_Simple_Init_Val
                              (Typ  => Typ,
                               N    => N,
                               Size => Esize (Id))));
                  end if;
               end if;

               Next_Non_Pragma (Decl);
            end loop;
         end if;

         --  Process the variant part (incorrectly ignoring late
         --  initialization requirements for components therein).

         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 (Init_Control_Formal) then
            Append_List_To (Stmts, Late_Stmts);

            --  If no initializations were generated for component declarations
            --  and included in Stmts, then append a null statement to Stmts
            --  to make it a valid Ada tree.

            if Is_Empty_List (Stmts) then
               Append (Make_Null_Statement (Loc), Stmts);
            end if;

            return Stmts;
         else
            declare
               use Initialization_Control;

               If_Early : constant Node_Id :=
                  (if Is_Empty_List (Stmts) then
                      Make_Null_Statement (Loc)
                   else
                      Make_If_Statement (Loc,
                        Condition =>
                          Early_Init_Condition (Loc, Init_Control_Formal),
                        Then_Statements => Stmts));
               If_Late : constant Node_Id :=
                  (if Is_Empty_List (Late_Stmts) then
                      Make_Null_Statement (Loc)
                   else
                      Make_If_Statement (Loc,
                        Condition =>
                          Late_Init_Condition (Loc, Init_Control_Formal),
                        Then_Statements => Late_Stmts));
            begin
               return New_List (If_Early, If_Late);
            end;
         end if;
      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 Present (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 array_typeSA
   --     (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 array_typeSA;

   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;

      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;
      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
         Op : constant Entity_Id := TSS (T, TSS_Composite_Equality);

      begin
         if Present (Op) then
            return Op;
         else
            return Get_User_Defined_Equality (T);
         end if;
      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;
            exit;
         end if;

         Next_Component (Comp);
      end loop;

      --  If there is a user-defined equality for the type, we do not create
      --  the implicit one.

      Eq_Op := Get_User_Defined_Equality (Typ);
      if Present (Eq_Op) then
         if Comes_From_Source (Eq_Op) then
            Build_Eq := False;
         else
            Eq_Op := Empty;
         end if;
      end if;

      --  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
         Eq_Op := Get_User_Defined_Equality (Etype (Typ));
         if Present (Eq_Op) then
            Copy_TSS (Eq_Op, Typ);
            Build_Eq := False;

            declare
               Op    : constant Entity_Id := User_Defined_Eq (Typ);
               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;
         end if;
      end if;

      --  If not inherited and not user-defined, build body as for a type with
      --  components of record type (i.e. a type for which "=" composes when
      --  used as a component in an outer composite type).

      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 <<Body_Id>> (Left, Right : T) return Boolean is
   --       [ X : T renames Left;  ]
   --       [ Y : T renames Right; ]
   --       --  The above renamings are generated only if the parameters of
   --       --  this built function (which are passed by the caller) are not
   --       --  named 'X' and 'Y'; these names are required to reuse several
   --       --  expander routines when generating this body.

   --    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;

   function Build_Variant_Record_Equality
     (Typ         : Entity_Id;
      Body_Id     : Entity_Id;
      Param_Specs : List_Id) return Node_Id
   is
      Loc   : constant Source_Ptr := Sloc (Typ);
      Def   : constant Node_Id    := Parent (Typ);
      Comps : constant Node_Id    := Component_List (Type_Definition (Def));
      Left  : constant Entity_Id  := Defining_Identifier (First (Param_Specs));
      Right : constant Entity_Id  :=
                    Defining_Identifier (Next (First (Param_Specs)));
      Decls : constant List_Id    := New_List;
      Stmts : constant List_Id    := New_List;

      Subp_Body : Node_Id;

   begin
      pragma Assert (not Is_Tagged_Type (Typ));

      --  In order to reuse the expander routines Make_Eq_If and Make_Eq_Case
      --  the name of the formals must be X and Y; otherwise we generate two
      --  renaming declarations for such purpose.

      if Chars (Left) /= Name_X then
         Append_To (Decls,
           Make_Object_Renaming_Declaration (Loc,
             Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
             Subtype_Mark        => New_Occurrence_Of (Typ, Loc),
             Name                => Make_Identifier (Loc, Chars (Left))));
      end if;

      if Chars (Right) /= Name_Y then
         Append_To (Decls,
           Make_Object_Renaming_Declaration (Loc,
             Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
             Subtype_Mark        => New_Occurrence_Of (Typ, Loc),
             Name                => Make_Identifier (Loc, Chars (Right))));
      end if;

      --  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
            A          : Entity_Id;
            B          : Entity_Id;
            Discr      : Entity_Id;
            Discr_Type : 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 (Param_Specs,
                 Make_Parameter_Specification (Loc,
                   Defining_Identifier => A,
                   Parameter_Type      =>
                     New_Occurrence_Of (Discr_Type, Loc)));

               Append_To (Param_Specs,
                 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)));

      Subp_Body :=
        Make_Subprogram_Body (Loc,
          Specification              =>
            Make_Function_Specification (Loc,
              Defining_Unit_Name       => Body_Id,
              Parameter_Specifications => Param_Specs,
              Result_Definition        =>
                New_Occurrence_Of (Standard_Boolean, Loc)),
          Declarations               => Decls,
          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc,
              Statements => Stmts));

      return Subp_Body;
   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
         --  Move this check to sem???

         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;

   -------------------------------
   -- Copy_Discr_Checking_Funcs --
   -------------------------------

   procedure Copy_Discr_Checking_Funcs (N : Node_Id) is
      Typ      : constant Entity_Id := Defining_Identifier (N);
      Comp     : Entity_Id := First_Component (Typ);
      Old_Comp : Entity_Id := First_Component
                                (Base_Type (Underlying_Type (Etype (Typ))));
   begin
      while Present (Comp) loop
         if 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 Copy_Discr_Checking_Funcs;

   ------------------------------
   -- 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;
      Index_Typ     : Entity_Id;
      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);
      Num := 1;
      Next_Literal (Ent);

      while Present (Ent) loop
         if Enumeration_Rep (Ent) - Last_Repval /= 1 then
            Is_Contiguous := False;
         else
            Last_Repval := Enumeration_Rep (Ent);
         end if;

         Num := Num + 1;
         Next_Literal (Ent);
      end loop;

      if Is_Contiguous then
         Set_Has_Contiguous_Rep (Typ);

         --  Now build a subtype declaration

         --    subtype typI is new Natural range 0 .. num - 1

         Index_Typ :=
           Make_Defining_Identifier (Loc,
             Chars => New_External_Name (Chars (Typ), 'I'));

         Append_Freeze_Action (Typ,
           Make_Subtype_Declaration (Loc,
             Defining_Identifier => Index_Typ,
             Subtype_Indication =>
               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))))));

         Set_Enum_Pos_To_Rep (Typ, Index_Typ);

      else
         --  Build list of literal references

         Lst := New_List;
         Ent := First_Literal (Typ);
         while Present (Ent) loop
            Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
            Next_Literal (Ent);
         end loop;

         --  Now build an array declaration

         --    typA : constant array (Natural range 0 .. num - 1) of typ :=
         --             (v, v, v, v, v, ....)

         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);
      end if;

      --  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???

      --  The underlying type is signed. Reset the Is_Unsigned_Type explicitly
      --  because it might have been inherited from the parent type.

      if Enumeration_Rep (First_Literal (Typ)) < 0 then
         Set_Is_Unsigned_Type (Typ, False);
      end if;

      Ityp := Integer_Type_For (Esize (Typ), Is_Unsigned_Type (Typ));

      --  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

      procedure Build_Class_Condition_Subprograms (Typ : Entity_Id);
      --  Create internal subprograms of Typ primitives that have class-wide
      --  preconditions or postconditions; they are invoked by the caller to
      --  evaluate the conditions.

      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 Register_Dispatch_Table_Wrappers (Typ : Entity_Id);
      --  Register dispatch-table wrappers in the dispatch table of Typ

      procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id);
      --  Check extra formals of dispatching primitives of tagged type Typ.
      --  Used in pragma Debug.

      ---------------------------------------
      -- Build_Class_Condition_Subprograms --
      ---------------------------------------

      procedure Build_Class_Condition_Subprograms (Typ : Entity_Id) is
         Prim_List : constant Elist_Id := Primitive_Operations (Typ);
         Prim_Elmt : Elmt_Id           := First_Elmt (Prim_List);
         Prim      : Entity_Id;

      begin
         while Present (Prim_Elmt) loop
            Prim := Node (Prim_Elmt);

            --  Primitive with class-wide preconditions

            if Comes_From_Source (Prim)
              and then Has_Significant_Contract (Prim)
              and then
                (Present (Class_Preconditions (Prim))
                   or else Present (Ignored_Class_Preconditions (Prim)))
            then
               if Expander_Active then
                  Make_Class_Precondition_Subps (Prim);
               end if;

            --  Wrapper of a primitive that has or inherits class-wide
            --  preconditions.

            elsif Is_Primitive_Wrapper (Prim)
              and then
                (Present (Nearest_Class_Condition_Subprogram
                           (Spec_Id => Prim,
                            Kind    => Class_Precondition))
                   or else
                 Present (Nearest_Class_Condition_Subprogram
                           (Spec_Id => Prim,
                            Kind    => Ignored_Class_Precondition)))
            then
               if Expander_Active then
                  Make_Class_Precondition_Subps (Prim);
               end if;
            end if;

            Next_Elmt (Prim_Elmt);
         end loop;
      end Build_Class_Condition_Subprograms;

      -----------------------------------
      -- Build_Variant_Record_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));
      begin
         --  For a variant record with restriction No_Implicit_Conditionals
         --  in effect we skip building the procedure. This is safe because
         --  if we can see the restriction, so can any caller, and 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 (
           Build_Variant_Record_Equality
             (Typ         => Typ,
              Body_Id     => F,
              Param_Specs => 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)))));

         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;

      --------------------------------------
      -- Register_Dispatch_Table_Wrappers --
      --------------------------------------

      procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id) is
         Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Typ));
         Subp : Entity_Id;

      begin
         while Present (Elmt) loop
            Subp := Node (Elmt);

            if Is_Dispatch_Table_Wrapper (Subp) then
               Append_Freeze_Actions (Typ,
                 Register_Primitive (Sloc (Subp), Subp));
            end if;

            Next_Elmt (Elmt);
         end loop;
      end Register_Dispatch_Table_Wrappers;

      ----------------------------------------
      -- Validate_Tagged_Type_Extra_Formals --
      ----------------------------------------

      procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id) is
         Ovr_Subp : Entity_Id;
         Elmt     : Elmt_Id;
         Subp     : Entity_Id;

      begin
         pragma Assert (not Is_Class_Wide_Type (Typ));

         --  No check required if expansion is not active since we never
         --  generate extra formals in such case.

         if not Expander_Active then
            return;
         end if;

         Elmt := First_Elmt (Primitive_Operations (Typ));
         while Present (Elmt) loop
            Subp := Node (Elmt);

            --  Extra formals of a dispatching primitive must match:

            --  1) The extra formals of its covered interface primitive

            if Present (Interface_Alias (Subp)) then
               pragma Assert
                 (Extra_Formals_Match_OK
                   (E     => Interface_Alias (Subp),
                    Ref_E => Alias (Subp)));
            end if;

            --  2) The extra formals of its renamed primitive

            if Present (Alias (Subp)) then
               pragma Assert
                 (Extra_Formals_Match_OK
                   (E     => Subp,
                    Ref_E => Ultimate_Alias (Subp)));
            end if;

            --  3) The extra formals of its overridden primitive

            if Present (Overridden_Operation (Subp)) then
               Ovr_Subp := Overridden_Operation (Subp);

               --  Handle controlling function wrapper

               if Is_Wrapper (Subp)
                 and then Ultimate_Alias (Ovr_Subp) = Subp
               then
                  if Present (Overridden_Operation (Ovr_Subp)) then
                     pragma Assert
                       (Extra_Formals_Match_OK
                         (E     => Subp,
                          Ref_E => Overridden_Operation (Ovr_Subp)));
                  end if;

               else
                  pragma Assert
                    (Extra_Formals_Match_OK
                      (E     => Subp,
                       Ref_E => Ovr_Subp));
               end if;
            end if;

            Next_Elmt (Elmt);
         end loop;
      end Validate_Tagged_Type_Extra_Formals;

      --  Local variables

      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;
      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.

      Build_Or_Copy_Discr_Checking_Funcs (Typ_Decl);

      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 Build_Static_Dispatch_Tables).

               if not Building_Static_DT (Typ) then
                  Append_Freeze_Actions (Typ, Make_DT (Typ));

                  --  Register dispatch table wrappers in the dispatch table.
                  --  It could not be done when these wrappers were built
                  --  because, at that stage, the dispatch table was not
                  --  available.

                  Register_Dispatch_Table_Wrappers (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.

         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.
      --
      --  This is not needed:
      --    1) If expansion is disabled, because extra formals are only added
      --       when we are generating code.
      --
      --    2) For types with foreign convention since primitives with foreign
      --       convention don't have extra formals and AI95-117 requires that
      --       all primitives of a tagged type inherit the convention.

      if Expander_Active
        and then Is_Tagged_Type (Typ)
        and then not Has_Foreign_Convention (Typ)
      then
         declare
            Elmt : Elmt_Id;
            E    : Entity_Id;

         begin
            --  Add extra formals to primitive operations

            Elmt := First_Elmt (Primitive_Operations (Typ));
            while Present (Elmt) loop
               Create_Extra_Formals (Node (Elmt));
               Next_Elmt (Elmt);
            end loop;

            --  Add extra formals to renamings of primitive operations. The
            --  addition of extra formals is done in two steps to minimize
            --  the compile time required for this action; the evaluation of
            --  Find_Dispatching_Type() and Contains() is only done here for
            --  renamings that are not primitive operations.

            E := First_Entity (Scope (Typ));
            while Present (E) loop
               if Is_Dispatching_Operation (E)
                 and then Present (Alias (E))
                 and then Find_Dispatching_Type (E) = Typ
                 and then not Contains (Primitive_Operations (Typ), E)
               then
                  Create_Extra_Formals (E);
               end if;

               Next_Entity (E);
            end loop;

            pragma Debug (Validate_Tagged_Type_Extra_Formals (Typ));
         end;
      end if;

      --  Build internal subprograms of primitives with class-wide
      --  pre/postconditions.

      if Is_Tagged_Type (Typ) then
         Build_Class_Condition_Subprograms (Typ);
      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 Is_Incomplete_Type (Desig_Typ)
           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 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.

         --  Suppress the master creation for access types created for entry
         --  formal parameters (parameter block component types). Seems like
         --  suppression should be more general for compiler-generated types,
         --  but testing Comes_From_Source may be too general in this case
         --  (affects some test output)???

         elsif not Is_Param_Block_Component_Type (Ptr_Typ)
           and then Is_Limited_Class_Wide_Type (Desig_Typ)
         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 := Empty;
            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 Might_Have_Tasks
                            (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
                     pragma Assert (Present (M_Id));
                     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 Is_Private_Type (Par_Id)
        and then Present (Full_View (Par_Id))
      then
         Par_Id := Base_Type (Full_View (Par_Id));
      end if;

      if Nkind (Type_Definition (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 Is_Private_Type (B_Id)
              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);
      Next_N   : constant Node_Id    := Next (N);

      Special_Ret_Obj : constant Boolean := Is_Special_Return_Object (Def_Id);
      --  If this is a special return object, it will be allocated differently
      --  and ultimately rewritten as a renaming, so initialization activities
      --  need to be deferred until after that is done.

      Func_Id : constant Entity_Id :=
       (if Special_Ret_Obj then Return_Applies_To (Scope (Def_Id)) else Empty);
      --  The function if this is a special return object, otherwise Empty

      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.

      function Build_Heap_Or_Pool_Allocator
        (Temp_Id    : Entity_Id;
         Temp_Typ   : Entity_Id;
         Ret_Typ    : Entity_Id;
         Alloc_Expr : Node_Id) return Node_Id;
      --  Create the statements necessary to allocate a return object on the
      --  heap or user-defined storage pool. The object may need finalization
      --  actions depending on the return type.
      --
      --    * Controlled case
      --
      --       if BIPfinalizationmaster = null then
      --          Temp_Id := <Alloc_Expr>;
      --       else
      --          declare
      --             type Ptr_Typ is access Ret_Typ;
      --             for Ptr_Typ'Storage_Pool use
      --                   Base_Pool (BIPfinalizationmaster.all).all;
      --             Local : Ptr_Typ;
      --
      --          begin
      --             procedure Allocate (...) is
      --             begin
      --                System.Storage_Pools.Subpools.Allocate_Any (...);
      --             end Allocate;
      --
      --             Local := <Alloc_Expr>;
      --             Temp_Id := Temp_Typ (Local);
      --          end;
      --       end if;
      --
      --    * Non-controlled case
      --
      --       Temp_Id := <Alloc_Expr>;
      --
      --  Temp_Id is the temporary which is used to reference the internally
      --  created object in all allocation forms. Temp_Typ is the type of the
      --  temporary. Func_Id is the enclosing function. Ret_Typ is the return
      --  type of Func_Id. Alloc_Expr is the actual allocator.

      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.

      procedure Initialize_Return_Object
        (Tag_Assign : Node_Id;
         Adj_Call   : Node_Id;
         Expr       : Node_Id;
         Init_Stmt  : Node_Id;
         After      : Node_Id);
      --  Generate all initialization actions for return object Def_Id. Any
      --  new code is inserted after node After.

      function Is_Renamable_Function_Call (Expr : Node_Id) return Boolean;
      --  If we are not at library level and the object declaration originally
      --  appears in the form:

      --    Obj : Typ := Func (...);

      --  and has been rewritten as the dereference of a captured reference
      --  to the function result built either on the primary or the secondary
      --  stack, then the declaration can be rewritten as the renaming of this
      --  dereference:

      --    type Ann is access all Typ;
      --    Rnn : constant Axx := Func (...)'reference;
      --    Obj : Typ renames Rnn.all;

      --  This will avoid making an extra copy and, in the case where Typ needs
      --  finalization, a pair of calls to the Adjust and Finalize primitives,
      --  or Deep_Adjust and Deep_Finalize routines, depending on whether Typ
      --  has components that themselves need finalization.

      --  However, in the case of a special return object, we need to make sure
      --  that the object Rnn is recognized by the Is_Related_To_Func_Return
      --  predicate; otherwise, if it is of a type that needs finalization,
      --  then Requires_Cleanup_Actions would return true because of this and
      --  Build_Finalizer would finalize it prematurely because of this (see
      --  also Expand_Simple_Function_Return for the same test in the case of
      --  a simple return).

      --  Finally, in the case of a special return object, we also need to make
      --  sure that the two functions return on the same stack, otherwise we
      --  would create a dangling reference.

      function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id;
      --  Make an allocator for a return object initialized with Expr

      function OK_To_Rename_Ref (N : Node_Id) return Boolean;
      --  Return True if N denotes an entity with OK_To_Rename set

      --------------------------------
      -- 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 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 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;

      ----------------------------------
      -- Build_Heap_Or_Pool_Allocator --
      ----------------------------------

      function Build_Heap_Or_Pool_Allocator
        (Temp_Id    : Entity_Id;
         Temp_Typ   : Entity_Id;
         Ret_Typ    : Entity_Id;
         Alloc_Expr : Node_Id) return Node_Id
      is
      begin
         pragma Assert (Is_Build_In_Place_Function (Func_Id));

         --  Processing for objects that require finalization actions

         if Needs_Finalization (Ret_Typ) then
            declare
               Decls      : constant List_Id := New_List;
               Fin_Mas_Id : constant Entity_Id :=
                 Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
               Orig_Expr  : constant Node_Id := New_Copy_Tree (Alloc_Expr);
               Stmts      : constant List_Id := New_List;
               Local_Id   : Entity_Id;
               Pool_Id    : Entity_Id;
               Ptr_Typ    : Entity_Id;

            begin
               --  Generate:
               --    Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;

               Pool_Id := Make_Temporary (Loc, 'P');

               Append_To (Decls,
                 Make_Object_Renaming_Declaration (Loc,
                   Defining_Identifier => Pool_Id,
                   Subtype_Mark        =>
                     New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
                   Name                =>
                     Make_Explicit_Dereference (Loc,
                       Prefix =>
                         Make_Function_Call (Loc,
                           Name                   =>
                             New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
                           Parameter_Associations => New_List (
                             Make_Explicit_Dereference (Loc,
                               Prefix =>
                                 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));

               --  Create an access type which uses the storage pool of the
               --  caller's master. This additional type is necessary because
               --  the finalization master cannot be associated with the type
               --  of the temporary. Otherwise the secondary stack allocation
               --  will fail.

               --  Generate:
               --    type Ptr_Typ is access Ret_Typ;

               Ptr_Typ := Make_Temporary (Loc, 'P');

               Append_To (Decls,
                 Make_Full_Type_Declaration (Loc,
                   Defining_Identifier => Ptr_Typ,
                   Type_Definition     =>
                     Make_Access_To_Object_Definition (Loc,
                       Subtype_Indication =>
                         New_Occurrence_Of (Ret_Typ, Loc))));

               --  Perform minor decoration in order to set the master and the
               --  storage pool attributes.

               Mutate_Ekind                (Ptr_Typ, E_Access_Type);
               Set_Finalization_Master     (Ptr_Typ, Fin_Mas_Id);
               Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);

               --  Create the temporary, generate:
               --    Local_Id : Ptr_Typ;

               Local_Id := Make_Temporary (Loc, 'T');

               Append_To (Decls,
                 Make_Object_Declaration (Loc,
                   Defining_Identifier => Local_Id,
                   Object_Definition   =>
                     New_Occurrence_Of (Ptr_Typ, Loc)));

               --  Allocate the object, generate:
               --    Local_Id := <Alloc_Expr>;

               Append_To (Stmts,
                 Make_Assignment_Statement (Loc,
                   Name       => New_Occurrence_Of (Local_Id, Loc),
                   Expression => Alloc_Expr));

               --  Generate:
               --    Temp_Id := Temp_Typ (Local_Id);

               Append_To (Stmts,
                 Make_Assignment_Statement (Loc,
                   Name       => New_Occurrence_Of (Temp_Id, Loc),
                   Expression =>
                     Unchecked_Convert_To (Temp_Typ,
                       New_Occurrence_Of (Local_Id, Loc))));

               --  Wrap the allocation in a block. This is further conditioned
               --  by checking the caller finalization master at runtime. A
               --  null value indicates a non-existent master, most likely due
               --  to a Finalize_Storage_Only allocation.

               --  Generate:
               --    if BIPfinalizationmaster = null then
               --       Temp_Id := <Orig_Expr>;
               --    else
               --       declare
               --          <Decls>
               --       begin
               --          <Stmts>
               --       end;
               --    end if;

               return
                 Make_If_Statement (Loc,
                   Condition       =>
                     Make_Op_Eq (Loc,
                       Left_Opnd  => New_Occurrence_Of (Fin_Mas_Id, Loc),
                       Right_Opnd => Make_Null (Loc)),

                   Then_Statements => New_List (
                     Make_Assignment_Statement (Loc,
                       Name       => New_Occurrence_Of (Temp_Id, Loc),
                       Expression => Orig_Expr)),

                   Else_Statements => New_List (
                     Make_Block_Statement (Loc,
                       Declarations               => Decls,
                       Handled_Statement_Sequence =>
                         Make_Handled_Sequence_Of_Statements (Loc,
                           Statements => Stmts))));
            end;

         --  For all other cases, generate:
         --    Temp_Id := <Alloc_Expr>;

         else
            return
              Make_Assignment_Statement (Loc,
                Name       => New_Occurrence_Of (Temp_Id, Loc),
                Expression => Alloc_Expr);
         end if;
      end Build_Heap_Or_Pool_Allocator;

      -------------------------------------
      -- 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.

         function Simple_Initialization_OK
           (Init_Typ : Entity_Id) return Boolean;
         --  Determine whether object declaration N with entity Def_Id needs
         --  simple initialization, assuming that it is of type Init_Typ.

         --------------------------
         -- 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;

         ------------------------------
         -- Simple_Initialization_OK --
         ------------------------------

         function Simple_Initialization_OK
           (Init_Typ : Entity_Id) return Boolean
         is
         begin
            --  Do not consider the object declaration if it comes with an
            --  initialization expression, or is internal in which case it
            --  will be assigned later.

            return
              not Is_Internal (Def_Id)
                and then not Has_Init_Expression (N)
                and then Needs_Simple_Initialization
                           (Typ         => Init_Typ,
                            Consider_IS =>
                              Initialize_Scalars
                                and then No (Following_Address_Clause (N)));
         end Simple_Initialization_OK;

         --  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;

               --  Optimize the default initialization of an array object when
               --  pragma Initialize_Scalars or Normalize_Scalars is in effect.
               --  Construct an in-place initialization aggregate which may be
               --  convert into a fast memset by the backend.

               elsif Init_Or_Norm_Scalars
                 and then Is_Array_Type (Typ)

                 --  The array must lack atomic components because they are
                 --  treated as non-static, and as a result the backend will
                 --  not initialize the memory in one go.

                 and then not Has_Atomic_Components (Typ)

                 --  The array must not be packed because the invalid values
                 --  in System.Scalar_Values are multiples of Storage_Unit.

                 and then not Is_Packed (Typ)

                 --  The array must have static non-empty ranges, otherwise
                 --  the backend cannot initialize the memory in one go.

                 and then Has_Static_Non_Empty_Array_Bounds (Typ)

                 --  The optimization is only relevant for arrays of scalar
                 --  types.

                 and then Is_Scalar_Type (Component_Type (Typ))

                 --  Similar to regular array initialization using a type
                 --  init proc, predicate checks are not performed because the
                 --  initialization values are intentionally invalid, and may
                 --  violate the predicate.

                 and then not Has_Predicates (Component_Type (Typ))

                 --  Array default component value takes precedence over
                 --  Init_Or_Norm_Scalars.

                 and then No (Find_Aspect (Typ,
                                           Aspect_Default_Component_Value))

                 --  The component type must have a single initialization value

                 and then Simple_Initialization_OK (Component_Type (Typ))
               then
                  Set_No_Initialization (N, False);
                  Set_Expression (N,
                    Get_Simple_Init_Val
                      (Typ  => Typ,
                       N    => Obj_Def,
                       Size => (if Known_Esize (Def_Id) then Esize (Def_Id)
                                else Uint_0)));

                  Analyze_And_Resolve
                    (Expression (N), Typ, Suppress => All_Checks);

               --  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

         elsif Simple_Initialization_OK (Typ) then
            Set_No_Initialization (N, False);
            Set_Expression (N,
              Get_Simple_Init_Val
                (Typ  => Typ,
                 N    => Obj_Def,
                 Size =>
                   (if Known_Esize (Def_Id) then Esize (Def_Id) else Uint_0)));

            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_Object_Reference,
                 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

               --  Do not emit warnings related to the elaboration order when a
               --  controlled object is declared before the body of Finalize is
               --  seen.

               if Legacy_Elaboration_Checks then
                  Set_No_Elaboration_Check (Fin_Call);
               end if;

               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;

      ------------------------------
      -- Initialize_Return_Object --
      ------------------------------

      procedure Initialize_Return_Object
        (Tag_Assign : Node_Id;
         Adj_Call   : Node_Id;
         Expr       : Node_Id;
         Init_Stmt  : Node_Id;
         After      : Node_Id)
      is
      begin
         if Present (Tag_Assign) then
            Insert_Action_After (After, Tag_Assign);
         end if;

         if Present (Adj_Call) then
            Insert_Action_After (After, Adj_Call);
         end if;

         if No (Expr) then
            Default_Initialize_Object (After);

         elsif Is_Delayed_Aggregate (Expr)
           and then not No_Initialization (N)
         then
            Convert_Aggr_In_Object_Decl (N);

         elsif Present (Init_Stmt) then
            Insert_Action_After (After, Init_Stmt);
            Set_Expression (N, Empty);
         end if;
      end Initialize_Return_Object;

      --------------------------------
      -- Is_Renamable_Function_Call --
      --------------------------------

      function Is_Renamable_Function_Call (Expr : Node_Id) return Boolean is
      begin
         return not Is_Library_Level_Entity (Def_Id)
           and then Is_Captured_Function_Call (Expr)
           and then (not Special_Ret_Obj
                      or else
                        (Is_Related_To_Func_Return (Entity (Prefix (Expr)))
                          and then Needs_Secondary_Stack (Etype (Expr)) =
                                   Needs_Secondary_Stack (Etype (Func_Id))));
      end Is_Renamable_Function_Call;

      -------------------------------
      -- Make_Allocator_For_Return --
      -------------------------------

      function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id is
         Alloc      : Node_Id;
         Alloc_Expr : Entity_Id;
         Alloc_Typ  : Entity_Id;

      begin
         --  If the return object's declaration does not include an expression,
         --  then we use its subtype for the allocation. Likewise in the case
         --  of a degenerate expression like a raise expression.

         if No (Expr)
           or else Nkind (Original_Node (Expr)) = N_Raise_Expression
         then
            Alloc_Typ := Typ;

         --  If the return object's declaration includes an expression, then
         --  there are two cases: either the nominal subtype of the object is
         --  definite and we can use it for the allocation directly, or it is
         --  not and Analyze_Object_Declaration should have built an actual
         --  subtype from the expression.

         --  However, there are exceptions in the latter case for interfaces
         --  (see Analyze_Object_Declaration), as well as class-wide types and
         --  types with unknown discriminants if they are additionally limited
         --  (see Expand_Subtype_From_Expr), so we must cope with them.

         elsif Is_Interface (Typ) then
            pragma Assert (Is_Class_Wide_Type (Typ));

            --  For interfaces, we use the type of the expression, except if
            --  we need to put back a conversion that we have removed earlier
            --  in the processing.

            if Is_Class_Wide_Type (Etype (Expr)) then
               Alloc_Typ := Typ;
            else
               Alloc_Typ := Etype (Expr);
            end if;

         elsif Is_Class_Wide_Type (Typ) then

            --  For class-wide types, we have to make sure that we use the
            --  dynamic type of the expression for the allocation, either by
            --  means of its (static) subtype or through the actual subtype.

            if Has_Tag_Of_Type (Expr) then
               Alloc_Typ := Etype (Expr);

            else pragma Assert (Ekind (Typ) = E_Class_Wide_Subtype
              and then Present (Equivalent_Type (Typ)));

               Alloc_Typ := Typ;
            end if;

         else pragma Assert (Is_Definite_Subtype (Typ)
           or else (Has_Unknown_Discriminants (Typ)
                     and then Is_Limited_View (Typ)));

            Alloc_Typ := Typ;
         end if;

         --  If the return object's declaration includes an expression and the
         --  declaration isn't marked as No_Initialization, then we generate an
         --  allocator with a qualified expression. Although this is necessary
         --  only in the case where the result type is an interface (or class-
         --  wide interface), we do it in all cases for the sake of consistency
         --  instead of subsequently generating a separate assignment.

         if Present (Expr)
           and then not Is_Delayed_Aggregate (Expr)
           and then not No_Initialization (N)
         then
            --  Ada 2005 (AI95-344): If the result type is class-wide, insert
            --  a check that the level of the return expression's underlying
            --  type is not deeper than the level of the master enclosing the
            --  function.

            --  AI12-043: The check is made immediately after the return object
            --  is created.

            if Is_Class_Wide_Type (Etype (Func_Id)) then
               Apply_CW_Accessibility_Check (Expr, Func_Id);
            end if;

            Alloc_Expr := New_Copy_Tree (Expr);

            if Etype (Alloc_Expr) /= Alloc_Typ then
               Alloc_Expr := Convert_To (Alloc_Typ, Alloc_Expr);
            end if;

            Alloc :=
              Make_Allocator (Loc,
                Expression =>
                  Make_Qualified_Expression (Loc,
                    Subtype_Mark =>
                      New_Occurrence_Of (Alloc_Typ, Loc),
                    Expression   => Alloc_Expr));

         else
            Alloc :=
              Make_Allocator (Loc,
                Expression => New_Occurrence_Of (Alloc_Typ, Loc));

            --  If the return object requires default initialization, then it
            --  will happen later following the elaboration of the renaming.
            --  If we don't turn it off here, then the object will be default
            --  initialized twice.

            Set_No_Initialization (Alloc);
         end if;

         --  Set the flag indicating that the allocator is made for a special
         --  return object. This is used to bypass various legality checks as
         --  well as to make sure that the result is not adjusted twice.

         Set_For_Special_Return_Object (Alloc);

         return Alloc;
      end Make_Allocator_For_Return;

      ----------------------
      -- OK_To_Rename_Ref --
      ----------------------

      function OK_To_Rename_Ref (N : Node_Id) return Boolean is
      begin
         return Is_Entity_Name (N)
           and then Ekind (Entity (N)) = E_Variable
           and then OK_To_Rename (Entity (N));
      end OK_To_Rename_Ref;

      --  Local variables

      Adj_Call   : Node_Id := Empty;
      Expr_Q     : Node_Id := Empty;
      Tag_Assign : Node_Id := Empty;

      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.

      Rewrite_As_Renaming : Boolean := False;
      --  Whether to turn the declaration into a renaming at the end

   --  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;

      --  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 are 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) or else Might_Have_Tasks (Typ) then
         Build_Activation_Chain_Entity (N);

         if Has_Task (Typ) then
            Build_Master_Entity (Def_Id);

         --  Handle objects initialized with BIP function calls

         elsif Present (Expr) then
            Expr_Q := Unqualify (Expr);

            if Is_Build_In_Place_Function_Call (Expr_Q)
              or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
              or else (Nkind (Expr_Q) = N_Reference
                        and then
                       Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
            then
               Build_Master_Entity (Def_Id);
            end if;
         end if;
      end if;

      --  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 Might_Have_Tasks (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 (Typ) in 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;

         if not Special_Ret_Obj then
            Default_Initialize_Object (Init_After);
         end if;

         --  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

         Expr_Q := Unqualify (Expr);

         --  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

            --  An aggregate that must be built in place is not resolved and
            --  expanded until the enclosing construct is expanded. This will
            --  happen when the aggregate is limited and the declared object
            --  has a following address clause; it happens also when generating
            --  C code for an aggregate that has an alignment or address clause
            --  (see Analyze_Object_Declaration). Resolution is done without
            --  expansion because it will take place when the declaration
            --  itself is expanded.

            if (Is_Limited_Type (Typ) or else Modify_Tree_For_C)
              and then not Analyzed (Expr)
            then
               Expander_Mode_Save_And_Set (False);
               Resolve (Expr, Typ);
               Expander_Mode_Restore;
            end if;

            if not Special_Ret_Obj then
               Convert_Aggr_In_Object_Decl (N);
            end if;

         --  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 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)
              and then Nkind (Expr) = N_Explicit_Dereference
              and then Nkind (Original_Node (Expr)) = N_Type_Conversion
              and then Etype (Original_Node (Expr)) = Typ
            then
               Rewrite (Expr, Original_Node (Expression (N)));
            end if;

            --  Avoid expansion of redundant interface conversion

            if Nkind (Expr) = N_Type_Conversion
              and then Etype (Expr) = Typ
            then
               Expr_Q := Expression (Expr);
            else
               Expr_Q := Expr;
            end if;

            --  We may use a renaming if the initialization expression is a
            --  captured function call that meets a few conditions.

            Rewrite_As_Renaming := Is_Renamable_Function_Call (Expr_Q);

            --  If the object is a special return object, then bypass special
            --  treatment of class-wide interface initialization below. In this
            --  case, the expansion of the return object will take care of this
            --  initialization via the expansion of the allocator.

            if Special_Ret_Obj and then not Rewrite_As_Renaming then

               --  If the type needs finalization and is not inherently
               --  limited, then the target is adjusted after the copy
               --  and attached to the finalization list.

               if Needs_Finalization (Typ)
                 and then not Is_Limited_View (Typ)
               then
                  Adj_Call :=
                    Make_Adjust_Call (
                      Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
                      Typ     => Base_Typ);
               end if;

            --  Renaming an expression of the object's type is immediate

            elsif Rewrite_As_Renaming
              and then Base_Type (Etype (Expr_Q)) = Base_Type (Typ)
            then
               null;

            elsif Tagged_Type_Expansion then
               declare
                  Iface : constant Entity_Id := Root_Type (Typ);

                  Expr_Typ     : Entity_Id;
                  New_Expr     : Node_Id;
                  Obj_Id       : Entity_Id;
                  Ptr_Obj_Decl : Node_Id;
                  Ptr_Obj_Id   : Entity_Id;
                  Tag_Comp     : Node_Id;

               begin
                  Expr_Typ := Base_Type (Etype (Expr_Q));
                  if Is_Class_Wide_Type (Expr_Typ) then
                     Expr_Typ := Root_Type (Expr_Typ);
                  end if;

                  --  Rename limited objects since they cannot be copied

                  if Is_Limited_Record (Expr_Typ) then
                     Rewrite_As_Renaming := True;
                  end if;

                  Obj_Id := Make_Temporary (Loc, 'D', Expr_Q);

                  --  Replace
                  --     IW : I'Class := Expr;
                  --  by
                  --     Dnn : Tag renames Tag_Ptr!(Expr'Address).all;
                  --     type Ityp is not null access I'Class;
                  --     Rnn : constant Ityp :=
                  --             Ityp!(Displace (Dnn'Address, I'Tag));
                  --     IW : I'Class renames Rnn.all;

                  if Rewrite_As_Renaming then
                     New_Expr :=
                       Make_Explicit_Dereference (Loc,
                         Unchecked_Convert_To (RTE (RE_Tag_Ptr),
                           Make_Attribute_Reference (Loc,
                             Prefix => Relocate_Node (Expr_Q),
                             Attribute_Name => Name_Address)));

                     --  Suppress junk access checks on RE_Tag_Ptr

                     Insert_Action (N,
                       Make_Object_Renaming_Declaration (Loc,
                         Defining_Identifier => Obj_Id,
                         Subtype_Mark        =>
                           New_Occurrence_Of (RTE (RE_Tag), Loc),
                         Name                => New_Expr),
                       Suppress => Access_Check);

                     --  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)));

                  --  Replace
                  --     IW : I'Class := Expr;
                  --  by
                  --     Dnn : Typ := Expr;
                  --     type Ityp is not null access I'Class;
                  --     Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address);
                  --     IW  : I'Class renames Rnn.all;

                  elsif Has_Tag_Of_Type (Expr_Q)
                    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
                     Insert_Action (N,
                       Make_Object_Declaration (Loc,
                         Defining_Identifier => Obj_Id,
                         Object_Definition   =>
                           New_Occurrence_Of (Expr_Typ, Loc),
                         Expression          => Relocate_Node (Expr_Q)));

                     --  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 := Expr;
                  --  by
                  --     type Equiv_Record is record ... end record;
                  --     implicit subtype CW is <Class_Wide_Subtype>;
                  --     Dnn : CW := CW!(Expr);
                  --     type Ityp is not null access I'Class;
                  --     Rnn : constant Ityp :=
                  --             Ityp!(Displace (Dnn'Address, I'Tag));
                  --     IW : I'Class renames Rnn.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_Q);

                     --  For interface types we use 'Address which displaces
                     --  the pointer to the base of the object (if required).

                     if Is_Interface (Etype (Expr_Q)) then
                        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_Q),
                                  Attribute_Name => Name_Address))));

                     --  For other types, no displacement is needed

                     else
                        New_Expr := Relocate_Node (Expr_Q);
                     end if;

                     --  Suppress junk access checks on RE_Tag_Ptr

                     Insert_Action (N,
                       Make_Object_Declaration (Loc,
                         Defining_Identifier => Obj_Id,
                         Object_Definition   =>
                           New_Occurrence_Of (Etype (Obj_Def), Loc),
                         Expression          => New_Expr),
                       Suppress => Access_Check);

                     --  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;

                  --  As explained in Exp_Disp, we use Convert_Tag_To_Interface
                  --  to do the final conversion, but we insert an intermediate
                  --  temporary before the dereference so that we can process
                  --  the expansion as part of the analysis of the declaration
                  --  of this temporary, and then rewrite manually the original
                  --  object as the simple renaming of this dereference.

                  Tag_Comp := Convert_Tag_To_Interface (Typ, Tag_Comp);
                  pragma Assert (Nkind (Tag_Comp) = N_Explicit_Dereference
                    and then
                      Nkind (Prefix (Tag_Comp)) = N_Unchecked_Type_Conversion);

                  Ptr_Obj_Id := Make_Temporary (Loc, 'R');

                  Ptr_Obj_Decl :=
                    Make_Object_Declaration (Loc,
                      Defining_Identifier => Ptr_Obj_Id,
                      Constant_Present    => True,
                      Object_Definition   =>
                        New_Occurrence_Of
                          (Entity (Subtype_Mark (Prefix (Tag_Comp))), Loc),
                      Expression => Prefix (Tag_Comp));

                  Insert_Action (N, Ptr_Obj_Decl, Suppress => All_Checks);

                  Set_Prefix (Tag_Comp, New_Occurrence_Of (Ptr_Obj_Id, Loc));
                  Expr_Q := Tag_Comp;
                  Set_Etype (Expr_Q, Typ);
                  Set_Parent (Expr_Q, N);

                  Rewrite_As_Renaming := True;
               end;

            else
               return;
            end if;

         --  Common case of explicit object initialization

         else
            --  Small optimization: if the expression is a function call and
            --  the object is stand-alone, not declared at library level and of
            --  a class-wide type, then we capture the result of the call into
            --  a temporary, with the benefit that, if the result's type does
            --  not need finalization, nothing will be finalized and, if it
            --  does, the temporary only will be finalized by means of a direct
            --  call to the Finalize primitive if the result's type is not a
            --  class-wide type; whereas, in both cases, the stand-alone object
            --  itself would be finalized by means of a dispatching call to the
            --  Deep_Finalize routine.

            if Nkind (Expr_Q) = N_Function_Call
              and then not Special_Ret_Obj
              and then not Is_Library_Level_Entity (Def_Id)
              and then Is_Class_Wide_Type (Typ)
            then
               Remove_Side_Effects (Expr_Q);
            end if;

            --  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;

            --  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);
               elsif not Special_Ret_Obj then
                  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
               declare
                  Id_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);

               begin
                  --  The call to the initialization procedure does NOT freeze
                  --  the object being initialized.

                  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;
               end;

            --  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 below).

               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. But avoid crashing on a raise
               --  expression or conditional expression.

               elsif Nkind (Original_Node (Expr_Q)) not in
                 N_Raise_Expression | N_If_Expression | N_Case_Expression
               then
                  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)
              and then Safe_To_Capture_Value (N, Def_Id)
            then
               Set_Is_Known_Valid (Def_Id);

            --  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.

            elsif Is_Access_Type (Typ) and then 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;

            --  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 (Typ)
            then
               Ensure_Valid (Expr);

               if Safe_To_Capture_Value (N, Def_Id) then
                  Set_Is_Known_Valid (Def_Id);
               end if;
            end if;

            --  Now determine whether we will use a renaming

            Rewrite_As_Renaming :=

              --  The declaration cannot be rewritten if it has got constraints

              Is_Entity_Name (Original_Node (Obj_Def))

                --  Nor if it is effectively an unconstrained declaration

                and then not (Is_Array_Type (Typ)
                               and then Is_Constr_Subt_For_UN_Aliased (Typ))

                --  We may use a renaming if the initialization expression is a
                --  captured function call that meets a few conditions.

                and then
                  (Is_Renamable_Function_Call (Expr_Q)

                   --  Or else if it is a variable with OK_To_Rename set

                   or else (OK_To_Rename_Ref (Expr_Q)
                             and then not Special_Ret_Obj)

                   --  Or else if it is a slice of such a variable

                   or else (Nkind (Expr_Q) = N_Slice
                             and then OK_To_Rename_Ref (Prefix (Expr_Q))
                             and then not Special_Ret_Obj));

            --  If the type needs finalization and is not inherently limited,
            --  then the target is adjusted after the copy and attached to the
            --  finalization list. However, no adjustment is needed in the case
            --  where the object has been initialized by a call to a function
            --  returning on the primary stack (see Expand_Ctrl_Function_Call)
            --  since no copy occurred, given that the type is by-reference.
            --  Similarly, no adjustment is needed 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 Nkind (Expr_Q) /= N_Function_Call
              and then not Rewrite_As_Renaming
            then
               Adj_Call :=
                 Make_Adjust_Call (
                   Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
                   Typ     => Base_Typ);

               if Present (Adj_Call) and then not Special_Ret_Obj then
                  Insert_Action_After (Init_After, Adj_Call);
               end if;
            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_Assignment_OK (Name (Stat));
               Set_No_Ctrl_Actions (Stat);
               Insert_Action_After (Init_After, Stat);
               Set_Expression (N, Empty);
               Set_No_Initialization (N);
            end;
         end if;
      end if;

      if Nkind (Obj_Def) = N_Access_Definition
        and then not Is_Local_Anonymous_Access (Typ)
      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_Decl : Node_Id;
            Level_Expr : Node_Id;

         begin
            Mutate_Ekind (Level, Ekind (Def_Id));
            Set_Etype (Level, Standard_Natural);
            Set_Scope (Level, Scope (Def_Id));

            --  Set accessibility level of null

            if No (Expr) then
               Level_Expr :=
                 Make_Integer_Literal
                   (Loc, Scope_Depth (Standard_Standard));

            --  When the expression of the object is a function which returns
            --  an anonymous access type the master of the call is the object
            --  being initialized instead of the type.

            elsif Nkind (Expr) = N_Function_Call
              and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type
            then
               Level_Expr := Accessibility_Level
                               (Def_Id, Object_Decl_Level);

            --  General case

            else
               Level_Expr := Accessibility_Level (Expr, Dynamic_Level);
            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_Null_Body (DIC_Procedure (Typ))
        and then not Has_Init_Expression (N)
        and then No (Expr)
        and then not Is_Imported (Def_Id)
      then
         declare
            DIC_Call : constant Node_Id :=
                         Build_DIC_Call
                           (Loc, New_Occurrence_Of (Def_Id, Loc), 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;

      --  If this is the return object of a build-in-place function, locate the
      --  implicit BIPaccess parameter designating the caller-supplied return
      --  object and convert the declaration to a renaming of a dereference of
      --  this parameter. If the declaration includes an expression, add an
      --  assignment statement to ensure the return object gets initialized.

      --    Result : T [:= <expression>];

      --  is converted to

      --    Result : T renames BIPaccess.all;
      --    [Result := <expression>;]

      --  in the constrained case, or to

      --    type Txx is access all ...;
      --    Rxx : Txx := null;

      --    if BIPalloc = 1 then
      --       Rxx := BIPaccess;
      --       Rxx.all := <expression>;
      --    elsif BIPalloc = 2 then
      --       Rxx := new <expression-type>'(<expression>)[storage_pool =
      --         system__secondary_stack__ss_pool][procedure_to_call =
      --         system__secondary_stack__ss_allocate];
      --    elsif BIPalloc = 3 then
      --       Rxx := new <expression-type>'(<expression>)
      --    elsif BIPalloc = 4 then
      --       Pxx : system__storage_pools__root_storage_pool renames
      --         BIPstoragepool.all;
      --       Rxx := new <expression-type>'(<expression>)[storage_pool =
      --         Pxx][procedure_to_call =
      --         system__storage_pools__allocate_any];
      --    else
      --       [program_error "build in place mismatch"]
      --    end if;

      --    Result : T renames Rxx.all;

      --  in the unconstrained case.

      if Is_Build_In_Place_Return_Object (Def_Id) then
         declare
            Init_Stmt      : Node_Id;
            Obj_Acc_Formal : Entity_Id;

         begin
            --  Retrieve the implicit access parameter passed by the caller

            Obj_Acc_Formal :=
              Build_In_Place_Formal (Func_Id, BIP_Object_Access);

            --  If the return object's declaration includes an expression
            --  and the declaration isn't marked as No_Initialization, then
            --  we need to generate an assignment to the object and insert
            --  it after the declaration before rewriting it as a renaming
            --  (otherwise we'll lose the initialization). The case where
            --  the result type is an interface (or class-wide interface)
            --  is also excluded because the context of the function call
            --  must be unconstrained, so the initialization will always
            --  be done as part of an allocator evaluation (storage pool
            --  or secondary stack), never to a constrained target object
            --  passed in by the caller. Besides the assignment being
            --  unneeded in this case, it avoids problems with trying to
            --  generate a dispatching assignment when the return expression
            --  is a nonlimited descendant of a limited interface (the
            --  interface has no assignment operation).

            if Present (Expr_Q)
              and then not Is_Delayed_Aggregate (Expr_Q)
              and then not No_Initialization (N)
              and then not Is_Interface (Typ)
            then
               if Is_Class_Wide_Type (Typ)
                 and then not Is_Class_Wide_Type (Etype (Expr_Q))
               then
                  Init_Stmt :=
                    Make_Assignment_Statement (Loc,
                      Name       => New_Occurrence_Of (Def_Id, Loc),
                      Expression =>
                        Make_Type_Conversion (Loc,
                          Subtype_Mark =>
                            New_Occurrence_Of (Typ, Loc),
                          Expression   => New_Copy_Tree (Expr_Q)));

               else
                  Init_Stmt :=
                    Make_Assignment_Statement (Loc,
                      Name       => New_Occurrence_Of (Def_Id, Loc),
                      Expression => New_Copy_Tree (Expr_Q));
               end if;

               Set_Assignment_OK (Name (Init_Stmt));
               Set_No_Ctrl_Actions (Init_Stmt);

            else
               Init_Stmt := Empty;
            end if;

            --  When the function's subtype is unconstrained, a run-time
            --  test may be needed to decide the form of allocation to use
            --  for the return object. The function has an implicit formal
            --  parameter indicating this. If the BIP_Alloc_Form formal has
            --  the value one, then the caller has passed access to an
            --  existing object for use as the return object. If the value
            --  is two, then the return object must be allocated on the
            --  secondary stack. If the value is three, then the return
            --  object must be allocated on the heap. Otherwise, the object
            --  must be allocated in a storage pool. We generate an if
            --  statement to test the BIP_Alloc_Form formal and initialize
            --  a local access value appropriately.

            if Needs_BIP_Alloc_Form (Func_Id) then
               declare
                  Desig_Typ : constant Entity_Id :=
                    (if Ekind (Typ) = E_Array_Subtype
                     then Etype (Func_Id) else Typ);
                  --  Ensure that the we use a fat pointer when allocating
                  --  an unconstrained array on the heap. In this case the
                  --  result object's type is a constrained array type even
                  --  though the function's type is unconstrained.

                  Obj_Alloc_Formal : constant Entity_Id :=
                    Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
                  Pool_Id          : constant Entity_Id :=
                    Make_Temporary (Loc, 'P');

                  Acc_Typ        : Entity_Id;
                  Alloc_Obj_Decl : Node_Id;
                  Alloc_Obj_Id   : Entity_Id;
                  Alloc_Stmt     : Node_Id;
                  Guard_Except   : Node_Id;
                  Heap_Allocator : Node_Id;
                  Pool_Allocator : Node_Id;
                  Pool_Decl      : Node_Id;
                  Ptr_Typ_Decl   : Node_Id;
                  SS_Allocator   : Node_Id;

               begin
                  --  Create an access type designating the function's
                  --  result subtype.

                  Acc_Typ := Make_Temporary (Loc, 'A');

                  Ptr_Typ_Decl :=
                    Make_Full_Type_Declaration (Loc,
                      Defining_Identifier => Acc_Typ,
                      Type_Definition     =>
                        Make_Access_To_Object_Definition (Loc,
                          All_Present        => True,
                          Subtype_Indication =>
                            New_Occurrence_Of (Desig_Typ, Loc)));

                  Insert_Action (N, Ptr_Typ_Decl, Suppress => All_Checks);

                  --  Create an access object that will be initialized to an
                  --  access value denoting the return object, either coming
                  --  from an implicit access value passed in by the caller
                  --  or from the result of an allocator.

                  Alloc_Obj_Id := Make_Temporary (Loc, 'R');

                  Alloc_Obj_Decl :=
                    Make_Object_Declaration (Loc,
                      Defining_Identifier => Alloc_Obj_Id,
                      Object_Definition   =>
                        New_Occurrence_Of (Acc_Typ, Loc));

                  Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);

                  --  First create the Heap_Allocator

                  Heap_Allocator := Make_Allocator_For_Return (Expr_Q);

                  --  The Pool_Allocator is just like the Heap_Allocator,
                  --  except we set Storage_Pool and Procedure_To_Call so
                  --  it will use the user-defined storage pool.

                  Pool_Allocator := Make_Allocator_For_Return (Expr_Q);

                  --  Do not generate the renaming of the build-in-place
                  --  pool parameter on ZFP because the parameter is not
                  --  created in the first place.

                  if RTE_Available (RE_Root_Storage_Pool_Ptr) then
                     Pool_Decl :=
                       Make_Object_Renaming_Declaration (Loc,
                         Defining_Identifier => Pool_Id,
                         Subtype_Mark        =>
                           New_Occurrence_Of
                             (RTE (RE_Root_Storage_Pool), Loc),
                         Name                =>
                           Make_Explicit_Dereference (Loc,
                             New_Occurrence_Of
                               (Build_In_Place_Formal
                                  (Func_Id, BIP_Storage_Pool), Loc)));
                     Set_Storage_Pool (Pool_Allocator, Pool_Id);
                     Set_Procedure_To_Call
                       (Pool_Allocator, RTE (RE_Allocate_Any));
                  else
                     Pool_Decl := Make_Null_Statement (Loc);
                  end if;

                  --  If the No_Allocators restriction is active, then only
                  --  an allocator for secondary stack allocation is needed.
                  --  It's OK for such allocators to have Comes_From_Source
                  --  set to False, because gigi knows not to flag them as
                  --  being a violation of No_Implicit_Heap_Allocations.

                  if Restriction_Active (No_Allocators) then
                     SS_Allocator   := Heap_Allocator;
                     Heap_Allocator := Make_Null (Loc);
                     Pool_Allocator := Make_Null (Loc);

                  --  Otherwise the heap and pool allocators may be needed,
                  --  so we make another allocator for secondary stack
                  --  allocation.

                  else
                     SS_Allocator := Make_Allocator_For_Return (Expr_Q);

                     --  The heap and pool allocators are marked as
                     --  Comes_From_Source since they correspond to an
                     --  explicit user-written allocator (that is, it will
                     --  only be executed on behalf of callers that call the
                     --  function as initialization for such an allocator).
                     --  Prevents errors when No_Implicit_Heap_Allocations
                     --  is in force.

                     Set_Comes_From_Source (Heap_Allocator, True);
                     Set_Comes_From_Source (Pool_Allocator, True);
                  end if;

                  --  The allocator is returned on the secondary stack

                  Check_Restriction (No_Secondary_Stack, N);
                  Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool));
                  Set_Procedure_To_Call
                    (SS_Allocator, RTE (RE_SS_Allocate));

                  --  The allocator is returned on the secondary stack,
                  --  so indicate that the function return, as well as
                  --  all blocks that encloses the allocator, must not
                  --  release it. The flags must be set now because
                  --  the decision to use the secondary stack is done
                  --  very late in the course of expanding the return
                  --  statement, past the point where these flags are
                  --  normally set.

                  Set_Uses_Sec_Stack (Func_Id);
                  Set_Uses_Sec_Stack (Scope (Def_Id));
                  Set_Sec_Stack_Needed_For_Return (Scope (Def_Id));

                  --  Guard against poor expansion on the caller side by
                  --  using a raise statement to catch out-of-range values
                  --  of formal parameter BIP_Alloc_Form.

                  if Exceptions_OK then
                     Guard_Except :=
                       Make_Raise_Program_Error (Loc,
                         Reason => PE_Build_In_Place_Mismatch);
                  else
                     Guard_Except := Make_Null_Statement (Loc);
                  end if;

                  --  Create an if statement to test the BIP_Alloc_Form
                  --  formal and initialize the access object to either the
                  --  BIP_Object_Access formal (BIP_Alloc_Form =
                  --  Caller_Allocation), the result of allocating the
                  --  object in the secondary stack (BIP_Alloc_Form =
                  --  Secondary_Stack), or else an allocator to create the
                  --  return object in the heap or user-defined pool
                  --  (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).

                  --  ??? An unchecked type conversion must be made in the
                  --  case of assigning the access object formal to the
                  --  local access object, because a normal conversion would
                  --  be illegal in some cases (such as converting access-
                  --  to-unconstrained to access-to-constrained), but the
                  --  the unchecked conversion will presumably fail to work
                  --  right in just such cases. It's not clear at all how to
                  --  handle this.

                  Alloc_Stmt :=
                    Make_If_Statement (Loc,
                      Condition =>
                        Make_Op_Eq (Loc,
                          Left_Opnd  =>
                            New_Occurrence_Of (Obj_Alloc_Formal, Loc),
                          Right_Opnd =>
                            Make_Integer_Literal (Loc,
                              UI_From_Int (BIP_Allocation_Form'Pos
                                             (Caller_Allocation)))),

                      Then_Statements => New_List (
                        Make_Assignment_Statement (Loc,
                          Name       =>
                            New_Occurrence_Of (Alloc_Obj_Id, Loc),
                          Expression =>
                            Unchecked_Convert_To
                              (Acc_Typ,
                               New_Occurrence_Of (Obj_Acc_Formal, Loc)))),

                      Elsif_Parts => New_List (
                        Make_Elsif_Part (Loc,
                          Condition =>
                            Make_Op_Eq (Loc,
                              Left_Opnd  =>
                                New_Occurrence_Of (Obj_Alloc_Formal, Loc),
                              Right_Opnd =>
                                Make_Integer_Literal (Loc,
                                  UI_From_Int (BIP_Allocation_Form'Pos
                                                 (Secondary_Stack)))),

                          Then_Statements => New_List (
                            Make_Assignment_Statement (Loc,
                              Name       =>
                                New_Occurrence_Of (Alloc_Obj_Id, Loc),
                              Expression => SS_Allocator))),

                        Make_Elsif_Part (Loc,
                          Condition =>
                            Make_Op_Eq (Loc,
                              Left_Opnd  =>
                                New_Occurrence_Of (Obj_Alloc_Formal, Loc),
                              Right_Opnd =>
                                Make_Integer_Literal (Loc,
                                  UI_From_Int (BIP_Allocation_Form'Pos
                                                 (Global_Heap)))),

                          Then_Statements => New_List (
                            Build_Heap_Or_Pool_Allocator
                              (Temp_Id    => Alloc_Obj_Id,
                               Temp_Typ   => Acc_Typ,
                               Ret_Typ    => Desig_Typ,
                               Alloc_Expr => Heap_Allocator))),

                        --  ??? If all is well, we can put the following
                        --  'elsif' in the 'else', but this is a useful
                        --  self-check in case caller and callee don't agree
                        --  on whether BIPAlloc and so on should be passed.

                        Make_Elsif_Part (Loc,
                          Condition =>
                            Make_Op_Eq (Loc,
                              Left_Opnd  =>
                                New_Occurrence_Of (Obj_Alloc_Formal, Loc),
                              Right_Opnd =>
                                Make_Integer_Literal (Loc,
                                  UI_From_Int (BIP_Allocation_Form'Pos
                                                 (User_Storage_Pool)))),

                          Then_Statements => New_List (
                            Pool_Decl,
                            Build_Heap_Or_Pool_Allocator
                              (Temp_Id    => Alloc_Obj_Id,
                               Temp_Typ   => Acc_Typ,
                               Ret_Typ    => Desig_Typ,
                               Alloc_Expr => Pool_Allocator)))),

                      --  Raise Program_Error if it's none of the above;
                      --  this is a compiler bug.

                      Else_Statements => New_List (Guard_Except));

                     --  If a separate initialization assignment was created
                     --  earlier, append that following the assignment of the
                     --  implicit access formal to the access object, to ensure
                     --  that the return object is initialized in that case. In
                     --  this situation, the target of the assignment must be
                     --  rewritten to denote a dereference of the access to the
                     --  return object passed in by the caller.

                     if Present (Init_Stmt) then
                        Set_Name (Init_Stmt,
                          Make_Explicit_Dereference (Loc,
                            Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
                        Set_Assignment_OK (Name (Init_Stmt));

                        Append_To (Then_Statements (Alloc_Stmt), Init_Stmt);
                        Init_Stmt := Empty;
                     end if;

                  Insert_Action (N, Alloc_Stmt, Suppress => All_Checks);

                  --  From now on, the type of the return object is the
                  --  designated type.

                  if Desig_Typ /= Typ then
                     Set_Etype (Def_Id, Desig_Typ);
                     Set_Actual_Subtype (Def_Id, Typ);
                  end if;

                  --  Remember the local access object for use in the
                  --  dereference of the renaming created below.

                  Obj_Acc_Formal := Alloc_Obj_Id;
               end;

            --  When the function's type is unconstrained and a run-time test
            --  is not needed, we nevertheless need to build the return using
            --  the return object's type.

            elsif not Is_Constrained (Underlying_Type (Etype (Func_Id))) then
               declare
                  Acc_Typ        : Entity_Id;
                  Alloc_Obj_Decl : Node_Id;
                  Alloc_Obj_Id   : Entity_Id;
                  Ptr_Typ_Decl   : Node_Id;

               begin
                  --  Create an access type designating the function's
                  --  result subtype.

                  Acc_Typ := Make_Temporary (Loc, 'A');

                  Ptr_Typ_Decl :=
                    Make_Full_Type_Declaration (Loc,
                      Defining_Identifier => Acc_Typ,
                      Type_Definition     =>
                        Make_Access_To_Object_Definition (Loc,
                          All_Present        => True,
                          Subtype_Indication =>
                            New_Occurrence_Of (Typ, Loc)));

                  Insert_Action (N, Ptr_Typ_Decl, Suppress => All_Checks);

                  --  Create an access object initialized to the conversion
                  --  of the implicit access value passed in by the caller.

                  Alloc_Obj_Id := Make_Temporary (Loc, 'R');

                  --  See the ??? comment a few lines above about the use of
                  --  an unchecked conversion here.

                  Alloc_Obj_Decl :=
                    Make_Object_Declaration (Loc,
                      Defining_Identifier => Alloc_Obj_Id,
                      Constant_Present    => True,
                      Object_Definition   =>
                        New_Occurrence_Of (Acc_Typ, Loc),
                      Expression =>
                        Unchecked_Convert_To
                          (Acc_Typ, New_Occurrence_Of (Obj_Acc_Formal, Loc)));

                  Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);

                  --  Remember the local access object for use in the
                  --  dereference of the renaming created below.

                  Obj_Acc_Formal := Alloc_Obj_Id;
               end;
            end if;

            --  Initialize the object now that it has got its final subtype,
            --  but before rewriting it as a renaming.

            Initialize_Return_Object
              (Tag_Assign, Adj_Call, Expr_Q, Init_Stmt, Init_After);

            --  Replace the return object declaration with a renaming of a
            --  dereference of the access value designating the return object.

            Expr_Q :=
              Make_Explicit_Dereference (Loc,
                Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
            Set_Etype (Expr_Q, Etype (Def_Id));

            Rewrite_As_Renaming := True;
         end;

      --  If we can rename the initialization expression, we need to make sure
      --  that we use the proper type in the case of a return object that lives
      --  on the secondary stack (see other cases below for a similar handling)
      --  and that the tag is assigned in the case of any return object.

      elsif Rewrite_As_Renaming then
         if Special_Ret_Obj then
            declare
               Desig_Typ : constant Entity_Id :=
                 (if Ekind (Typ) = E_Array_Subtype
                  then Etype (Func_Id) else Typ);

            begin
               --  From now on, the type of the return object is the
               --  designated type.

               if Desig_Typ /= Typ then
                  Set_Etype (Def_Id, Desig_Typ);
                  Set_Actual_Subtype (Def_Id, Typ);
               end if;

               if Present (Tag_Assign) then
                  Insert_Action_After (Init_After, Tag_Assign);
               end if;

               --  Ada 2005 (AI95-344): If the result type is class-wide,
               --  insert a check that the level of the return expression's
               --  underlying type is not deeper than the level of the master
               --  enclosing the function.

               --  AI12-043: The check is made immediately after the return
               --  object is created.

               if Is_Class_Wide_Type (Etype (Func_Id)) then
                  Apply_CW_Accessibility_Check (Expr_Q, Func_Id);
               end if;
            end;
         end if;

      --  If this is the return object of a function returning on the secondary
      --  stack, convert the declaration to a renaming of the dereference of ah
      --  allocator for the secondary stack.

      --    Result : T [:= <expression>];

      --  is converted to

      --    type Txx is access all ...;
      --    Rxx : constant Txx :=
      --      new <expression-type>['(<expression>)][storage_pool =
      --        system__secondary_stack__ss_pool][procedure_to_call =
      --        system__secondary_stack__ss_allocate];

      --    Result : T renames Rxx.all;

      elsif Is_Secondary_Stack_Return_Object (Def_Id) then
         declare
            Desig_Typ : constant Entity_Id :=
              (if Ekind (Typ) = E_Array_Subtype
               then Etype (Func_Id) else Typ);
            --  Ensure that the we use a fat pointer when allocating
            --  an unconstrained array on the heap. In this case the
            --  result object's type is a constrained array type even
            --  though the function's type is unconstrained.

            Acc_Typ        : Entity_Id;
            Alloc_Obj_Decl : Node_Id;
            Alloc_Obj_Id   : Entity_Id;
            Ptr_Type_Decl  : Node_Id;

         begin
            --  Create an access type designating the function's
            --  result subtype.

            Acc_Typ := Make_Temporary (Loc, 'A');

            Ptr_Type_Decl :=
              Make_Full_Type_Declaration (Loc,
                Defining_Identifier => Acc_Typ,
                Type_Definition     =>
                  Make_Access_To_Object_Definition (Loc,
                    All_Present        => True,
                    Subtype_Indication =>
                      New_Occurrence_Of (Desig_Typ, Loc)));

            Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks);

            Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));

            Alloc_Obj_Id := Make_Temporary (Loc, 'R');

            Alloc_Obj_Decl :=
              Make_Object_Declaration (Loc,
                Defining_Identifier => Alloc_Obj_Id,
                Constant_Present    => True,
                Object_Definition   =>
                  New_Occurrence_Of (Acc_Typ, Loc),
                Expression => Make_Allocator_For_Return (Expr_Q));

            Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);

            Set_Uses_Sec_Stack (Func_Id);
            Set_Uses_Sec_Stack (Scope (Def_Id));
            Set_Sec_Stack_Needed_For_Return (Scope (Def_Id));

            --  From now on, the type of the return object is the
            --  designated type.

            if Desig_Typ /= Typ then
               Set_Etype (Def_Id, Desig_Typ);
               Set_Actual_Subtype (Def_Id, Typ);
            end if;

            --  Initialize the object now that it has got its final subtype,
            --  but before rewriting it as a renaming.

            Initialize_Return_Object
              (Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After);

            --  Replace the return object declaration with a renaming of a
            --  dereference of the access value designating the return object.

            Expr_Q :=
              Make_Explicit_Dereference (Loc,
                Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc));
            Set_Etype (Expr_Q, Etype (Def_Id));

            Rewrite_As_Renaming := True;
         end;

      --  If this is the return object of a function returning a by-reference
      --  type, convert the declaration to a renaming of the dereference of ah
      --  allocator for the return stack.

      --    Result : T [:= <expression>];

      --  is converted to

      --    type Txx is access all ...;
      --    Rxx : constant Txx :=
      --      new <expression-type>['(<expression>)][storage_pool =
      --        system__return_stack__rs_pool][procedure_to_call =
      --        system__return_stack__rs_allocate];

      --    Result : T renames Rxx.all;

      elsif Back_End_Return_Slot
        and then Is_By_Reference_Return_Object (Def_Id)
      then
         declare
            Acc_Typ        : Entity_Id;
            Alloc_Obj_Decl : Node_Id;
            Alloc_Obj_Id   : Entity_Id;
            Ptr_Type_Decl  : Node_Id;

         begin
            --  Create an access type designating the function's
            --  result subtype.

            Acc_Typ := Make_Temporary (Loc, 'A');

            Ptr_Type_Decl :=
              Make_Full_Type_Declaration (Loc,
                Defining_Identifier => Acc_Typ,
                Type_Definition     =>
                  Make_Access_To_Object_Definition (Loc,
                    All_Present        => True,
                    Subtype_Indication =>
                      New_Occurrence_Of (Typ, Loc)));

            Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks);

            Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_RS_Pool));

            Alloc_Obj_Id := Make_Temporary (Loc, 'R');

            Alloc_Obj_Decl :=
              Make_Object_Declaration (Loc,
                Defining_Identifier => Alloc_Obj_Id,
                Constant_Present    => True,
                Object_Definition   =>
                  New_Occurrence_Of (Acc_Typ, Loc),
                Expression => Make_Allocator_For_Return (Expr_Q));

            Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);

            --  Initialize the object now that it has got its final subtype,
            --  but before rewriting it as a renaming.

            Initialize_Return_Object
              (Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After);

            --  Replace the return object declaration with a renaming of a
            --  dereference of the access value designating the return object.

            Expr_Q :=
              Make_Explicit_Dereference (Loc,
                Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc));
            Set_Etype (Expr_Q, Etype (Def_Id));

            Rewrite_As_Renaming := True;
         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 Rewrite_As_Renaming then
         Rewrite (N,
           Make_Object_Renaming_Declaration (Loc,
             Defining_Identifier => Def_Id,
             Subtype_Mark        => New_Occurrence_Of (Etype (Def_Id), Loc),
             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 (Def_Id, 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.

         Set_Debug_Info_Defining_Id (N);

         --  Now call the routine to generate debug info for the renaming

         Insert_Action (N, Debug_Renaming_Declaration (N));
      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 and 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;

      --  Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3

      if Nkind (Parent (N)) in N_Constrained_Array_Definition | N_Slice
        and then Nkind (Parent (Parent (N))) not in
                   N_Full_Type_Declaration | N_Object_Declaration
      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. Within a generic we still need to set Parent_Subtype
      --  link because the visibility of inherited components will have to be
      --  verified in subsequent instances.

      if not Expander_Active then
         if Inside_A_Generic and then Ekind (T) = E_Record_Type then
            Set_Parent_Subtype (T, Etype (T));
         end if;
         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. But the Finalize_Address routine is missing if the type is
         --  class-wide and we are under restriction No_Dispatching_Calls, see
         --  Expand_Freeze_Class_Wide_Type above for the rationale.

         elsif Needs_Finalization (Typ)
           and then (not Is_Class_Wide_Type (Typ)
                      or else not Restriction_Active (No_Dispatching_Calls))
           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;
      Saved_IGR : constant Node_Id         := Ignored_Ghost_Region;
      --  Save the Ghost-related attributes 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 (Def_Id) in 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))
              and then RTU_Loaded (System_Storage_Pools_Subpools)
            then
               declare
                  Loc   : constant Source_Ptr := Sloc (Def_Id);
                  Pool  : constant Entity_Id :=
                            Associated_Storage_Pool (Def_Id);

               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)
                       > Static_Accessibility_Level (Pool, Object_Decl_Level)
                    and then Is_Class_Wide_Type (Etype (Pool))
                    and then not Accessibility_Checks_Suppressed (Def_Id)
                    and then not Accessibility_Checks_Suppressed (Pool)
                  then
                     --  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;

                     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
                                   (RTE
                                     (RE_Root_Storage_Pool_With_Subpools)),
                                  Loc)),
                         Then_Statements => New_List (
                           Make_Raise_Program_Error (Loc,
                             Reason => PE_Accessibility_Check_Failed))));
                  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, except do it for types
            --  that are the full view of types derived from other private
            --  types and for access types used to implement indirect temps.
            --  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)
              and then not Old_Attr_Util.Indirect_Temps
                             .Is_Access_Type_For_Indirect_Temp (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 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. But skip internal types.

      if Is_Itype (Def_Id) then
         null;

      elsif 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.

      else
         if Has_Invariants (Def_Id) then
            if not Predicate_Check_In_Scope (Def_Id)
              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;

         --  Generate the [spec and] body of the procedure tasked with the
         --  run-time verification of pragma Default_Initial_Condition's
         --  expression.

         if Has_DIC (Def_Id) then
            Build_DIC_Procedure_Body (Def_Id);
         end if;
      end if;

      Restore_Ghost_Region (Saved_GM, Saved_IGR);

      return Result;

   exception
      when RE_Not_Available =>
         Restore_Ghost_Region (Saved_GM, Saved_IGR);

         return False;
   end Freeze_Type;

   -------------------------
   -- Get_Simple_Init_Val --
   -------------------------

   function Get_Simple_Init_Val
     (Typ  : Entity_Id;
      N    : Node_Id;
      Size : Uint := No_Uint) return Node_Id
   is
      IV_Attribute : constant Boolean :=
                       Nkind (N) = N_Attribute_Reference
                         and then Attribute_Name (N) = Name_Invalid_Value;

      Loc : constant Source_Ptr := Sloc (N);

      procedure Extract_Subtype_Bounds
        (Lo_Bound : out Uint;
         Hi_Bound : out Uint);
      --  Inspect subtype Typ as well its ancestor subtypes and derived types
      --  to determine the best known information about the bounds of the type.
      --  The output parameters are set as follows:
      --
      --    * Lo_Bound - Set to No_Unit when there is no information available,
      --      or to the known low bound.
      --
      --    * Hi_Bound - Set to No_Unit when there is no information available,
      --      or to the known high bound.

      function Simple_Init_Array_Type return Node_Id;
      --  Build an expression to initialize array type Typ

      function Simple_Init_Defaulted_Type return Node_Id;
      --  Build an expression to initialize type Typ which is subject to
      --  aspect Default_Value.

      function Simple_Init_Initialize_Scalars_Type
        (Size_To_Use : Uint) return Node_Id;
      --  Build an expression to initialize scalar type Typ which is subject to
      --  pragma Initialize_Scalars. Size_To_Use is the size of the object.

      function Simple_Init_Normalize_Scalars_Type
        (Size_To_Use : Uint) return Node_Id;
      --  Build an expression to initialize scalar type Typ which is subject to
      --  pragma Normalize_Scalars. Size_To_Use is the size of the object.

      function Simple_Init_Private_Type return Node_Id;
      --  Build an expression to initialize private type Typ

      function Simple_Init_Scalar_Type return Node_Id;
      --  Build an expression to initialize scalar type Typ

      ----------------------------
      -- Extract_Subtype_Bounds --
      ----------------------------

      procedure Extract_Subtype_Bounds
        (Lo_Bound : out Uint;
         Hi_Bound : out Uint)
      is
         ST1    : Entity_Id;
         ST2    : Entity_Id;
         Lo     : Node_Id;
         Hi     : Node_Id;
         Lo_Val : Uint;
         Hi_Val : Uint;

      begin
         Lo_Bound := No_Uint;
         Hi_Bound := No_Uint;

         --  Loop to climb ancestor subtypes and derived types

         ST1 := Typ;
         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
               Lo_Val := Expr_Value (Lo);

               if No (Lo_Bound) or else Lo_Bound < Lo_Val then
                  Lo_Bound := Lo_Val;
               end if;
            end if;

            if Compile_Time_Known_Value (Hi) then
               Hi_Val := Expr_Value (Hi);

               if No (Hi_Bound) or else Hi_Bound > Hi_Val then
                  Hi_Bound := Hi_Val;
               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 Extract_Subtype_Bounds;

      ----------------------------
      -- Simple_Init_Array_Type --
      ----------------------------

      function Simple_Init_Array_Type return Node_Id is
         Comp_Typ : constant Entity_Id := Component_Type (Typ);

         function Simple_Init_Dimension (Index : Node_Id) return Node_Id;
         --  Initialize a single array dimension with index constraint Index

         --------------------
         -- Simple_Init_Dimension --
         --------------------

         function Simple_Init_Dimension (Index : Node_Id) return Node_Id is
         begin
            --  Process the current dimension

            if Present (Index) then

               --  Build a suitable "others" aggregate for the next dimension,
               --  or initialize the component itself. Generate:
               --
               --    (others => ...)

               return
                 Make_Aggregate (Loc,
                   Component_Associations => New_List (
                     Make_Component_Association (Loc,
                       Choices    => New_List (Make_Others_Choice (Loc)),
                       Expression =>
                         Simple_Init_Dimension (Next_Index (Index)))));

            --  Otherwise all dimensions have been processed. Initialize the
            --  component itself.

            else
               return
                 Get_Simple_Init_Val
                   (Typ  => Comp_Typ,
                    N    => N,
                    Size => Esize (Comp_Typ));
            end if;
         end Simple_Init_Dimension;

      --  Start of processing for Simple_Init_Array_Type

      begin
         return Simple_Init_Dimension (First_Index (Typ));
      end Simple_Init_Array_Type;

      --------------------------------
      -- Simple_Init_Defaulted_Type --
      --------------------------------

      function Simple_Init_Defaulted_Type return Node_Id is
         Subtyp : Entity_Id := First_Subtype (Typ);

      begin
         --  When the first subtype is private, retrieve the expression of the
         --  Default_Value from the underlying type.

         if Is_Private_Type (Subtyp) then
            Subtyp := Full_View (Subtyp);
         end if;

         --  Use the Sloc of the context node when constructing the initial
         --  value because the expression of Default_Value may come from a
         --  different unit. Updating the Sloc will result in accurate error
         --  diagnostics.

         return
           OK_Convert_To
             (Typ  => Typ,
              Expr =>
                New_Copy_Tree
                  (Source   => Default_Aspect_Value (Subtyp),
                   New_Sloc => Loc));
      end Simple_Init_Defaulted_Type;

      -----------------------------------------
      -- Simple_Init_Initialize_Scalars_Type --
      -----------------------------------------

      function Simple_Init_Initialize_Scalars_Type
        (Size_To_Use : Uint) return Node_Id
      is
         Float_Typ : Entity_Id;
         Hi_Bound  : Uint;
         Lo_Bound  : Uint;
         Scal_Typ  : Scalar_Id;

      begin
         Extract_Subtype_Bounds (Lo_Bound, Hi_Bound);

         --  Float types

         if Is_Floating_Point_Type (Typ) then
            Float_Typ := Root_Type (Typ);

            if Float_Typ = Standard_Short_Float then
               Scal_Typ := Name_Short_Float;
            elsif Float_Typ = Standard_Float then
               Scal_Typ := Name_Float;
            elsif Float_Typ = Standard_Long_Float then
               Scal_Typ := Name_Long_Float;
            else pragma Assert (Float_Typ = Standard_Long_Long_Float);
               Scal_Typ := Name_Long_Long_Float;
            end if;

         --  If zero is invalid, it is a convenient value to use that is for
         --  sure an appropriate invalid value in all situations.

         elsif Present (Lo_Bound) and then Lo_Bound > Uint_0 then
            return Make_Integer_Literal (Loc, 0);

         --  Unsigned types

         elsif Is_Unsigned_Type (Typ) then
            if Size_To_Use <= 8 then
               Scal_Typ := Name_Unsigned_8;
            elsif Size_To_Use <= 16 then
               Scal_Typ := Name_Unsigned_16;
            elsif Size_To_Use <= 32 then
               Scal_Typ := Name_Unsigned_32;
            elsif Size_To_Use <= 64 then
               Scal_Typ := Name_Unsigned_64;
            else
               Scal_Typ := Name_Unsigned_128;
            end if;

         --  Signed types

         else
            if Size_To_Use <= 8 then
               Scal_Typ := Name_Signed_8;
            elsif Size_To_Use <= 16 then
               Scal_Typ := Name_Signed_16;
            elsif Size_To_Use <= 32 then
               Scal_Typ := Name_Signed_32;
            elsif Size_To_Use <= 64 then
               Scal_Typ := Name_Signed_64;
            else
               Scal_Typ := Name_Signed_128;
            end if;
         end if;

         --  Use the values specified by pragma Initialize_Scalars or the ones
         --  provided by the binder. Higher precedence is given to the pragma.

         return Invalid_Scalar_Value (Loc, Scal_Typ);
      end Simple_Init_Initialize_Scalars_Type;

      ----------------------------------------
      -- Simple_Init_Normalize_Scalars_Type --
      ----------------------------------------

      function Simple_Init_Normalize_Scalars_Type
        (Size_To_Use : Uint) return Node_Id
      is
         Signed_Size : constant Uint := UI_Min (Uint_63, Size_To_Use - 1);

         Expr     : Node_Id;
         Hi_Bound : Uint;
         Lo_Bound : Uint;

      begin
         Extract_Subtype_Bounds (Lo_Bound, Hi_Bound);

         --  If zero is invalid, it is a convenient value to use that is for
         --  sure an appropriate invalid value in all situations.

         if Present (Lo_Bound) and then Lo_Bound > Uint_0 then
            Expr := 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_Enumeration_Type (Typ)
           or else Is_Floating_Point_Type (Typ)
           or else Is_Unsigned_Type (Typ)
         then
            Expr := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);

            --  Resolve as Long_Long_Long_Unsigned, because the largest number
            --  we can generate is out of range of universal integer.

            Analyze_And_Resolve (Expr, Standard_Long_Long_Long_Unsigned);

         --  Case of signed types

         else
            --  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 Present (Lo_Bound) and then Present (Hi_Bound)
              and then Lo_Bound <= (-(2 ** Signed_Size))
              and then Hi_Bound < 2 ** Signed_Size
            then
               Expr := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);

            --  Normal case of largest negative value

            else
               Expr := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
            end if;
         end if;

         return Expr;
      end Simple_Init_Normalize_Scalars_Type;

      ------------------------------
      -- Simple_Init_Private_Type --
      ------------------------------

      function Simple_Init_Private_Type return Node_Id is
         Under_Typ : constant Entity_Id := Underlying_Type (Typ);
         Expr      : Node_Id;

      begin
         --  The availability of the underlying view must be checked by routine
         --  Needs_Simple_Initialization.

         pragma Assert (Present (Under_Typ));

         Expr := Get_Simple_Init_Val (Under_Typ, N, Size);

         --  If the initial value is null or an aggregate, qualify it with the
         --  underlying type in order to provide a proper context.

         if Nkind (Expr) in N_Aggregate | N_Null then
            Expr :=
              Make_Qualified_Expression (Loc,
                Subtype_Mark => New_Occurrence_Of (Under_Typ, Loc),
                Expression   => Expr);
         end if;

         Expr := Unchecked_Convert_To (Typ, Expr);

         --  Do not truncate the result when scalar types are involved and
         --  Initialize/Normalize_Scalars is in effect.

         if Nkind (Expr) = N_Unchecked_Type_Conversion
           and then Is_Scalar_Type (Under_Typ)
         then
            Set_No_Truncation (Expr);
         end if;

         return Expr;
      end Simple_Init_Private_Type;

      -----------------------------
      -- Simple_Init_Scalar_Type --
      -----------------------------

      function Simple_Init_Scalar_Type return Node_Id is
         Expr        : Node_Id;
         Size_To_Use : Uint;

      begin
         pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);

         --  Determine the size of the object. This is either the size provided
         --  by the caller, or the Esize of the scalar type.

         if No (Size) or else Size <= Uint_0 then
            Size_To_Use := UI_Max (Uint_1, Esize (Typ));
         else
            Size_To_Use := Size;
         end if;

         --  The maximum size to use is System_Max_Integer_Size bits. This
         --  will create values of type Long_Long_Long_Unsigned and the range
         --  must fit this type.

         if Present (Size_To_Use)
           and then Size_To_Use > System_Max_Integer_Size
         then
            Size_To_Use := UI_From_Int (System_Max_Integer_Size);
         end if;

         if Normalize_Scalars and then not IV_Attribute then
            Expr := Simple_Init_Normalize_Scalars_Type (Size_To_Use);
         else
            Expr := Simple_Init_Initialize_Scalars_Type (Size_To_Use);
         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.

         Expr := Unchecked_Convert_To (Base_Type (Typ), Expr);

         --  Ensure that the expression is not truncated since the "bad" bits
         --  are desired, and also kill the range checks.

         if Nkind (Expr) = N_Unchecked_Type_Conversion then
            Set_Kill_Range_Check (Expr);
            Set_No_Truncation    (Expr);
         end if;

         return Expr;
      end Simple_Init_Scalar_Type;

   --  Start of processing for Get_Simple_Init_Val

   begin
      if Is_Private_Type (Typ) then
         return Simple_Init_Private_Type;

      elsif Is_Scalar_Type (Typ) then
         if Has_Default_Aspect (Typ) then
            return Simple_Init_Defaulted_Type;
         else
            return Simple_Init_Scalar_Type;
         end if;

      --  Array type with Initialize or Normalize_Scalars

      elsif Is_Array_Type (Typ) then
         pragma Assert (Init_Or_Norm_Scalars);
         return Simple_Init_Array_Type;

      --  Access type is initialized to null

      elsif Is_Access_Type (Typ) 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;

   package body Initialization_Control is

      ------------------------
      -- Requires_Late_Init --
      ------------------------

      function Requires_Late_Init
        (Decl     : Node_Id;
         Rec_Type : Entity_Id) return Boolean
      is
         References_Current_Instance : Boolean := False;
         Has_Access_Discriminant     : Boolean := False;
         Has_Internal_Call           : Boolean := False;

         function Find_Access_Discriminant
           (N : Node_Id) return Traverse_Result;
         --  Look for a name denoting an access discriminant

         function Find_Current_Instance
           (N : Node_Id) return Traverse_Result;
         --  Look for a reference to the current instance of the type

         function Find_Internal_Call
           (N : Node_Id) return Traverse_Result;
         --  Look for an internal protected function call

         ------------------------------
         -- Find_Access_Discriminant --
         ------------------------------

         function Find_Access_Discriminant
           (N : Node_Id) return Traverse_Result is
         begin
            if Is_Entity_Name (N)
              and then Denotes_Discriminant (N)
              and then Is_Access_Type (Etype (N))
            then
               Has_Access_Discriminant := True;
               return Abandon;
            else
               return OK;
            end if;
         end Find_Access_Discriminant;

         ---------------------------
         -- Find_Current_Instance --
         ---------------------------

         function Find_Current_Instance
           (N : Node_Id) return Traverse_Result is
         begin
            if Is_Entity_Name (N)
              and then Present (Entity (N))
              and then Is_Current_Instance (N)
            then
               References_Current_Instance := True;
               return Abandon;
            else
               return OK;
            end if;
         end Find_Current_Instance;

         ------------------------
         -- Find_Internal_Call --
         ------------------------

         function Find_Internal_Call (N : Node_Id) return Traverse_Result is

            function Call_Scope (N : Node_Id) return Entity_Id;
            --  Return the scope enclosing a given call node N

            ----------------
            -- Call_Scope --
            ----------------

            function Call_Scope (N : Node_Id) return Entity_Id is
               Nam : constant Node_Id := Name (N);
            begin
               if Nkind (Nam) = N_Selected_Component then
                  return Scope (Entity (Prefix (Nam)));
               else
                  return Scope (Entity (Nam));
               end if;
            end Call_Scope;

         begin
            if Nkind (N) = N_Function_Call
              and then Call_Scope (N)
                         = Corresponding_Concurrent_Type (Rec_Type)
            then
               Has_Internal_Call := True;
               return Abandon;
            else
               return OK;
            end if;
         end Find_Internal_Call;

         procedure Search_Access_Discriminant is new
           Traverse_Proc (Find_Access_Discriminant);

         procedure Search_Current_Instance is new
           Traverse_Proc (Find_Current_Instance);

         procedure Search_Internal_Call is new
           Traverse_Proc (Find_Internal_Call);

         --  Start of processing for Requires_Late_Init

      begin
         --  A component of an object is said to require late initialization
         --  if:

         --  it has an access discriminant value constrained by a per-object
         --  expression;

         if Has_Access_Constraint (Defining_Identifier (Decl))
           and then No (Expression (Decl))
         then
            return True;

         elsif Present (Expression (Decl)) then

            --  it has an initialization expression that includes a name
            --  denoting an access discriminant;

            Search_Access_Discriminant (Expression (Decl));

            if Has_Access_Discriminant then
               return True;
            end if;

            --  or it has an initialization expression that includes a
            --  reference to the current instance of the type either by
            --  name...

            Search_Current_Instance (Expression (Decl));

            if References_Current_Instance then
               return True;
            end if;

            --  ...or implicitly as the target object of a call.

            if Is_Protected_Record_Type (Rec_Type) then
               Search_Internal_Call (Expression (Decl));

               if Has_Internal_Call then
                  return True;
               end if;
            end if;
         end if;

         return False;
      end Requires_Late_Init;

      -----------------------------
      -- Has_Late_Init_Component --
      -----------------------------

      function Has_Late_Init_Component
        (Tagged_Rec_Type : Entity_Id) return Boolean
      is
         Comp_Id : Entity_Id :=
           First_Component (Implementation_Base_Type (Tagged_Rec_Type));
      begin
         while Present (Comp_Id) loop
            if Requires_Late_Init (Decl     => Parent (Comp_Id),
                                   Rec_Type => Tagged_Rec_Type)
            then
               return True; -- found a component that requires late init

            elsif Chars (Comp_Id) = Name_uParent
              and then Has_Late_Init_Component (Etype (Comp_Id))
            then
               return True; -- an ancestor type has a late init component
            end if;

            Next_Component (Comp_Id);
         end loop;

         return False;
      end Has_Late_Init_Component;

      ------------------------
      -- Tag_Init_Condition --
      ------------------------

      function Tag_Init_Condition
        (Loc : Source_Ptr;
         Init_Control_Formal : Entity_Id) return Node_Id is
      begin
         return Make_Op_Eq (Loc,
                  New_Occurrence_Of (Init_Control_Formal, Loc),
                  Make_Mode_Literal (Loc, Full_Init));
      end Tag_Init_Condition;

      --------------------------
      -- Early_Init_Condition --
      --------------------------

      function Early_Init_Condition
        (Loc : Source_Ptr;
         Init_Control_Formal : Entity_Id) return Node_Id is
      begin
         return Make_Op_Ne (Loc,
                  New_Occurrence_Of (Init_Control_Formal, Loc),
                  Make_Mode_Literal (Loc, Late_Init_Only));
      end Early_Init_Condition;

      -------------------------
      -- Late_Init_Condition --
      -------------------------

      function Late_Init_Condition
        (Loc : Source_Ptr;
         Init_Control_Formal : Entity_Id) return Node_Id is
      begin
         return Make_Op_Ne (Loc,
                  New_Occurrence_Of (Init_Control_Formal, Loc),
                  Make_Mode_Literal (Loc, Early_Init_Only));
      end Late_Init_Condition;

   end Initialization_Control;

   ----------------------------
   -- 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
                        pragma Assert
                          (Nkind (Parent (Comp)) = N_Component_Declaration);

                        if 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; Proc_Id : Entity_Id) return List_Id
   is
      Loc        : constant Source_Ptr := Sloc (Typ);
      Unc_Arr    : constant Boolean :=
                     Is_Array_Type (Typ) and then not Is_Constrained (Typ);
      With_Prot  : constant Boolean :=
                     Has_Protected (Typ)
                       or else (Is_Record_Type (Typ)
                                 and then Is_Protected_Record_Type (Typ));
      With_Task  : constant Boolean :=
                     not Global_No_Tasking
                       and then
                     (Has_Task (Typ)
                        or else (Is_Record_Type (Typ)
                                   and then Is_Task_Record_Type (Typ)));
      Formals : List_Id;

   begin
      --  The first parameter is always _Init : [in] out Typ. Note that we need
      --  it to be in/out in the case of an unconstrained array, because of the
      --  need to have the bounds, and in the case of protected or task record
      --  value, because there are default record fields 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          => Unc_Arr or else With_Prot or else With_Task,
          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 With_Task then
         Append_To (Formals,
           Make_Parameter_Specification (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uMaster),
             Parameter_Type      =>
               New_Occurrence_Of (Standard_Integer, Loc)));

         Set_Has_Master_Entity (Proc_Id);

         --  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;

      --  Due to certain edge cases such as arrays with null-excluding
      --  components being built with the secondary stack it becomes necessary
      --  to add a formal to the Init_Proc which controls whether we raise
      --  Constraint_Errors on generated calls for internal object
      --  declarations.

      if Needs_Conditional_Null_Excluding_Check (Typ) then
         Append_To (Formals,
           Make_Parameter_Specification (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc,
                 New_External_Name (Chars
                   (Component_Type (Typ)), "_skip_null_excluding_check")),
             Expression          => New_Occurrence_Of (Standard_False, Loc),
             In_Present          => True,
             Parameter_Type      =>
               New_Occurrence_Of (Standard_Boolean, 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'Unrestricted_Access)

            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_Op_Minus (Loc,
                       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_Unrestricted_Access)))));

            --  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_Op_Minus (Loc,
                    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_Op_Minus (Loc,
                         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 not Building_Static_Secondary_DT (Typ)
              and then 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_Op_Minus (Loc,
                         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));

                  --  Move this check to sem???
                  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
               Initialize_Tag
                 (Typ       => Full_Typ,
                  Iface     => Node (Iface_Elmt),
                  Tag_Comp  => Tag_Comp,
                  Iface_Tag => Node (Iface_Tag_Elmt));
            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
                 (Typ       => 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_Null_Statement_List --
   ----------------------------

   function Is_Null_Statement_List (Stmts : List_Id) return Boolean is
      Stmt : Node_Id;

   begin
      --  We must skip SCIL nodes because they may have been added to the list
      --  by Insert_Actions.

      Stmt := First_Non_SCIL_Node (Stmts);
      while Present (Stmt) loop
         if Nkind (Stmt) = N_Case_Statement then
            declare
               Alt : Node_Id;
            begin
               Alt := First (Alternatives (Stmt));
               while Present (Alt) loop
                  if not Is_Null_Statement_List (Statements (Alt)) then
                     return False;
                  end if;

                  Next (Alt);
               end loop;
            end;

         elsif Nkind (Stmt) /= N_Null_Statement then
            return False;
         end if;

         Stmt := Next_Non_SCIL_Node (Stmt);
      end loop;

      return True;
   end Is_Null_Statement_List;

   ----------------------------------------
   -- 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);

      function Make_Wrapper_Specification (Subp : Entity_Id) return Node_Id;
      --  Returns a function specification with the same profile as Subp

      --------------------------------
      -- Make_Wrapper_Specification --
      --------------------------------

      function Make_Wrapper_Specification (Subp : Entity_Id) return Node_Id is
      begin
         return
           Make_Function_Specification (Loc,
             Defining_Unit_Name       =>
               Make_Defining_Identifier (Loc,
                 Chars => Chars (Subp)),
             Parameter_Specifications =>
               Copy_Parameter_List (Subp),
             Result_Definition        =>
               New_Occurrence_Of (Etype (Subp), Loc));
      end Make_Wrapper_Specification;

      Prim_Elmt   : Elmt_Id;
      Subp        : Entity_Id;
      Actual_List : List_Id;
      Formal      : Entity_Id;
      Par_Formal  : Entity_Id;
      Ext_Aggr    : Node_Id;
      Formal_Node : Node_Id;
      Func_Body   : Node_Id;
      Func_Decl   : Node_Id;
      Func_Id     : Entity_Id;

   --  Start of processing for Make_Controlling_Function_Wrappers

   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
            --  If there is a non-overloadable homonym in the current
            --  scope, the implicit declaration remains invisible.
            --  We check the current entity with the same name, or its
            --  homonym in case the derivation takes place after the
            --  hiding object declaration.

            if Present (Current_Entity (Subp)) then
               declare
                  Curr : constant Entity_Id := Current_Entity (Subp);
                  Prev : constant Entity_Id := Homonym (Curr);
               begin
                  if (Comes_From_Source (Curr)
                    and then Scope (Curr) = Current_Scope
                    and then not Is_Overloadable (Curr))
                  or else
                    (Present (Prev)
                      and then Comes_From_Source (Prev)
                      and then Scope (Prev) = Current_Scope
                      and then not Is_Overloadable (Prev))
                  then
                     goto Next_Prim;
                  end if;
               end;
            end if;

            Func_Decl :=
              Make_Subprogram_Declaration (Loc,
                Specification => Make_Wrapper_Specification (Subp));

            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 (Parameter_Specifications (Specification (Func_Decl)));

            if Present (Formal) then
               Actual_List := New_List;

               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;
            else
               Actual_List := No_List;
            end if;

            Ext_Aggr :=
              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);

            --  GNATprove will use expression of an expression function as an
            --  implicit postcondition. GNAT will also benefit from expression
            --  function to avoid premature freezing, but would struggle if we
            --  added an expression function to freezing actions, so we create
            --  the expanded form directly.

            if GNATprove_Mode then
               Func_Body :=
                 Make_Expression_Function (Loc,
                   Specification =>
                     Make_Wrapper_Specification (Subp),
                   Expression => Ext_Aggr);
            else
               Func_Body :=
                 Make_Subprogram_Body (Loc,
                   Specification              =>
                     Make_Wrapper_Specification (Subp),
                   Declarations               => Empty_List,
                   Handled_Statement_Sequence =>
                     Make_Handled_Sequence_Of_Statements (Loc,
                       Statements => New_List (
                         Make_Simple_Return_Statement (Loc,
                           Expression => Ext_Aggr))));
               Set_Was_Expression_Function (Func_Body);
            end if;

            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.

            Func_Id := Defining_Unit_Name (Specification (Func_Decl));

            Mutate_Ekind (Func_Id, E_Function);
            Set_Is_Wrapper (Func_Id);

            --  Corresponding_Spec will be set again to the same value during
            --  analysis, but we need this information earlier.
            --  Expand_N_Freeze_Entity needs to know whether a subprogram body
            --  is a wrapper's body in order to get check suppression right.

            Set_Corresponding_Spec (Func_Body, Func_Id);
         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))));
      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

   --  Equality may be user-defined for a given component type, in which case
   --  a function call is constructed instead of an operator node. This is an
   --  Ada 2012 change in the composability of equality for untagged composite
   --  types.

   function Make_Eq_If
     (E : Entity_Id;
      L : List_Id) return Node_Id
   is
      Loc : constant Source_Ptr := Sloc (E);

      C          : Node_Id;
      Cond       : Node_Id;
      Field_Name : Name_Id;
      Next_Test  : Node_Id;
      Typ        : Entity_Id;

   begin
      if No (L) then
         return Make_Null_Statement (Loc);

      else
         Cond := Empty;

         C := First_Non_Pragma (L);
         while Present (C) loop
            Typ        := Etype (Defining_Identifier (C));
            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 (Typ)
            then
               null;

            elsif Field_Name /= Name_uTag then
               declare
                  Lhs : constant Node_Id :=
                    Make_Selected_Component (Loc,
                      Prefix        => Make_Identifier (Loc, Name_X),
                      Selector_Name => Make_Identifier (Loc, Field_Name));

                  Rhs : constant Node_Id :=
                    Make_Selected_Component (Loc,
                      Prefix        => Make_Identifier (Loc, Name_Y),
                      Selector_Name => Make_Identifier (Loc, Field_Name));
                  Eq_Call : Node_Id;

               begin
                  --  Build equality code with a user-defined operator, if
                  --  available, and with the predefined "=" otherwise. For
                  --  compatibility with older Ada versions, we also use the
                  --  predefined operation if the component-type equality is
                  --  abstract, rather than raising Program_Error.

                  if Ada_Version < Ada_2012 then
                     Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);

                  else
                     Eq_Call := Build_Eq_Call (Typ, Loc, Lhs, Rhs);

                     if No (Eq_Call) then
                        Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);

                     --  If a component has a defined abstract equality, its
                     --  application raises Program_Error on that component
                     --  and therefore on the current variant.

                     elsif Nkind (Eq_Call) = N_Raise_Program_Error then
                        Set_Etype (Eq_Call, Standard_Boolean);
                        Next_Test := Make_Op_Not (Loc, Eq_Call);

                     else
                        Next_Test := Make_Op_Not (Loc, Eq_Call);
                     end if;
                  end if;
               end;

               Evolve_Or_Else (Cond, Next_Test);
            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));
      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;

      Set_Handled_Statement_Sequence
        (Decl,
         Make_Handled_Sequence_Of_Statements (Loc, New_List (
           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)))))))));

      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;
      New_Param_Spec : Node_Id;
      New_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
            --  The null procedure spec is copied from the inherited procedure,
            --  except for the IS NULL (which must be added) and the overriding
            --  indicators (which must be removed, if present).

            New_Spec :=
              Copy_Subprogram_Spec (Subprogram_Specification (Subp), Loc);

            Set_Null_Present      (New_Spec, True);
            Set_Must_Override     (New_Spec, False);
            Set_Must_Not_Override (New_Spec, False);

            Formal := First_Formal (Subp);
            New_Param_Spec := First (Parameter_Specifications (New_Spec));

            while Present (Formal) loop

               --  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;

               Next_Formal (Formal);
               Next (New_Param_Spec);
            end loop;

            Append_To (Decl_List,
              Make_Subprogram_Declaration (Loc,
                Specification => New_Spec));
         end if;

         Next_Elmt (Prim_Elmt);
      end loop;

      return Decl_List;
   end Make_Null_Procedure_Specs;

   ---------------------------------------
   -- Make_Predefined_Primitive_Eq_Spec --
   ---------------------------------------

   procedure Make_Predefined_Primitive_Eq_Spec
     (Tag_Typ     : Entity_Id;
      Predef_List : 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);

      Eq_Name   : Name_Id := Name_Op_Eq;
      Eq_Needed : Boolean := True;
      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;

      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 (Predef_List, 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;
   end Make_Predefined_Primitive_Eq_Spec;

   -------------------------------------
   -- Make_Predefined_Primitive_Specs --
   -------------------------------------

   procedure Make_Predefined_Primitive_Specs
     (Tag_Typ     : Entity_Id;
      Predef_List : out List_Id;
      Renamed_Eq  : out Entity_Id)
   is
      Loc : constant Source_Ptr := Sloc (Tag_Typ);
      Res : constant List_Id    := New_List;

      use Exp_Put_Image;

   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));

      --  Spec of Put_Image

      if not No_Run_Time_Mode
        and then RTE_Available (RE_Root_Buffer_Type)
      then
         --  No_Run_Time_Mode implies that the declaration of Tag_Typ
         --  (like any tagged type) will be rejected. Given this, avoid
         --  cascading errors associated with the Tag_Typ's TSS_Put_Image
         --  procedure.

         Append_To (Res, Predef_Spec_Or_Body (Loc,
           Tag_Typ => Tag_Typ,
           Name    => Make_TSS_Name (Tag_Typ, TSS_Put_Image),
           Profile => Build_Put_Image_Profile (Loc, Tag_Typ)));
      end if;

      --  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
         Make_Predefined_Primitive_Eq_Spec (Tag_Typ, Res, Renamed_Eq);

         --  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 Ravenscar or ZFP is active

      if Ada_Version >= Ada_2005
        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_Id   : constant Entity_Id  := Defining_Identifier (N);
      Expr     : constant Node_Id    := Expression (N);
      Typ      : constant Entity_Id  := Etype (Def_Id);
      Full_Typ : constant Entity_Id  := Underlying_Type (Typ);

   begin
      --  This expansion activity is called during analysis

      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 (Unqualify (Expr)) /= N_Aggregate
      then
         return
           Make_Tag_Assignment_From_Type
             (Loc, New_Occurrence_Of (Def_Id, Loc), Full_Typ);

      else
         return Empty;
      end if;
   end Make_Tag_Assignment;

   ----------------------
   -- 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;

      --  Declare an abstract subprogram for primitive subprograms of an
      --  interface type (except for "=").

      if Is_Interface (Tag_Typ) then
         if Name /= Name_Op_Eq then
            return Make_Abstract_Subprogram_Declaration (Loc, Spec);

         --  The equality function (if any) for an interface type is defined
         --  to be nonabstract, so we create an expression function for it that
         --  always returns False. Note that the function can never actually be
         --  invoked because interface types are abstract, so there aren't any
         --  objects of such types (and their equality operation will always
         --  dispatch).

         else
            return Make_Expression_Function
                     (Loc, Spec, New_Occurrence_Of (Standard_False, Loc));
         end if;

      --  If body case, return empty subprogram body. Note that this is ill-
      --  formed, because there is not even a null statement, and certainly not
      --  a return in the function case. The caller is expected to do surgery
      --  on the body to add the appropriate stuff.

      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) 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 => False);
   end Predef_Stream_Attr_Spec;

   ----------------------------------
   -- Predefined_Primitive_Eq_Body --
   ----------------------------------

   procedure Predefined_Primitive_Eq_Body
     (Tag_Typ     : Entity_Id;
      Predef_List : List_Id;
      Renamed_Eq  : Entity_Id)
   is
      Decl      : Node_Id;
      Eq_Needed : Boolean;
      Eq_Name   : Name_Id;
      Prim      : Elmt_Id;

   begin
      --  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 Is_User_Defined_Equality (Node (Prim))
              and then not Is_Internal (Node (Prim))
            then
               Eq_Needed := False;
               Eq_Name := No_Name;
               exit;
            end if;

            Next_Elmt (Prim);
         end loop;

      else
         Eq_Needed := False;
         Eq_Name   := No_Name;

         Prim := First_Elmt (Primitive_Operations (Tag_Typ));
         while Present (Prim) loop
            if Is_User_Defined_Equality (Node (Prim))
              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;

      --  If equality is needed, we will have its name

      pragma Assert (Eq_Needed = Present (Eq_Name));

      --  Body for equality

      if Eq_Needed then
         Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
         Append_To (Predef_List, Decl);
      end if;

      --  Body for inequality (if required)

      Decl := Make_Neq_Body (Tag_Typ);

      if Present (Decl) then
         Append_To (Predef_List, Decl);
      end if;
   end Predefined_Primitive_Eq_Body;

   ---------------------------------
   -- 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;
      Ent      : Entity_Id;

      pragma Warnings (Off, Ent);

      use Exp_Put_Image;

   begin
      pragma Assert (not Is_Interface (Tag_Typ));

      --  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);

      --  Body of Put_Image

      if No (TSS (Tag_Typ, TSS_Put_Image))
         and then not No_Run_Time_Mode
         and then RTE_Available (RE_Root_Buffer_Type)
      then
         Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent);
         Append_To (Res, Decl);
      end if;

      --  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 (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 (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
           (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 (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 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
          ((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_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) then
         --  Body for equality and inequality

         Predefined_Primitive_Eq_Body (Tag_Typ, Res, Renamed_Eq);

         --  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_Concurrent_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;