File : exp_ch3.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 3                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25 
  26 with Aspects;  use Aspects;
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Exp_Aggr; use Exp_Aggr;
  32 with Exp_Atag; use Exp_Atag;
  33 with Exp_Ch4;  use Exp_Ch4;
  34 with Exp_Ch6;  use Exp_Ch6;
  35 with Exp_Ch7;  use Exp_Ch7;
  36 with Exp_Ch9;  use Exp_Ch9;
  37 with Exp_Ch11; use Exp_Ch11;
  38 with Exp_Dbug; use Exp_Dbug;
  39 with Exp_Disp; use Exp_Disp;
  40 with Exp_Dist; use Exp_Dist;
  41 with Exp_Smem; use Exp_Smem;
  42 with Exp_Strm; use Exp_Strm;
  43 with Exp_Tss;  use Exp_Tss;
  44 with Exp_Util; use Exp_Util;
  45 with Freeze;   use Freeze;
  46 with Ghost;    use Ghost;
  47 with Inline;   use Inline;
  48 with Namet;    use Namet;
  49 with Nlists;   use Nlists;
  50 with Nmake;    use Nmake;
  51 with Opt;      use Opt;
  52 with Restrict; use Restrict;
  53 with Rident;   use Rident;
  54 with Rtsfind;  use Rtsfind;
  55 with Sem;      use Sem;
  56 with Sem_Aux;  use Sem_Aux;
  57 with Sem_Attr; use Sem_Attr;
  58 with Sem_Cat;  use Sem_Cat;
  59 with Sem_Ch3;  use Sem_Ch3;
  60 with Sem_Ch6;  use Sem_Ch6;
  61 with Sem_Ch8;  use Sem_Ch8;
  62 with Sem_Disp; use Sem_Disp;
  63 with Sem_Eval; use Sem_Eval;
  64 with Sem_Mech; use Sem_Mech;
  65 with Sem_Res;  use Sem_Res;
  66 with Sem_SCIL; use Sem_SCIL;
  67 with Sem_Type; use Sem_Type;
  68 with Sem_Util; use Sem_Util;
  69 with Sinfo;    use Sinfo;
  70 with Stand;    use Stand;
  71 with Snames;   use Snames;
  72 with Targparm; use Targparm;
  73 with Tbuild;   use Tbuild;
  74 with Ttypes;   use Ttypes;
  75 with Validsw;  use Validsw;
  76 
  77 package body Exp_Ch3 is
  78 
  79    -----------------------
  80    -- Local Subprograms --
  81    -----------------------
  82 
  83    procedure Adjust_Discriminants (Rtype : Entity_Id);
  84    --  This is used when freezing a record type. It attempts to construct
  85    --  more restrictive subtypes for discriminants so that the max size of
  86    --  the record can be calculated more accurately. See the body of this
  87    --  procedure for details.
  88 
  89    procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
  90    --  Build initialization procedure for given array type. Nod is a node
  91    --  used for attachment of any actions required in its construction.
  92    --  It also supplies the source location used for the procedure.
  93 
  94    function Build_Discriminant_Formals
  95      (Rec_Id : Entity_Id;
  96       Use_Dl : Boolean) return List_Id;
  97    --  This function uses the discriminants of a type to build a list of
  98    --  formal parameters, used in Build_Init_Procedure among other places.
  99    --  If the flag Use_Dl is set, the list is built using the already
 100    --  defined discriminals of the type, as is the case for concurrent
 101    --  types with discriminants. Otherwise new identifiers are created,
 102    --  with the source names of the discriminants.
 103 
 104    function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
 105    --  This function builds a static aggregate that can serve as the initial
 106    --  value for an array type whose bounds are static, and whose component
 107    --  type is a composite type that has a static equivalent aggregate.
 108    --  The equivalent array aggregate is used both for object initialization
 109    --  and for component initialization, when used in the following function.
 110 
 111    function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
 112    --  This function builds a static aggregate that can serve as the initial
 113    --  value for a record type whose components are scalar and initialized
 114    --  with compile-time values, or arrays with similar initialization or
 115    --  defaults. When possible, initialization of an object of the type can
 116    --  be achieved by using a copy of the aggregate as an initial value, thus
 117    --  removing the implicit call that would otherwise constitute elaboration
 118    --  code.
 119 
 120    procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id);
 121    --  Build record initialization procedure. N is the type declaration
 122    --  node, and Rec_Ent is the corresponding entity for the record type.
 123 
 124    procedure Build_Slice_Assignment (Typ : Entity_Id);
 125    --  Build assignment procedure for one-dimensional arrays of controlled
 126    --  types. Other array and slice assignments are expanded in-line, but
 127    --  the code expansion for controlled components (when control actions
 128    --  are active) can lead to very large blocks that GCC3 handles poorly.
 129 
 130    procedure Build_Untagged_Equality (Typ : Entity_Id);
 131    --  AI05-0123: Equality on untagged records composes. This procedure
 132    --  builds the equality routine for an untagged record that has components
 133    --  of a record type that has user-defined primitive equality operations.
 134    --  The resulting operation is a TSS subprogram.
 135 
 136    procedure Build_Variant_Record_Equality (Typ  : Entity_Id);
 137    --  Create An Equality function for the untagged variant record Typ and
 138    --  attach it to the TSS list
 139 
 140    procedure Check_Stream_Attributes (Typ : Entity_Id);
 141    --  Check that if a limited extension has a parent with user-defined stream
 142    --  attributes, and does not itself have user-defined stream-attributes,
 143    --  then any limited component of the extension also has the corresponding
 144    --  user-defined stream attributes.
 145 
 146    procedure Clean_Task_Names
 147      (Typ     : Entity_Id;
 148       Proc_Id : Entity_Id);
 149    --  If an initialization procedure includes calls to generate names
 150    --  for task subcomponents, indicate that secondary stack cleanup is
 151    --  needed after an initialization. Typ is the component type, and Proc_Id
 152    --  the initialization procedure for the enclosing composite type.
 153 
 154    procedure Expand_Freeze_Array_Type (N : Node_Id);
 155    --  Freeze an array type. Deals with building the initialization procedure,
 156    --  creating the packed array type for a packed array and also with the
 157    --  creation of the controlling procedures for the controlled case. The
 158    --  argument N is the N_Freeze_Entity node for the type.
 159 
 160    procedure Expand_Freeze_Class_Wide_Type (N : Node_Id);
 161    --  Freeze a class-wide type. Build routine Finalize_Address for the purpose
 162    --  of finalizing controlled derivations from the class-wide's root type.
 163 
 164    procedure Expand_Freeze_Enumeration_Type (N : Node_Id);
 165    --  Freeze enumeration type with non-standard representation. Builds the
 166    --  array and function needed to convert between enumeration pos and
 167    --  enumeration representation values. N is the N_Freeze_Entity node
 168    --  for the type.
 169 
 170    procedure Expand_Freeze_Record_Type (N : Node_Id);
 171    --  Freeze record type. Builds all necessary discriminant checking
 172    --  and other ancillary functions, and builds dispatch tables where
 173    --  needed. The argument N is the N_Freeze_Entity node. This processing
 174    --  applies only to E_Record_Type entities, not to class wide types,
 175    --  record subtypes, or private types.
 176 
 177    procedure Expand_Tagged_Root (T : Entity_Id);
 178    --  Add a field _Tag at the beginning of the record. This field carries
 179    --  the value of the access to the Dispatch table. This procedure is only
 180    --  called on root type, the _Tag field being inherited by the descendants.
 181 
 182    procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
 183    --  Treat user-defined stream operations as renaming_as_body if the
 184    --  subprogram they rename is not frozen when the type is frozen.
 185 
 186    procedure Initialization_Warning (E : Entity_Id);
 187    --  If static elaboration of the package is requested, indicate
 188    --  when a type does meet the conditions for static initialization. If
 189    --  E is a type, it has components that have no static initialization.
 190    --  if E is an entity, its initial expression is not compile-time known.
 191 
 192    function Init_Formals (Typ : Entity_Id) return List_Id;
 193    --  This function builds the list of formals for an initialization routine.
 194    --  The first formal is always _Init with the given type. For task value
 195    --  record types and types containing tasks, three additional formals are
 196    --  added:
 197    --
 198    --    _Master    : Master_Id
 199    --    _Chain     : in out Activation_Chain
 200    --    _Task_Name : String
 201    --
 202    --  The caller must append additional entries for discriminants if required.
 203 
 204    function Inline_Init_Proc (Typ : Entity_Id) return Boolean;
 205    --  Returns true if the initialization procedure of Typ should be inlined
 206 
 207    function In_Runtime (E : Entity_Id) return Boolean;
 208    --  Check if E is defined in the RTL (in a child of Ada or System). Used
 209    --  to avoid to bring in the overhead of _Input, _Output for tagged types.
 210 
 211    function Is_User_Defined_Equality (Prim : Node_Id) return Boolean;
 212    --  Returns true if Prim is a user defined equality function
 213 
 214    function Make_Eq_Body
 215      (Typ     : Entity_Id;
 216       Eq_Name : Name_Id) return Node_Id;
 217    --  Build the body of a primitive equality operation for a tagged record
 218    --  type, or in Ada 2012 for any record type that has components with a
 219    --  user-defined equality. Factored out of Predefined_Primitive_Bodies.
 220 
 221    function Make_Eq_Case
 222      (E      : Entity_Id;
 223       CL     : Node_Id;
 224       Discrs : Elist_Id := New_Elmt_List) return List_Id;
 225    --  Building block for variant record equality. Defined to share the code
 226    --  between the tagged and untagged case. Given a Component_List node CL,
 227    --  it generates an 'if' followed by a 'case' statement that compares all
 228    --  components of local temporaries named X and Y (that are declared as
 229    --  formals at some upper level). E provides the Sloc to be used for the
 230    --  generated code.
 231    --
 232    --  IF E is an unchecked_union,  Discrs is the list of formals created for
 233    --  the inferred discriminants of one operand. These formals are used in
 234    --  the generated case statements for each variant of the unchecked union.
 235 
 236    function Make_Eq_If
 237      (E : Entity_Id;
 238       L : List_Id) return Node_Id;
 239    --  Building block for variant record equality. Defined to share the code
 240    --  between the tagged and untagged case. Given the list of components
 241    --  (or discriminants) L, it generates a return statement that compares all
 242    --  components of local temporaries named X and Y (that are declared as
 243    --  formals at some upper level). E provides the Sloc to be used for the
 244    --  generated code.
 245 
 246    function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id;
 247    --  Search for a renaming of the inequality dispatching primitive of
 248    --  this tagged type. If found then build and return the corresponding
 249    --  rename-as-body inequality subprogram; otherwise return Empty.
 250 
 251    procedure Make_Predefined_Primitive_Specs
 252      (Tag_Typ     : Entity_Id;
 253       Predef_List : out List_Id;
 254       Renamed_Eq  : out Entity_Id);
 255    --  Create a list with the specs of the predefined primitive operations.
 256    --  For tagged types that are interfaces all these primitives are defined
 257    --  abstract.
 258    --
 259    --  The following entries are present for all tagged types, and provide
 260    --  the results of the corresponding attribute applied to the object.
 261    --  Dispatching is required in general, since the result of the attribute
 262    --  will vary with the actual object subtype.
 263    --
 264    --     _size          provides result of 'Size attribute
 265    --     typSR          provides result of 'Read attribute
 266    --     typSW          provides result of 'Write attribute
 267    --     typSI          provides result of 'Input attribute
 268    --     typSO          provides result of 'Output attribute
 269    --
 270    --  The following entries are additionally present for non-limited tagged
 271    --  types, and implement additional dispatching operations for predefined
 272    --  operations:
 273    --
 274    --     _equality      implements "=" operator
 275    --     _assign        implements assignment operation
 276    --     typDF          implements deep finalization
 277    --     typDA          implements deep adjust
 278    --
 279    --  The latter two are empty procedures unless the type contains some
 280    --  controlled components that require finalization actions (the deep
 281    --  in the name refers to the fact that the action applies to components).
 282    --
 283    --  The list is returned in Predef_List. The Parameter Renamed_Eq either
 284    --  returns the value Empty, or else the defining unit name for the
 285    --  predefined equality function in the case where the type has a primitive
 286    --  operation that is a renaming of predefined equality (but only if there
 287    --  is also an overriding user-defined equality function). The returned
 288    --  Renamed_Eq will be passed to the corresponding parameter of
 289    --  Predefined_Primitive_Bodies.
 290 
 291    function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
 292    --  Returns True if there are representation clauses for type T that are not
 293    --  inherited. If the result is false, the init_proc and the discriminant
 294    --  checking functions of the parent can be reused by a derived type.
 295 
 296    procedure Make_Controlling_Function_Wrappers
 297      (Tag_Typ   : Entity_Id;
 298       Decl_List : out List_Id;
 299       Body_List : out List_Id);
 300    --  Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions
 301    --  associated with inherited functions with controlling results which
 302    --  are not overridden. The body of each wrapper function consists solely
 303    --  of a return statement whose expression is an extension aggregate
 304    --  invoking the inherited subprogram's parent subprogram and extended
 305    --  with a null association list.
 306 
 307    function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
 308    --  Ada 2005 (AI-251): Makes specs for null procedures associated with any
 309    --  null procedures inherited from an interface type that have not been
 310    --  overridden. Only one null procedure will be created for a given set of
 311    --  inherited null procedures with homographic profiles.
 312 
 313    function Predef_Spec_Or_Body
 314      (Loc      : Source_Ptr;
 315       Tag_Typ  : Entity_Id;
 316       Name     : Name_Id;
 317       Profile  : List_Id;
 318       Ret_Type : Entity_Id := Empty;
 319       For_Body : Boolean   := False) return Node_Id;
 320    --  This function generates the appropriate expansion for a predefined
 321    --  primitive operation specified by its name, parameter profile and
 322    --  return type (Empty means this is a procedure). If For_Body is false,
 323    --  then the returned node is a subprogram declaration. If For_Body is
 324    --  true, then the returned node is a empty subprogram body containing
 325    --  no declarations and no statements.
 326 
 327    function Predef_Stream_Attr_Spec
 328      (Loc      : Source_Ptr;
 329       Tag_Typ  : Entity_Id;
 330       Name     : TSS_Name_Type;
 331       For_Body : Boolean := False) return Node_Id;
 332    --  Specialized version of Predef_Spec_Or_Body that apply to read, write,
 333    --  input and output attribute whose specs are constructed in Exp_Strm.
 334 
 335    function Predef_Deep_Spec
 336      (Loc      : Source_Ptr;
 337       Tag_Typ  : Entity_Id;
 338       Name     : TSS_Name_Type;
 339       For_Body : Boolean := False) return Node_Id;
 340    --  Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
 341    --  and _deep_finalize
 342 
 343    function Predefined_Primitive_Bodies
 344      (Tag_Typ    : Entity_Id;
 345       Renamed_Eq : Entity_Id) return List_Id;
 346    --  Create the bodies of the predefined primitives that are described in
 347    --  Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
 348    --  the defining unit name of the type's predefined equality as returned
 349    --  by Make_Predefined_Primitive_Specs.
 350 
 351    function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
 352    --  Freeze entities of all predefined primitive operations. This is needed
 353    --  because the bodies of these operations do not normally do any freezing.
 354 
 355    function Stream_Operation_OK
 356      (Typ       : Entity_Id;
 357       Operation : TSS_Name_Type) return Boolean;
 358    --  Check whether the named stream operation must be emitted for a given
 359    --  type. The rules for inheritance of stream attributes by type extensions
 360    --  are enforced by this function. Furthermore, various restrictions prevent
 361    --  the generation of these operations, as a useful optimization or for
 362    --  certification purposes and to save unnecessary generated code.
 363 
 364    --------------------------
 365    -- Adjust_Discriminants --
 366    --------------------------
 367 
 368    --  This procedure attempts to define subtypes for discriminants that are
 369    --  more restrictive than those declared. Such a replacement is possible if
 370    --  we can demonstrate that values outside the restricted range would cause
 371    --  constraint errors in any case. The advantage of restricting the
 372    --  discriminant types in this way is that the maximum size of the variant
 373    --  record can be calculated more conservatively.
 374 
 375    --  An example of a situation in which we can perform this type of
 376    --  restriction is the following:
 377 
 378    --    subtype B is range 1 .. 10;
 379    --    type Q is array (B range <>) of Integer;
 380 
 381    --    type V (N : Natural) is record
 382    --       C : Q (1 .. N);
 383    --    end record;
 384 
 385    --  In this situation, we can restrict the upper bound of N to 10, since
 386    --  any larger value would cause a constraint error in any case.
 387 
 388    --  There are many situations in which such restriction is possible, but
 389    --  for now, we just look for cases like the above, where the component
 390    --  in question is a one dimensional array whose upper bound is one of
 391    --  the record discriminants. Also the component must not be part of
 392    --  any variant part, since then the component does not always exist.
 393 
 394    procedure Adjust_Discriminants (Rtype : Entity_Id) is
 395       Loc   : constant Source_Ptr := Sloc (Rtype);
 396       Comp  : Entity_Id;
 397       Ctyp  : Entity_Id;
 398       Ityp  : Entity_Id;
 399       Lo    : Node_Id;
 400       Hi    : Node_Id;
 401       P     : Node_Id;
 402       Loval : Uint;
 403       Discr : Entity_Id;
 404       Dtyp  : Entity_Id;
 405       Dhi   : Node_Id;
 406       Dhiv  : Uint;
 407       Ahi   : Node_Id;
 408       Ahiv  : Uint;
 409       Tnn   : Entity_Id;
 410 
 411    begin
 412       Comp := First_Component (Rtype);
 413       while Present (Comp) loop
 414 
 415          --  If our parent is a variant, quit, we do not look at components
 416          --  that are in variant parts, because they may not always exist.
 417 
 418          P := Parent (Comp);   -- component declaration
 419          P := Parent (P);      -- component list
 420 
 421          exit when Nkind (Parent (P)) = N_Variant;
 422 
 423          --  We are looking for a one dimensional array type
 424 
 425          Ctyp := Etype (Comp);
 426 
 427          if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then
 428             goto Continue;
 429          end if;
 430 
 431          --  The lower bound must be constant, and the upper bound is a
 432          --  discriminant (which is a discriminant of the current record).
 433 
 434          Ityp := Etype (First_Index (Ctyp));
 435          Lo := Type_Low_Bound (Ityp);
 436          Hi := Type_High_Bound (Ityp);
 437 
 438          if not Compile_Time_Known_Value (Lo)
 439            or else Nkind (Hi) /= N_Identifier
 440            or else No (Entity (Hi))
 441            or else Ekind (Entity (Hi)) /= E_Discriminant
 442          then
 443             goto Continue;
 444          end if;
 445 
 446          --  We have an array with appropriate bounds
 447 
 448          Loval := Expr_Value (Lo);
 449          Discr := Entity (Hi);
 450          Dtyp  := Etype (Discr);
 451 
 452          --  See if the discriminant has a known upper bound
 453 
 454          Dhi := Type_High_Bound (Dtyp);
 455 
 456          if not Compile_Time_Known_Value (Dhi) then
 457             goto Continue;
 458          end if;
 459 
 460          Dhiv := Expr_Value (Dhi);
 461 
 462          --  See if base type of component array has known upper bound
 463 
 464          Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
 465 
 466          if not Compile_Time_Known_Value (Ahi) then
 467             goto Continue;
 468          end if;
 469 
 470          Ahiv := Expr_Value (Ahi);
 471 
 472          --  The condition for doing the restriction is that the high bound
 473          --  of the discriminant is greater than the low bound of the array,
 474          --  and is also greater than the high bound of the base type index.
 475 
 476          if Dhiv > Loval and then Dhiv > Ahiv then
 477 
 478             --  We can reset the upper bound of the discriminant type to
 479             --  whichever is larger, the low bound of the component, or
 480             --  the high bound of the base type array index.
 481 
 482             --  We build a subtype that is declared as
 483 
 484             --     subtype Tnn is discr_type range discr_type'First .. max;
 485 
 486             --  And insert this declaration into the tree. The type of the
 487             --  discriminant is then reset to this more restricted subtype.
 488 
 489             Tnn := Make_Temporary (Loc, 'T');
 490 
 491             Insert_Action (Declaration_Node (Rtype),
 492               Make_Subtype_Declaration (Loc,
 493                 Defining_Identifier => Tnn,
 494                 Subtype_Indication =>
 495                   Make_Subtype_Indication (Loc,
 496                     Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
 497                     Constraint   =>
 498                       Make_Range_Constraint (Loc,
 499                         Range_Expression =>
 500                           Make_Range (Loc,
 501                             Low_Bound =>
 502                               Make_Attribute_Reference (Loc,
 503                                 Attribute_Name => Name_First,
 504                                 Prefix => New_Occurrence_Of (Dtyp, Loc)),
 505                             High_Bound =>
 506                               Make_Integer_Literal (Loc,
 507                                 Intval => UI_Max (Loval, Ahiv)))))));
 508 
 509             Set_Etype (Discr, Tnn);
 510          end if;
 511 
 512       <<Continue>>
 513          Next_Component (Comp);
 514       end loop;
 515    end Adjust_Discriminants;
 516 
 517    ---------------------------
 518    -- Build_Array_Init_Proc --
 519    ---------------------------
 520 
 521    procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
 522       Comp_Type        : constant Entity_Id  := Component_Type (A_Type);
 523       Body_Stmts       : List_Id;
 524       Has_Default_Init : Boolean;
 525       Index_List       : List_Id;
 526       Loc              : Source_Ptr;
 527       Proc_Id          : Entity_Id;
 528 
 529       function Init_Component return List_Id;
 530       --  Create one statement to initialize one array component, designated
 531       --  by a full set of indexes.
 532 
 533       function Init_One_Dimension (N : Int) return List_Id;
 534       --  Create loop to initialize one dimension of the array. The single
 535       --  statement in the loop body initializes the inner dimensions if any,
 536       --  or else the single component. Note that this procedure is called
 537       --  recursively, with N being the dimension to be initialized. A call
 538       --  with N greater than the number of dimensions simply generates the
 539       --  component initialization, terminating the recursion.
 540 
 541       --------------------
 542       -- Init_Component --
 543       --------------------
 544 
 545       function Init_Component return List_Id is
 546          Comp : Node_Id;
 547 
 548       begin
 549          Comp :=
 550            Make_Indexed_Component (Loc,
 551              Prefix      => Make_Identifier (Loc, Name_uInit),
 552              Expressions => Index_List);
 553 
 554          if Has_Default_Aspect (A_Type) then
 555             Set_Assignment_OK (Comp);
 556             return New_List (
 557               Make_Assignment_Statement (Loc,
 558                 Name       => Comp,
 559                 Expression =>
 560                   Convert_To (Comp_Type,
 561                     Default_Aspect_Component_Value (First_Subtype (A_Type)))));
 562 
 563          elsif Needs_Simple_Initialization (Comp_Type) then
 564             Set_Assignment_OK (Comp);
 565             return New_List (
 566               Make_Assignment_Statement (Loc,
 567                 Name       => Comp,
 568                 Expression =>
 569                   Get_Simple_Init_Val
 570                     (Comp_Type, Nod, Component_Size (A_Type))));
 571 
 572          else
 573             Clean_Task_Names (Comp_Type, Proc_Id);
 574             return
 575               Build_Initialization_Call
 576                 (Loc, Comp, Comp_Type,
 577                  In_Init_Proc => True,
 578                  Enclos_Type  => A_Type);
 579          end if;
 580       end Init_Component;
 581 
 582       ------------------------
 583       -- Init_One_Dimension --
 584       ------------------------
 585 
 586       function Init_One_Dimension (N : Int) return List_Id is
 587          Index : Entity_Id;
 588 
 589       begin
 590          --  If the component does not need initializing, then there is nothing
 591          --  to do here, so we return a null body. This occurs when generating
 592          --  the dummy Init_Proc needed for Initialize_Scalars processing.
 593 
 594          if not Has_Non_Null_Base_Init_Proc (Comp_Type)
 595            and then not Needs_Simple_Initialization (Comp_Type)
 596            and then not Has_Task (Comp_Type)
 597            and then not Has_Default_Aspect (A_Type)
 598          then
 599             return New_List (Make_Null_Statement (Loc));
 600 
 601          --  If all dimensions dealt with, we simply initialize the component
 602 
 603          elsif N > Number_Dimensions (A_Type) then
 604             return Init_Component;
 605 
 606          --  Here we generate the required loop
 607 
 608          else
 609             Index :=
 610               Make_Defining_Identifier (Loc, New_External_Name ('J', N));
 611 
 612             Append (New_Occurrence_Of (Index, Loc), Index_List);
 613 
 614             return New_List (
 615               Make_Implicit_Loop_Statement (Nod,
 616                 Identifier       => Empty,
 617                 Iteration_Scheme =>
 618                   Make_Iteration_Scheme (Loc,
 619                     Loop_Parameter_Specification =>
 620                       Make_Loop_Parameter_Specification (Loc,
 621                         Defining_Identifier         => Index,
 622                         Discrete_Subtype_Definition =>
 623                           Make_Attribute_Reference (Loc,
 624                             Prefix          =>
 625                               Make_Identifier (Loc, Name_uInit),
 626                             Attribute_Name  => Name_Range,
 627                             Expressions     => New_List (
 628                               Make_Integer_Literal (Loc, N))))),
 629                 Statements       => Init_One_Dimension (N + 1)));
 630          end if;
 631       end Init_One_Dimension;
 632 
 633    --  Start of processing for Build_Array_Init_Proc
 634 
 635    begin
 636       --  The init proc is created when analyzing the freeze node for the type,
 637       --  but it properly belongs with the array type declaration. However, if
 638       --  the freeze node is for a subtype of a type declared in another unit
 639       --  it seems preferable to use the freeze node as the source location of
 640       --  the init proc. In any case this is preferable for gcov usage, and
 641       --  the Sloc is not otherwise used by the compiler.
 642 
 643       if In_Open_Scopes (Scope (A_Type)) then
 644          Loc := Sloc (A_Type);
 645       else
 646          Loc := Sloc (Nod);
 647       end if;
 648 
 649       --  Nothing to generate in the following cases:
 650 
 651       --    1. Initialization is suppressed for the type
 652       --    2. An initialization already exists for the base type
 653 
 654       if Initialization_Suppressed (A_Type)
 655         or else Present (Base_Init_Proc (A_Type))
 656       then
 657          return;
 658       end if;
 659 
 660       Index_List := New_List;
 661 
 662       --  We need an initialization procedure if any of the following is true:
 663 
 664       --    1. The component type has an initialization procedure
 665       --    2. The component type needs simple initialization
 666       --    3. Tasks are present
 667       --    4. The type is marked as a public entity
 668       --    5. The array type has a Default_Component_Value aspect
 669 
 670       --  The reason for the public entity test is to deal properly with the
 671       --  Initialize_Scalars pragma. This pragma can be set in the client and
 672       --  not in the declaring package, this means the client will make a call
 673       --  to the initialization procedure (because one of conditions 1-3 must
 674       --  apply in this case), and we must generate a procedure (even if it is
 675       --  null) to satisfy the call in this case.
 676 
 677       --  Exception: do not build an array init_proc for a type whose root
 678       --  type is Standard.String or Standard.Wide_[Wide_]String, since there
 679       --  is no place to put the code, and in any case we handle initialization
 680       --  of such types (in the Initialize_Scalars case, that's the only time
 681       --  the issue arises) in a special manner anyway which does not need an
 682       --  init_proc.
 683 
 684       Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
 685                             or else Needs_Simple_Initialization (Comp_Type)
 686                             or else Has_Task (Comp_Type)
 687                             or else Has_Default_Aspect (A_Type);
 688 
 689       if Has_Default_Init
 690         or else (not Restriction_Active (No_Initialize_Scalars)
 691                   and then Is_Public (A_Type)
 692                   and then not Is_Standard_String_Type (A_Type))
 693       then
 694          Proc_Id :=
 695            Make_Defining_Identifier (Loc,
 696              Chars => Make_Init_Proc_Name (A_Type));
 697 
 698          --  If No_Default_Initialization restriction is active, then we don't
 699          --  want to build an init_proc, but we need to mark that an init_proc
 700          --  would be needed if this restriction was not active (so that we can
 701          --  detect attempts to call it), so set a dummy init_proc in place.
 702          --  This is only done though when actual default initialization is
 703          --  needed (and not done when only Is_Public is True), since otherwise
 704          --  objects such as arrays of scalars could be wrongly flagged as
 705          --  violating the restriction.
 706 
 707          if Restriction_Active (No_Default_Initialization) then
 708             if Has_Default_Init then
 709                Set_Init_Proc (A_Type, Proc_Id);
 710             end if;
 711 
 712             return;
 713          end if;
 714 
 715          Body_Stmts := Init_One_Dimension (1);
 716 
 717          Discard_Node (
 718            Make_Subprogram_Body (Loc,
 719              Specification =>
 720                Make_Procedure_Specification (Loc,
 721                  Defining_Unit_Name => Proc_Id,
 722                  Parameter_Specifications => Init_Formals (A_Type)),
 723              Declarations => New_List,
 724              Handled_Statement_Sequence =>
 725                Make_Handled_Sequence_Of_Statements (Loc,
 726                  Statements => Body_Stmts)));
 727 
 728          Set_Ekind          (Proc_Id, E_Procedure);
 729          Set_Is_Public      (Proc_Id, Is_Public (A_Type));
 730          Set_Is_Internal    (Proc_Id);
 731          Set_Has_Completion (Proc_Id);
 732 
 733          if not Debug_Generated_Code then
 734             Set_Debug_Info_Off (Proc_Id);
 735          end if;
 736 
 737          --  Set Inlined on Init_Proc if it is set on the Init_Proc of the
 738          --  component type itself (see also Build_Record_Init_Proc).
 739 
 740          Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type));
 741 
 742          --  Associate Init_Proc with type, and determine if the procedure
 743          --  is null (happens because of the Initialize_Scalars pragma case,
 744          --  where we have to generate a null procedure in case it is called
 745          --  by a client with Initialize_Scalars set). Such procedures have
 746          --  to be generated, but do not have to be called, so we mark them
 747          --  as null to suppress the call.
 748 
 749          Set_Init_Proc (A_Type, Proc_Id);
 750 
 751          if List_Length (Body_Stmts) = 1
 752 
 753            --  We must skip SCIL nodes because they may have been added to this
 754            --  list by Insert_Actions.
 755 
 756            and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
 757          then
 758             Set_Is_Null_Init_Proc (Proc_Id);
 759 
 760          else
 761             --  Try to build a static aggregate to statically initialize
 762             --  objects of the type. This can only be done for constrained
 763             --  one-dimensional arrays with static bounds.
 764 
 765             Set_Static_Initialization
 766               (Proc_Id,
 767                Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
 768          end if;
 769       end if;
 770    end Build_Array_Init_Proc;
 771 
 772    --------------------------------
 773    -- Build_Discr_Checking_Funcs --
 774    --------------------------------
 775 
 776    procedure Build_Discr_Checking_Funcs (N : Node_Id) is
 777       Rec_Id            : Entity_Id;
 778       Loc               : Source_Ptr;
 779       Enclosing_Func_Id : Entity_Id;
 780       Sequence          : Nat := 1;
 781       Type_Def          : Node_Id;
 782       V                 : Node_Id;
 783 
 784       function Build_Case_Statement
 785         (Case_Id : Entity_Id;
 786          Variant : Node_Id) return Node_Id;
 787       --  Build a case statement containing only two alternatives. The first
 788       --  alternative corresponds exactly to the discrete choices given on the
 789       --  variant with contains the components that we are generating the
 790       --  checks for. If the discriminant is one of these return False. The
 791       --  second alternative is an OTHERS choice that will return True
 792       --  indicating the discriminant did not match.
 793 
 794       function Build_Dcheck_Function
 795         (Case_Id : Entity_Id;
 796          Variant : Node_Id) return Entity_Id;
 797       --  Build the discriminant checking function for a given variant
 798 
 799       procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
 800       --  Builds the discriminant checking function for each variant of the
 801       --  given variant part of the record type.
 802 
 803       --------------------------
 804       -- Build_Case_Statement --
 805       --------------------------
 806 
 807       function Build_Case_Statement
 808         (Case_Id : Entity_Id;
 809          Variant : Node_Id) return Node_Id
 810       is
 811          Alt_List       : constant List_Id := New_List;
 812          Actuals_List   : List_Id;
 813          Case_Node      : Node_Id;
 814          Case_Alt_Node  : Node_Id;
 815          Choice         : Node_Id;
 816          Choice_List    : List_Id;
 817          D              : Entity_Id;
 818          Return_Node    : Node_Id;
 819 
 820       begin
 821          Case_Node := New_Node (N_Case_Statement, Loc);
 822 
 823          --  Replace the discriminant which controls the variant with the name
 824          --  of the formal of the checking function.
 825 
 826          Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id)));
 827 
 828          Choice := First (Discrete_Choices (Variant));
 829 
 830          if Nkind (Choice) = N_Others_Choice then
 831             Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
 832          else
 833             Choice_List := New_Copy_List (Discrete_Choices (Variant));
 834          end if;
 835 
 836          if not Is_Empty_List (Choice_List) then
 837             Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
 838             Set_Discrete_Choices (Case_Alt_Node, Choice_List);
 839 
 840             --  In case this is a nested variant, we need to return the result
 841             --  of the discriminant checking function for the immediately
 842             --  enclosing variant.
 843 
 844             if Present (Enclosing_Func_Id) then
 845                Actuals_List := New_List;
 846 
 847                D := First_Discriminant (Rec_Id);
 848                while Present (D) loop
 849                   Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
 850                   Next_Discriminant (D);
 851                end loop;
 852 
 853                Return_Node :=
 854                  Make_Simple_Return_Statement (Loc,
 855                    Expression =>
 856                      Make_Function_Call (Loc,
 857                        Name =>
 858                          New_Occurrence_Of (Enclosing_Func_Id,  Loc),
 859                        Parameter_Associations =>
 860                          Actuals_List));
 861 
 862             else
 863                Return_Node :=
 864                  Make_Simple_Return_Statement (Loc,
 865                    Expression =>
 866                      New_Occurrence_Of (Standard_False, Loc));
 867             end if;
 868 
 869             Set_Statements (Case_Alt_Node, New_List (Return_Node));
 870             Append (Case_Alt_Node, Alt_List);
 871          end if;
 872 
 873          Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
 874          Choice_List := New_List (New_Node (N_Others_Choice, Loc));
 875          Set_Discrete_Choices (Case_Alt_Node, Choice_List);
 876 
 877          Return_Node :=
 878            Make_Simple_Return_Statement (Loc,
 879              Expression =>
 880                New_Occurrence_Of (Standard_True, Loc));
 881 
 882          Set_Statements (Case_Alt_Node, New_List (Return_Node));
 883          Append (Case_Alt_Node, Alt_List);
 884 
 885          Set_Alternatives (Case_Node, Alt_List);
 886          return Case_Node;
 887       end Build_Case_Statement;
 888 
 889       ---------------------------
 890       -- Build_Dcheck_Function --
 891       ---------------------------
 892 
 893       function Build_Dcheck_Function
 894         (Case_Id : Entity_Id;
 895          Variant : Node_Id) return Entity_Id
 896       is
 897          Body_Node           : Node_Id;
 898          Func_Id             : Entity_Id;
 899          Parameter_List      : List_Id;
 900          Spec_Node           : Node_Id;
 901 
 902       begin
 903          Body_Node := New_Node (N_Subprogram_Body, Loc);
 904          Sequence := Sequence + 1;
 905 
 906          Func_Id :=
 907            Make_Defining_Identifier (Loc,
 908              Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
 909          Set_Is_Discriminant_Check_Function (Func_Id);
 910 
 911          Spec_Node := New_Node (N_Function_Specification, Loc);
 912          Set_Defining_Unit_Name (Spec_Node, Func_Id);
 913 
 914          Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
 915 
 916          Set_Parameter_Specifications (Spec_Node, Parameter_List);
 917          Set_Result_Definition (Spec_Node,
 918                                 New_Occurrence_Of (Standard_Boolean,  Loc));
 919          Set_Specification (Body_Node, Spec_Node);
 920          Set_Declarations (Body_Node, New_List);
 921 
 922          Set_Handled_Statement_Sequence (Body_Node,
 923            Make_Handled_Sequence_Of_Statements (Loc,
 924              Statements => New_List (
 925                Build_Case_Statement (Case_Id, Variant))));
 926 
 927          Set_Ekind       (Func_Id, E_Function);
 928          Set_Mechanism   (Func_Id, Default_Mechanism);
 929          Set_Is_Inlined  (Func_Id, True);
 930          Set_Is_Pure     (Func_Id, True);
 931          Set_Is_Public   (Func_Id, Is_Public (Rec_Id));
 932          Set_Is_Internal (Func_Id, True);
 933 
 934          if not Debug_Generated_Code then
 935             Set_Debug_Info_Off (Func_Id);
 936          end if;
 937 
 938          Analyze (Body_Node);
 939 
 940          Append_Freeze_Action (Rec_Id, Body_Node);
 941          Set_Dcheck_Function (Variant, Func_Id);
 942          return Func_Id;
 943       end Build_Dcheck_Function;
 944 
 945       ----------------------------
 946       -- Build_Dcheck_Functions --
 947       ----------------------------
 948 
 949       procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
 950          Component_List_Node : Node_Id;
 951          Decl                : Entity_Id;
 952          Discr_Name          : Entity_Id;
 953          Func_Id             : Entity_Id;
 954          Variant             : Node_Id;
 955          Saved_Enclosing_Func_Id : Entity_Id;
 956 
 957       begin
 958          --  Build the discriminant-checking function for each variant, and
 959          --  label all components of that variant with the function's name.
 960          --  We only Generate a discriminant-checking function when the
 961          --  variant is not empty, to prevent the creation of dead code.
 962          --  The exception to that is when Frontend_Layout_On_Target is set,
 963          --  because the variant record size function generated in package
 964          --  Layout needs to generate calls to all discriminant-checking
 965          --  functions, including those for empty variants.
 966 
 967          Discr_Name := Entity (Name (Variant_Part_Node));
 968          Variant := First_Non_Pragma (Variants (Variant_Part_Node));
 969 
 970          while Present (Variant) loop
 971             Component_List_Node := Component_List (Variant);
 972 
 973             if not Null_Present (Component_List_Node)
 974               or else Frontend_Layout_On_Target
 975             then
 976                Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
 977 
 978                Decl :=
 979                  First_Non_Pragma (Component_Items (Component_List_Node));
 980                while Present (Decl) loop
 981                   Set_Discriminant_Checking_Func
 982                     (Defining_Identifier (Decl), Func_Id);
 983                   Next_Non_Pragma (Decl);
 984                end loop;
 985 
 986                if Present (Variant_Part (Component_List_Node)) then
 987                   Saved_Enclosing_Func_Id := Enclosing_Func_Id;
 988                   Enclosing_Func_Id := Func_Id;
 989                   Build_Dcheck_Functions (Variant_Part (Component_List_Node));
 990                   Enclosing_Func_Id := Saved_Enclosing_Func_Id;
 991                end if;
 992             end if;
 993 
 994             Next_Non_Pragma (Variant);
 995          end loop;
 996       end Build_Dcheck_Functions;
 997 
 998    --  Start of processing for Build_Discr_Checking_Funcs
 999 
1000    begin
1001       --  Only build if not done already
1002 
1003       if not Discr_Check_Funcs_Built (N) then
1004          Type_Def := Type_Definition (N);
1005 
1006          if Nkind (Type_Def) = N_Record_Definition then
1007             if No (Component_List (Type_Def)) then   -- null record.
1008                return;
1009             else
1010                V := Variant_Part (Component_List (Type_Def));
1011             end if;
1012 
1013          else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
1014             if No (Component_List (Record_Extension_Part (Type_Def))) then
1015                return;
1016             else
1017                V := Variant_Part
1018                       (Component_List (Record_Extension_Part (Type_Def)));
1019             end if;
1020          end if;
1021 
1022          Rec_Id := Defining_Identifier (N);
1023 
1024          if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
1025             Loc := Sloc (N);
1026             Enclosing_Func_Id := Empty;
1027             Build_Dcheck_Functions (V);
1028          end if;
1029 
1030          Set_Discr_Check_Funcs_Built (N);
1031       end if;
1032    end Build_Discr_Checking_Funcs;
1033 
1034    --------------------------------
1035    -- Build_Discriminant_Formals --
1036    --------------------------------
1037 
1038    function Build_Discriminant_Formals
1039      (Rec_Id : Entity_Id;
1040       Use_Dl : Boolean) return List_Id
1041    is
1042       Loc             : Source_Ptr       := Sloc (Rec_Id);
1043       Parameter_List  : constant List_Id := New_List;
1044       D               : Entity_Id;
1045       Formal          : Entity_Id;
1046       Formal_Type     : Entity_Id;
1047       Param_Spec_Node : Node_Id;
1048 
1049    begin
1050       if Has_Discriminants (Rec_Id) then
1051          D := First_Discriminant (Rec_Id);
1052          while Present (D) loop
1053             Loc := Sloc (D);
1054 
1055             if Use_Dl then
1056                Formal := Discriminal (D);
1057                Formal_Type := Etype (Formal);
1058             else
1059                Formal := Make_Defining_Identifier (Loc, Chars (D));
1060                Formal_Type := Etype (D);
1061             end if;
1062 
1063             Param_Spec_Node :=
1064               Make_Parameter_Specification (Loc,
1065                   Defining_Identifier => Formal,
1066                 Parameter_Type =>
1067                   New_Occurrence_Of (Formal_Type, Loc));
1068             Append (Param_Spec_Node, Parameter_List);
1069             Next_Discriminant (D);
1070          end loop;
1071       end if;
1072 
1073       return Parameter_List;
1074    end Build_Discriminant_Formals;
1075 
1076    --------------------------------------
1077    -- Build_Equivalent_Array_Aggregate --
1078    --------------------------------------
1079 
1080    function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is
1081       Loc        : constant Source_Ptr := Sloc (T);
1082       Comp_Type  : constant Entity_Id := Component_Type (T);
1083       Index_Type : constant Entity_Id := Etype (First_Index (T));
1084       Proc       : constant Entity_Id := Base_Init_Proc (T);
1085       Lo, Hi     : Node_Id;
1086       Aggr       : Node_Id;
1087       Expr       : Node_Id;
1088 
1089    begin
1090       if not Is_Constrained (T)
1091         or else Number_Dimensions (T) > 1
1092         or else No (Proc)
1093       then
1094          Initialization_Warning (T);
1095          return Empty;
1096       end if;
1097 
1098       Lo := Type_Low_Bound  (Index_Type);
1099       Hi := Type_High_Bound (Index_Type);
1100 
1101       if not Compile_Time_Known_Value (Lo)
1102         or else not Compile_Time_Known_Value (Hi)
1103       then
1104          Initialization_Warning (T);
1105          return Empty;
1106       end if;
1107 
1108       if Is_Record_Type (Comp_Type)
1109         and then Present (Base_Init_Proc (Comp_Type))
1110       then
1111          Expr := Static_Initialization (Base_Init_Proc (Comp_Type));
1112 
1113          if No (Expr) then
1114             Initialization_Warning (T);
1115             return Empty;
1116          end if;
1117 
1118       else
1119          Initialization_Warning (T);
1120          return Empty;
1121       end if;
1122 
1123       Aggr := Make_Aggregate (Loc, No_List, New_List);
1124       Set_Etype (Aggr, T);
1125       Set_Aggregate_Bounds (Aggr,
1126         Make_Range (Loc,
1127           Low_Bound  => New_Copy (Lo),
1128           High_Bound => New_Copy (Hi)));
1129       Set_Parent (Aggr, Parent (Proc));
1130 
1131       Append_To (Component_Associations (Aggr),
1132          Make_Component_Association (Loc,
1133               Choices =>
1134                  New_List (
1135                    Make_Range (Loc,
1136                      Low_Bound  => New_Copy (Lo),
1137                      High_Bound => New_Copy (Hi))),
1138               Expression => Expr));
1139 
1140       if Static_Array_Aggregate (Aggr) then
1141          return Aggr;
1142       else
1143          Initialization_Warning (T);
1144          return Empty;
1145       end if;
1146    end Build_Equivalent_Array_Aggregate;
1147 
1148    ---------------------------------------
1149    -- Build_Equivalent_Record_Aggregate --
1150    ---------------------------------------
1151 
1152    function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is
1153       Agg       : Node_Id;
1154       Comp      : Entity_Id;
1155       Comp_Type : Entity_Id;
1156 
1157       --  Start of processing for Build_Equivalent_Record_Aggregate
1158 
1159    begin
1160       if not Is_Record_Type (T)
1161         or else Has_Discriminants (T)
1162         or else Is_Limited_Type (T)
1163         or else Has_Non_Standard_Rep (T)
1164       then
1165          Initialization_Warning (T);
1166          return Empty;
1167       end if;
1168 
1169       Comp := First_Component (T);
1170 
1171       --  A null record needs no warning
1172 
1173       if No (Comp) then
1174          return Empty;
1175       end if;
1176 
1177       while Present (Comp) loop
1178 
1179          --  Array components are acceptable if initialized by a positional
1180          --  aggregate with static components.
1181 
1182          if Is_Array_Type (Etype (Comp)) then
1183             Comp_Type := Component_Type (Etype (Comp));
1184 
1185             if Nkind (Parent (Comp)) /= N_Component_Declaration
1186               or else No (Expression (Parent (Comp)))
1187               or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
1188             then
1189                Initialization_Warning (T);
1190                return Empty;
1191 
1192             elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
1193                and then
1194                  (not Compile_Time_Known_Value (Type_Low_Bound  (Comp_Type))
1195                    or else
1196                   not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
1197             then
1198                Initialization_Warning (T);
1199                return Empty;
1200 
1201             elsif
1202               not Static_Array_Aggregate (Expression (Parent (Comp)))
1203             then
1204                Initialization_Warning (T);
1205                return Empty;
1206             end if;
1207 
1208          elsif Is_Scalar_Type (Etype (Comp)) then
1209             Comp_Type := Etype (Comp);
1210 
1211             if Nkind (Parent (Comp)) /= N_Component_Declaration
1212               or else No (Expression (Parent (Comp)))
1213               or else not Compile_Time_Known_Value (Expression (Parent (Comp)))
1214               or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1215               or else not
1216                 Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
1217             then
1218                Initialization_Warning (T);
1219                return Empty;
1220             end if;
1221 
1222          --  For now, other types are excluded
1223 
1224          else
1225             Initialization_Warning (T);
1226             return Empty;
1227          end if;
1228 
1229          Next_Component (Comp);
1230       end loop;
1231 
1232       --  All components have static initialization. Build positional aggregate
1233       --  from the given expressions or defaults.
1234 
1235       Agg := Make_Aggregate (Sloc (T), New_List, New_List);
1236       Set_Parent (Agg, Parent (T));
1237 
1238       Comp := First_Component (T);
1239       while Present (Comp) loop
1240          Append
1241            (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg));
1242          Next_Component (Comp);
1243       end loop;
1244 
1245       Analyze_And_Resolve (Agg, T);
1246       return Agg;
1247    end Build_Equivalent_Record_Aggregate;
1248 
1249    -------------------------------
1250    -- Build_Initialization_Call --
1251    -------------------------------
1252 
1253    --  References to a discriminant inside the record type declaration can
1254    --  appear either in the subtype_indication to constrain a record or an
1255    --  array, or as part of a larger expression given for the initial value
1256    --  of a component. In both of these cases N appears in the record
1257    --  initialization procedure and needs to be replaced by the formal
1258    --  parameter of the initialization procedure which corresponds to that
1259    --  discriminant.
1260 
1261    --  In the example below, references to discriminants D1 and D2 in proc_1
1262    --  are replaced by references to formals with the same name
1263    --  (discriminals)
1264 
1265    --  A similar replacement is done for calls to any record initialization
1266    --  procedure for any components that are themselves of a record type.
1267 
1268    --  type R (D1, D2 : Integer) is record
1269    --     X : Integer := F * D1;
1270    --     Y : Integer := F * D2;
1271    --  end record;
1272 
1273    --  procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1274    --  begin
1275    --     Out_2.D1 := D1;
1276    --     Out_2.D2 := D2;
1277    --     Out_2.X := F * D1;
1278    --     Out_2.Y := F * D2;
1279    --  end;
1280 
1281    function Build_Initialization_Call
1282      (Loc               : Source_Ptr;
1283       Id_Ref            : Node_Id;
1284       Typ               : Entity_Id;
1285       In_Init_Proc      : Boolean := False;
1286       Enclos_Type       : Entity_Id := Empty;
1287       Discr_Map         : Elist_Id := New_Elmt_List;
1288       With_Default_Init : Boolean := False;
1289       Constructor_Ref   : Node_Id := Empty) return List_Id
1290    is
1291       Res            : constant List_Id := New_List;
1292       Arg            : Node_Id;
1293       Args           : List_Id;
1294       Decls          : List_Id;
1295       Decl           : Node_Id;
1296       Discr          : Entity_Id;
1297       First_Arg      : Node_Id;
1298       Full_Init_Type : Entity_Id;
1299       Full_Type      : Entity_Id;
1300       Init_Type      : Entity_Id;
1301       Proc           : Entity_Id;
1302 
1303    begin
1304       pragma Assert (Constructor_Ref = Empty
1305         or else Is_CPP_Constructor_Call (Constructor_Ref));
1306 
1307       if No (Constructor_Ref) then
1308          Proc := Base_Init_Proc (Typ);
1309       else
1310          Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
1311       end if;
1312 
1313       pragma Assert (Present (Proc));
1314       Init_Type      := Etype (First_Formal (Proc));
1315       Full_Init_Type := Underlying_Type (Init_Type);
1316 
1317       --  Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1318       --  is active (in which case we make the call anyway, since in the
1319       --  actual compiled client it may be non null).
1320 
1321       if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
1322          return Empty_List;
1323       end if;
1324 
1325       --  Use the [underlying] full view when dealing with a private type. This
1326       --  may require several steps depending on derivations.
1327 
1328       Full_Type := Typ;
1329       loop
1330          if Is_Private_Type (Full_Type) then
1331             if Present (Full_View (Full_Type)) then
1332                Full_Type := Full_View (Full_Type);
1333 
1334             elsif Present (Underlying_Full_View (Full_Type)) then
1335                Full_Type := Underlying_Full_View (Full_Type);
1336 
1337             --  When a private type acts as a generic actual and lacks a full
1338             --  view, use the base type.
1339 
1340             elsif Is_Generic_Actual_Type (Full_Type) then
1341                Full_Type := Base_Type (Full_Type);
1342 
1343             --  The loop has recovered the [underlying] full view, stop the
1344             --  traversal.
1345 
1346             else
1347                exit;
1348             end if;
1349 
1350          --  The type is not private, nothing to do
1351 
1352          else
1353             exit;
1354          end if;
1355       end loop;
1356 
1357       --  If Typ is derived, the procedure is the initialization procedure for
1358       --  the root type. Wrap the argument in an conversion to make it type
1359       --  honest. Actually it isn't quite type honest, because there can be
1360       --  conflicts of views in the private type case. That is why we set
1361       --  Conversion_OK in the conversion node.
1362 
1363       if (Is_Record_Type (Typ)
1364            or else Is_Array_Type (Typ)
1365            or else Is_Private_Type (Typ))
1366         and then Init_Type /= Base_Type (Typ)
1367       then
1368          First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
1369          Set_Etype (First_Arg, Init_Type);
1370 
1371       else
1372          First_Arg := Id_Ref;
1373       end if;
1374 
1375       Args := New_List (Convert_Concurrent (First_Arg, Typ));
1376 
1377       --  In the tasks case, add _Master as the value of the _Master parameter
1378       --  and _Chain as the value of the _Chain parameter. At the outer level,
1379       --  these will be variables holding the corresponding values obtained
1380       --  from GNARL. At inner levels, they will be the parameters passed down
1381       --  through the outer routines.
1382 
1383       if Has_Task (Full_Type) then
1384          if Restriction_Active (No_Task_Hierarchy) then
1385             Append_To (Args,
1386               New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
1387          else
1388             Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1389          end if;
1390 
1391          --  Add _Chain (not done for sequential elaboration policy, see
1392          --  comment for Create_Restricted_Task_Sequential in s-tarest.ads).
1393 
1394          if Partition_Elaboration_Policy /= 'S' then
1395             Append_To (Args, Make_Identifier (Loc, Name_uChain));
1396          end if;
1397 
1398          --  Ada 2005 (AI-287): In case of default initialized components
1399          --  with tasks, we generate a null string actual parameter.
1400          --  This is just a workaround that must be improved later???
1401 
1402          if With_Default_Init then
1403             Append_To (Args,
1404               Make_String_Literal (Loc,
1405                 Strval => ""));
1406 
1407          else
1408             Decls :=
1409               Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
1410             Decl  := Last (Decls);
1411 
1412             Append_To (Args,
1413               New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1414             Append_List (Decls, Res);
1415          end if;
1416 
1417       else
1418          Decls := No_List;
1419          Decl  := Empty;
1420       end if;
1421 
1422       --  Add discriminant values if discriminants are present
1423 
1424       if Has_Discriminants (Full_Init_Type) then
1425          Discr := First_Discriminant (Full_Init_Type);
1426          while Present (Discr) loop
1427 
1428             --  If this is a discriminated concurrent type, the init_proc
1429             --  for the corresponding record is being called. Use that type
1430             --  directly to find the discriminant value, to handle properly
1431             --  intervening renamed discriminants.
1432 
1433             declare
1434                T : Entity_Id := Full_Type;
1435 
1436             begin
1437                if Is_Protected_Type (T) then
1438                   T := Corresponding_Record_Type (T);
1439                end if;
1440 
1441                Arg :=
1442                  Get_Discriminant_Value (
1443                    Discr,
1444                    T,
1445                    Discriminant_Constraint (Full_Type));
1446             end;
1447 
1448             --  If the target has access discriminants, and is constrained by
1449             --  an access to the enclosing construct, i.e. a current instance,
1450             --  replace the reference to the type by a reference to the object.
1451 
1452             if Nkind (Arg) = N_Attribute_Reference
1453               and then Is_Access_Type (Etype (Arg))
1454               and then Is_Entity_Name (Prefix (Arg))
1455               and then Is_Type (Entity (Prefix (Arg)))
1456             then
1457                Arg :=
1458                  Make_Attribute_Reference (Loc,
1459                    Prefix         => New_Copy (Prefix (Id_Ref)),
1460                    Attribute_Name => Name_Unrestricted_Access);
1461 
1462             elsif In_Init_Proc then
1463 
1464                --  Replace any possible references to the discriminant in the
1465                --  call to the record initialization procedure with references
1466                --  to the appropriate formal parameter.
1467 
1468                if Nkind (Arg) = N_Identifier
1469                  and then Ekind (Entity (Arg)) = E_Discriminant
1470                then
1471                   Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc);
1472 
1473                --  Otherwise make a copy of the default expression. Note that
1474                --  we use the current Sloc for this, because we do not want the
1475                --  call to appear to be at the declaration point. Within the
1476                --  expression, replace discriminants with their discriminals.
1477 
1478                else
1479                   Arg :=
1480                     New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
1481                end if;
1482 
1483             else
1484                if Is_Constrained (Full_Type) then
1485                   Arg := Duplicate_Subexpr_No_Checks (Arg);
1486                else
1487                   --  The constraints come from the discriminant default exps,
1488                   --  they must be reevaluated, so we use New_Copy_Tree but we
1489                   --  ensure the proper Sloc (for any embedded calls).
1490 
1491                   Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
1492                end if;
1493             end if;
1494 
1495             --  Ada 2005 (AI-287): In case of default initialized components,
1496             --  if the component is constrained with a discriminant of the
1497             --  enclosing type, we need to generate the corresponding selected
1498             --  component node to access the discriminant value. In other cases
1499             --  this is not required, either  because we are inside the init
1500             --  proc and we use the corresponding formal, or else because the
1501             --  component is constrained by an expression.
1502 
1503             if With_Default_Init
1504               and then Nkind (Id_Ref) = N_Selected_Component
1505               and then Nkind (Arg) = N_Identifier
1506               and then Ekind (Entity (Arg)) = E_Discriminant
1507             then
1508                Append_To (Args,
1509                  Make_Selected_Component (Loc,
1510                    Prefix => New_Copy_Tree (Prefix (Id_Ref)),
1511                    Selector_Name => Arg));
1512             else
1513                Append_To (Args, Arg);
1514             end if;
1515 
1516             Next_Discriminant (Discr);
1517          end loop;
1518       end if;
1519 
1520       --  If this is a call to initialize the parent component of a derived
1521       --  tagged type, indicate that the tag should not be set in the parent.
1522 
1523       if Is_Tagged_Type (Full_Init_Type)
1524         and then not Is_CPP_Class (Full_Init_Type)
1525         and then Nkind (Id_Ref) = N_Selected_Component
1526         and then Chars (Selector_Name (Id_Ref)) = Name_uParent
1527       then
1528          Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
1529 
1530       elsif Present (Constructor_Ref) then
1531          Append_List_To (Args,
1532            New_Copy_List (Parameter_Associations (Constructor_Ref)));
1533       end if;
1534 
1535       Append_To (Res,
1536         Make_Procedure_Call_Statement (Loc,
1537           Name => New_Occurrence_Of (Proc, Loc),
1538           Parameter_Associations => Args));
1539 
1540       if Needs_Finalization (Typ)
1541         and then Nkind (Id_Ref) = N_Selected_Component
1542       then
1543          if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
1544             Append_To (Res,
1545               Make_Init_Call
1546                 (Obj_Ref => New_Copy_Tree (First_Arg),
1547                  Typ     => Typ));
1548          end if;
1549       end if;
1550 
1551       return Res;
1552 
1553    exception
1554       when RE_Not_Available =>
1555          return Empty_List;
1556    end Build_Initialization_Call;
1557 
1558    ----------------------------
1559    -- Build_Record_Init_Proc --
1560    ----------------------------
1561 
1562    procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is
1563       Decls     : constant List_Id  := New_List;
1564       Discr_Map : constant Elist_Id := New_Elmt_List;
1565       Loc       : constant Source_Ptr := Sloc (Rec_Ent);
1566       Counter   : Nat := 0;
1567       Proc_Id   : Entity_Id;
1568       Rec_Type  : Entity_Id;
1569       Set_Tag   : Entity_Id := Empty;
1570 
1571       function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
1572       --  Build an assignment statement which assigns the default expression
1573       --  to its corresponding record component if defined. The left hand side
1574       --  of the assignment is marked Assignment_OK so that initialization of
1575       --  limited private records works correctly. This routine may also build
1576       --  an adjustment call if the component is controlled.
1577 
1578       procedure Build_Discriminant_Assignments (Statement_List : List_Id);
1579       --  If the record has discriminants, add assignment statements to
1580       --  Statement_List to initialize the discriminant values from the
1581       --  arguments of the initialization procedure.
1582 
1583       function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
1584       --  Build a list representing a sequence of statements which initialize
1585       --  components of the given component list. This may involve building
1586       --  case statements for the variant parts. Append any locally declared
1587       --  objects on list Decls.
1588 
1589       function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
1590       --  Given an untagged type-derivation that declares discriminants, e.g.
1591       --
1592       --     type R (R1, R2 : Integer) is record ... end record;
1593       --     type D (D1 : Integer) is new R (1, D1);
1594       --
1595       --  we make the _init_proc of D be
1596       --
1597       --       procedure _init_proc (X : D; D1 : Integer) is
1598       --       begin
1599       --          _init_proc (R (X), 1, D1);
1600       --       end _init_proc;
1601       --
1602       --  This function builds the call statement in this _init_proc.
1603 
1604       procedure Build_CPP_Init_Procedure;
1605       --  Build the tree corresponding to the procedure specification and body
1606       --  of the IC procedure that initializes the C++ part of the dispatch
1607       --  table of an Ada tagged type that is a derivation of a CPP type.
1608       --  Install it as the CPP_Init TSS.
1609 
1610       procedure Build_Init_Procedure;
1611       --  Build the tree corresponding to the procedure specification and body
1612       --  of the initialization procedure and install it as the _init TSS.
1613 
1614       procedure Build_Offset_To_Top_Functions;
1615       --  Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
1616       --  and body of Offset_To_Top, a function used in conjuction with types
1617       --  having secondary dispatch tables.
1618 
1619       procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
1620       --  Add range checks to components of discriminated records. S is a
1621       --  subtype indication of a record component. Check_List is a list
1622       --  to which the check actions are appended.
1623 
1624       function Component_Needs_Simple_Initialization
1625         (T : Entity_Id) return Boolean;
1626       --  Determine if a component needs simple initialization, given its type
1627       --  T. This routine is the same as Needs_Simple_Initialization except for
1628       --  components of type Tag and Interface_Tag. These two access types do
1629       --  not require initialization since they are explicitly initialized by
1630       --  other means.
1631 
1632       function Parent_Subtype_Renaming_Discrims return Boolean;
1633       --  Returns True for base types N that rename discriminants, else False
1634 
1635       function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
1636       --  Determine whether a record initialization procedure needs to be
1637       --  generated for the given record type.
1638 
1639       ----------------------
1640       -- Build_Assignment --
1641       ----------------------
1642 
1643       function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
1644          N_Loc : constant Source_Ptr := Sloc (N);
1645          Typ   : constant Entity_Id := Underlying_Type (Etype (Id));
1646          Exp   : Node_Id := N;
1647          Kind  : Node_Kind := Nkind (N);
1648          Lhs   : Node_Id;
1649          Res   : List_Id;
1650 
1651       begin
1652          Lhs :=
1653            Make_Selected_Component (N_Loc,
1654              Prefix        => Make_Identifier (Loc, Name_uInit),
1655              Selector_Name => New_Occurrence_Of (Id, N_Loc));
1656          Set_Assignment_OK (Lhs);
1657 
1658          --  Case of an access attribute applied to the current instance.
1659          --  Replace the reference to the type by a reference to the actual
1660          --  object. (Note that this handles the case of the top level of
1661          --  the expression being given by such an attribute, but does not
1662          --  cover uses nested within an initial value expression. Nested
1663          --  uses are unlikely to occur in practice, but are theoretically
1664          --  possible.) It is not clear how to handle them without fully
1665          --  traversing the expression. ???
1666 
1667          if Kind = N_Attribute_Reference
1668            and then Nam_In (Attribute_Name (N), Name_Unchecked_Access,
1669                                                 Name_Unrestricted_Access)
1670            and then Is_Entity_Name (Prefix (N))
1671            and then Is_Type (Entity (Prefix (N)))
1672            and then Entity (Prefix (N)) = Rec_Type
1673          then
1674             Exp :=
1675               Make_Attribute_Reference (N_Loc,
1676                 Prefix         =>
1677                   Make_Identifier (N_Loc, Name_uInit),
1678                 Attribute_Name => Name_Unrestricted_Access);
1679          end if;
1680 
1681          --  Take a copy of Exp to ensure that later copies of this component
1682          --  declaration in derived types see the original tree, not a node
1683          --  rewritten during expansion of the init_proc. If the copy contains
1684          --  itypes, the scope of the new itypes is the init_proc being built.
1685 
1686          Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
1687 
1688          Res := New_List (
1689            Make_Assignment_Statement (Loc,
1690              Name       => Lhs,
1691              Expression => Exp));
1692 
1693          Set_No_Ctrl_Actions (First (Res));
1694 
1695          --  Adjust the tag if tagged (because of possible view conversions).
1696          --  Suppress the tag adjustment when not Tagged_Type_Expansion because
1697          --  tags are represented implicitly in objects.
1698 
1699          if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
1700             Append_To (Res,
1701               Make_Assignment_Statement (N_Loc,
1702                 Name       =>
1703                   Make_Selected_Component (N_Loc,
1704                     Prefix        =>
1705                       New_Copy_Tree (Lhs, New_Scope => Proc_Id),
1706                     Selector_Name =>
1707                       New_Occurrence_Of (First_Tag_Component (Typ), N_Loc)),
1708 
1709                 Expression =>
1710                   Unchecked_Convert_To (RTE (RE_Tag),
1711                     New_Occurrence_Of
1712                       (Node
1713                         (First_Elmt
1714                           (Access_Disp_Table (Underlying_Type (Typ)))),
1715                        N_Loc))));
1716          end if;
1717 
1718          --  Adjust the component if controlled except if it is an aggregate
1719          --  that will be expanded inline.
1720 
1721          if Kind = N_Qualified_Expression then
1722             Kind := Nkind (Expression (N));
1723          end if;
1724 
1725          if Needs_Finalization (Typ)
1726            and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
1727            and then not Is_Limited_View (Typ)
1728          then
1729             Append_To (Res,
1730               Make_Adjust_Call
1731                 (Obj_Ref => New_Copy_Tree (Lhs),
1732                  Typ     => Etype (Id)));
1733          end if;
1734 
1735          return Res;
1736 
1737       exception
1738          when RE_Not_Available =>
1739             return Empty_List;
1740       end Build_Assignment;
1741 
1742       ------------------------------------
1743       -- Build_Discriminant_Assignments --
1744       ------------------------------------
1745 
1746       procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
1747          Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
1748          D         : Entity_Id;
1749          D_Loc     : Source_Ptr;
1750 
1751       begin
1752          if Has_Discriminants (Rec_Type)
1753            and then not Is_Unchecked_Union (Rec_Type)
1754          then
1755             D := First_Discriminant (Rec_Type);
1756             while Present (D) loop
1757 
1758                --  Don't generate the assignment for discriminants in derived
1759                --  tagged types if the discriminant is a renaming of some
1760                --  ancestor discriminant. This initialization will be done
1761                --  when initializing the _parent field of the derived record.
1762 
1763                if Is_Tagged
1764                  and then Present (Corresponding_Discriminant (D))
1765                then
1766                   null;
1767 
1768                else
1769                   D_Loc := Sloc (D);
1770                   Append_List_To (Statement_List,
1771                     Build_Assignment (D,
1772                       New_Occurrence_Of (Discriminal (D), D_Loc)));
1773                end if;
1774 
1775                Next_Discriminant (D);
1776             end loop;
1777          end if;
1778       end Build_Discriminant_Assignments;
1779 
1780       --------------------------
1781       -- Build_Init_Call_Thru --
1782       --------------------------
1783 
1784       function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
1785          Parent_Proc : constant Entity_Id :=
1786                          Base_Init_Proc (Etype (Rec_Type));
1787 
1788          Parent_Type : constant Entity_Id :=
1789                          Etype (First_Formal (Parent_Proc));
1790 
1791          Uparent_Type : constant Entity_Id :=
1792                           Underlying_Type (Parent_Type);
1793 
1794          First_Discr_Param : Node_Id;
1795 
1796          Arg          : Node_Id;
1797          Args         : List_Id;
1798          First_Arg    : Node_Id;
1799          Parent_Discr : Entity_Id;
1800          Res          : List_Id;
1801 
1802       begin
1803          --  First argument (_Init) is the object to be initialized.
1804          --  ??? not sure where to get a reasonable Loc for First_Arg
1805 
1806          First_Arg :=
1807            OK_Convert_To (Parent_Type,
1808              New_Occurrence_Of
1809                (Defining_Identifier (First (Parameters)), Loc));
1810 
1811          Set_Etype (First_Arg, Parent_Type);
1812 
1813          Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
1814 
1815          --  In the tasks case,
1816          --    add _Master as the value of the _Master parameter
1817          --    add _Chain as the value of the _Chain parameter.
1818          --    add _Task_Name as the value of the _Task_Name parameter.
1819          --  At the outer level, these will be variables holding the
1820          --  corresponding values obtained from GNARL or the expander.
1821          --
1822          --  At inner levels, they will be the parameters passed down through
1823          --  the outer routines.
1824 
1825          First_Discr_Param := Next (First (Parameters));
1826 
1827          if Has_Task (Rec_Type) then
1828             if Restriction_Active (No_Task_Hierarchy) then
1829                Append_To (Args,
1830                  New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
1831             else
1832                Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1833             end if;
1834 
1835             --  Add _Chain (not done for sequential elaboration policy, see
1836             --  comment for Create_Restricted_Task_Sequential in s-tarest.ads).
1837 
1838             if Partition_Elaboration_Policy /= 'S' then
1839                Append_To (Args, Make_Identifier (Loc, Name_uChain));
1840             end if;
1841 
1842             Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
1843             First_Discr_Param := Next (Next (Next (First_Discr_Param)));
1844          end if;
1845 
1846          --  Append discriminant values
1847 
1848          if Has_Discriminants (Uparent_Type) then
1849             pragma Assert (not Is_Tagged_Type (Uparent_Type));
1850 
1851             Parent_Discr := First_Discriminant (Uparent_Type);
1852             while Present (Parent_Discr) loop
1853 
1854                --  Get the initial value for this discriminant
1855                --  ??? needs to be cleaned up to use parent_Discr_Constr
1856                --  directly.
1857 
1858                declare
1859                   Discr       : Entity_Id :=
1860                                   First_Stored_Discriminant (Uparent_Type);
1861 
1862                   Discr_Value : Elmt_Id :=
1863                                   First_Elmt (Stored_Constraint (Rec_Type));
1864 
1865                begin
1866                   while Original_Record_Component (Parent_Discr) /= Discr loop
1867                      Next_Stored_Discriminant (Discr);
1868                      Next_Elmt (Discr_Value);
1869                   end loop;
1870 
1871                   Arg := Node (Discr_Value);
1872                end;
1873 
1874                --  Append it to the list
1875 
1876                if Nkind (Arg) = N_Identifier
1877                  and then Ekind (Entity (Arg)) = E_Discriminant
1878                then
1879                   Append_To (Args,
1880                     New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
1881 
1882                --  Case of access discriminants. We replace the reference
1883                --  to the type by a reference to the actual object.
1884 
1885                --  Is above comment right??? Use of New_Copy below seems mighty
1886                --  suspicious ???
1887 
1888                else
1889                   Append_To (Args, New_Copy (Arg));
1890                end if;
1891 
1892                Next_Discriminant (Parent_Discr);
1893             end loop;
1894          end if;
1895 
1896          Res :=
1897            New_List (
1898              Make_Procedure_Call_Statement (Loc,
1899                Name                   =>
1900                  New_Occurrence_Of (Parent_Proc, Loc),
1901                Parameter_Associations => Args));
1902 
1903          return Res;
1904       end Build_Init_Call_Thru;
1905 
1906       -----------------------------------
1907       -- Build_Offset_To_Top_Functions --
1908       -----------------------------------
1909 
1910       procedure Build_Offset_To_Top_Functions is
1911 
1912          procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
1913          --  Generate:
1914          --    function Fxx (O : Address) return Storage_Offset is
1915          --       type Acc is access all <Typ>;
1916          --    begin
1917          --       return Acc!(O).Iface_Comp'Position;
1918          --    end Fxx;
1919 
1920          ----------------------------------
1921          -- Build_Offset_To_Top_Function --
1922          ----------------------------------
1923 
1924          procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
1925             Body_Node : Node_Id;
1926             Func_Id   : Entity_Id;
1927             Spec_Node : Node_Id;
1928             Acc_Type  : Entity_Id;
1929 
1930          begin
1931             Func_Id := Make_Temporary (Loc, 'F');
1932             Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
1933 
1934             --  Generate
1935             --    function Fxx (O : in Rec_Typ) return Storage_Offset;
1936 
1937             Spec_Node := New_Node (N_Function_Specification, Loc);
1938             Set_Defining_Unit_Name (Spec_Node, Func_Id);
1939             Set_Parameter_Specifications (Spec_Node, New_List (
1940               Make_Parameter_Specification (Loc,
1941                 Defining_Identifier =>
1942                   Make_Defining_Identifier (Loc, Name_uO),
1943                 In_Present          => True,
1944                 Parameter_Type      =>
1945                   New_Occurrence_Of (RTE (RE_Address), Loc))));
1946             Set_Result_Definition (Spec_Node,
1947               New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
1948 
1949             --  Generate
1950             --    function Fxx (O : in Rec_Typ) return Storage_Offset is
1951             --    begin
1952             --       return O.Iface_Comp'Position;
1953             --    end Fxx;
1954 
1955             Body_Node := New_Node (N_Subprogram_Body, Loc);
1956             Set_Specification (Body_Node, Spec_Node);
1957 
1958             Acc_Type := Make_Temporary (Loc, 'T');
1959             Set_Declarations (Body_Node, New_List (
1960               Make_Full_Type_Declaration (Loc,
1961                 Defining_Identifier => Acc_Type,
1962                 Type_Definition     =>
1963                   Make_Access_To_Object_Definition (Loc,
1964                     All_Present            => True,
1965                     Null_Exclusion_Present => False,
1966                     Constant_Present       => False,
1967                     Subtype_Indication     =>
1968                       New_Occurrence_Of (Rec_Type, Loc)))));
1969 
1970             Set_Handled_Statement_Sequence (Body_Node,
1971               Make_Handled_Sequence_Of_Statements (Loc,
1972                 Statements     => New_List (
1973                   Make_Simple_Return_Statement (Loc,
1974                     Expression =>
1975                       Make_Attribute_Reference (Loc,
1976                         Prefix         =>
1977                           Make_Selected_Component (Loc,
1978                             Prefix        =>
1979                               Unchecked_Convert_To (Acc_Type,
1980                                 Make_Identifier (Loc, Name_uO)),
1981                             Selector_Name =>
1982                               New_Occurrence_Of (Iface_Comp, Loc)),
1983                         Attribute_Name => Name_Position)))));
1984 
1985             Set_Ekind       (Func_Id, E_Function);
1986             Set_Mechanism   (Func_Id, Default_Mechanism);
1987             Set_Is_Internal (Func_Id, True);
1988 
1989             if not Debug_Generated_Code then
1990                Set_Debug_Info_Off (Func_Id);
1991             end if;
1992 
1993             Analyze (Body_Node);
1994 
1995             Append_Freeze_Action (Rec_Type, Body_Node);
1996          end Build_Offset_To_Top_Function;
1997 
1998          --  Local variables
1999 
2000          Iface_Comp       : Node_Id;
2001          Iface_Comp_Elmt  : Elmt_Id;
2002          Ifaces_Comp_List : Elist_Id;
2003 
2004       --  Start of processing for Build_Offset_To_Top_Functions
2005 
2006       begin
2007          --  Offset_To_Top_Functions are built only for derivations of types
2008          --  with discriminants that cover interface types.
2009          --  Nothing is needed either in case of virtual targets, since
2010          --  interfaces are handled directly by the target.
2011 
2012          if not Is_Tagged_Type (Rec_Type)
2013            or else Etype (Rec_Type) = Rec_Type
2014            or else not Has_Discriminants (Etype (Rec_Type))
2015            or else not Tagged_Type_Expansion
2016          then
2017             return;
2018          end if;
2019 
2020          Collect_Interface_Components (Rec_Type, Ifaces_Comp_List);
2021 
2022          --  For each interface type with secondary dispatch table we generate
2023          --  the Offset_To_Top_Functions (required to displace the pointer in
2024          --  interface conversions)
2025 
2026          Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
2027          while Present (Iface_Comp_Elmt) loop
2028             Iface_Comp := Node (Iface_Comp_Elmt);
2029             pragma Assert (Is_Interface (Related_Type (Iface_Comp)));
2030 
2031             --  If the interface is a parent of Rec_Type it shares the primary
2032             --  dispatch table and hence there is no need to build the function
2033 
2034             if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
2035                                 Use_Full_View => True)
2036             then
2037                Build_Offset_To_Top_Function (Iface_Comp);
2038             end if;
2039 
2040             Next_Elmt (Iface_Comp_Elmt);
2041          end loop;
2042       end Build_Offset_To_Top_Functions;
2043 
2044       ------------------------------
2045       -- Build_CPP_Init_Procedure --
2046       ------------------------------
2047 
2048       procedure Build_CPP_Init_Procedure is
2049          Body_Node         : Node_Id;
2050          Body_Stmts        : List_Id;
2051          Flag_Id           : Entity_Id;
2052          Handled_Stmt_Node : Node_Id;
2053          Init_Tags_List    : List_Id;
2054          Proc_Id           : Entity_Id;
2055          Proc_Spec_Node    : Node_Id;
2056 
2057       begin
2058          --  Check cases requiring no IC routine
2059 
2060          if not Is_CPP_Class (Root_Type (Rec_Type))
2061            or else Is_CPP_Class (Rec_Type)
2062            or else CPP_Num_Prims (Rec_Type) = 0
2063            or else not Tagged_Type_Expansion
2064            or else No_Run_Time_Mode
2065          then
2066             return;
2067          end if;
2068 
2069          --  Generate:
2070 
2071          --     Flag : Boolean := False;
2072          --
2073          --     procedure Typ_IC is
2074          --     begin
2075          --        if not Flag then
2076          --           Copy C++ dispatch table slots from parent
2077          --           Update C++ slots of overridden primitives
2078          --        end if;
2079          --     end;
2080 
2081          Flag_Id := Make_Temporary (Loc, 'F');
2082 
2083          Append_Freeze_Action (Rec_Type,
2084            Make_Object_Declaration (Loc,
2085              Defining_Identifier => Flag_Id,
2086              Object_Definition =>
2087                New_Occurrence_Of (Standard_Boolean, Loc),
2088              Expression =>
2089                New_Occurrence_Of (Standard_True, Loc)));
2090 
2091          Body_Stmts := New_List;
2092          Body_Node  := New_Node (N_Subprogram_Body, Loc);
2093 
2094          Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2095 
2096          Proc_Id :=
2097            Make_Defining_Identifier (Loc,
2098              Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
2099 
2100          Set_Ekind       (Proc_Id, E_Procedure);
2101          Set_Is_Internal (Proc_Id);
2102 
2103          Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2104 
2105          Set_Parameter_Specifications (Proc_Spec_Node, New_List);
2106          Set_Specification (Body_Node, Proc_Spec_Node);
2107          Set_Declarations  (Body_Node, New_List);
2108 
2109          Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
2110 
2111          Append_To (Init_Tags_List,
2112            Make_Assignment_Statement (Loc,
2113              Name =>
2114                New_Occurrence_Of (Flag_Id, Loc),
2115              Expression =>
2116                New_Occurrence_Of (Standard_False, Loc)));
2117 
2118          Append_To (Body_Stmts,
2119            Make_If_Statement (Loc,
2120              Condition => New_Occurrence_Of (Flag_Id, Loc),
2121              Then_Statements => Init_Tags_List));
2122 
2123          Handled_Stmt_Node :=
2124            New_Node (N_Handled_Sequence_Of_Statements, Loc);
2125          Set_Statements (Handled_Stmt_Node, Body_Stmts);
2126          Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2127          Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2128 
2129          if not Debug_Generated_Code then
2130             Set_Debug_Info_Off (Proc_Id);
2131          end if;
2132 
2133          --  Associate CPP_Init_Proc with type
2134 
2135          Set_Init_Proc (Rec_Type, Proc_Id);
2136       end Build_CPP_Init_Procedure;
2137 
2138       --------------------------
2139       -- Build_Init_Procedure --
2140       --------------------------
2141 
2142       procedure Build_Init_Procedure is
2143          Body_Stmts            : List_Id;
2144          Body_Node             : Node_Id;
2145          Handled_Stmt_Node     : Node_Id;
2146          Init_Tags_List        : List_Id;
2147          Parameters            : List_Id;
2148          Proc_Spec_Node        : Node_Id;
2149          Record_Extension_Node : Node_Id;
2150 
2151       begin
2152          Body_Stmts := New_List;
2153          Body_Node := New_Node (N_Subprogram_Body, Loc);
2154          Set_Ekind (Proc_Id, E_Procedure);
2155 
2156          Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2157          Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2158 
2159          Parameters := Init_Formals (Rec_Type);
2160          Append_List_To (Parameters,
2161            Build_Discriminant_Formals (Rec_Type, True));
2162 
2163          --  For tagged types, we add a flag to indicate whether the routine
2164          --  is called to initialize a parent component in the init_proc of
2165          --  a type extension. If the flag is false, we do not set the tag
2166          --  because it has been set already in the extension.
2167 
2168          if Is_Tagged_Type (Rec_Type) then
2169             Set_Tag := Make_Temporary (Loc, 'P');
2170 
2171             Append_To (Parameters,
2172               Make_Parameter_Specification (Loc,
2173                 Defining_Identifier => Set_Tag,
2174                 Parameter_Type =>
2175                   New_Occurrence_Of (Standard_Boolean, Loc),
2176                 Expression =>
2177                   New_Occurrence_Of (Standard_True, Loc)));
2178          end if;
2179 
2180          Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
2181          Set_Specification (Body_Node, Proc_Spec_Node);
2182          Set_Declarations (Body_Node, Decls);
2183 
2184          --  N is a Derived_Type_Definition that renames the parameters of the
2185          --  ancestor type. We initialize it by expanding our discriminants and
2186          --  call the ancestor _init_proc with a type-converted object.
2187 
2188          if Parent_Subtype_Renaming_Discrims then
2189             Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
2190 
2191          elsif Nkind (Type_Definition (N)) = N_Record_Definition then
2192             Build_Discriminant_Assignments (Body_Stmts);
2193 
2194             if not Null_Present (Type_Definition (N)) then
2195                Append_List_To (Body_Stmts,
2196                  Build_Init_Statements (Component_List (Type_Definition (N))));
2197             end if;
2198 
2199          --  N is a Derived_Type_Definition with a possible non-empty
2200          --  extension. The initialization of a type extension consists in the
2201          --  initialization of the components in the extension.
2202 
2203          else
2204             Build_Discriminant_Assignments (Body_Stmts);
2205 
2206             Record_Extension_Node :=
2207               Record_Extension_Part (Type_Definition (N));
2208 
2209             if not Null_Present (Record_Extension_Node) then
2210                declare
2211                   Stmts : constant List_Id :=
2212                             Build_Init_Statements (
2213                               Component_List (Record_Extension_Node));
2214 
2215                begin
2216                   --  The parent field must be initialized first because the
2217                   --  offset of the new discriminants may depend on it. This is
2218                   --  not needed if the parent is an interface type because in
2219                   --  such case the initialization of the _parent field was not
2220                   --  generated.
2221 
2222                   if not Is_Interface (Etype (Rec_Ent)) then
2223                      declare
2224                         Parent_IP : constant Name_Id :=
2225                                       Make_Init_Proc_Name (Etype (Rec_Ent));
2226                         Stmt      : Node_Id;
2227                         IP_Call   : Node_Id;
2228                         IP_Stmts  : List_Id;
2229 
2230                      begin
2231                         --  Look for a call to the parent IP at the beginning
2232                         --  of Stmts associated with the record extension
2233 
2234                         Stmt := First (Stmts);
2235                         IP_Call := Empty;
2236                         while Present (Stmt) loop
2237                            if Nkind (Stmt) = N_Procedure_Call_Statement
2238                              and then Chars (Name (Stmt)) = Parent_IP
2239                            then
2240                               IP_Call := Stmt;
2241                               exit;
2242                            end if;
2243 
2244                            Next (Stmt);
2245                         end loop;
2246 
2247                         --  If found then move it to the beginning of the
2248                         --  statements of this IP routine
2249 
2250                         if Present (IP_Call) then
2251                            IP_Stmts := New_List;
2252                            loop
2253                               Stmt := Remove_Head (Stmts);
2254                               Append_To (IP_Stmts, Stmt);
2255                               exit when Stmt = IP_Call;
2256                            end loop;
2257 
2258                            Prepend_List_To (Body_Stmts, IP_Stmts);
2259                         end if;
2260                      end;
2261                   end if;
2262 
2263                   Append_List_To (Body_Stmts, Stmts);
2264                end;
2265             end if;
2266          end if;
2267 
2268          --  Add here the assignment to instantiate the Tag
2269 
2270          --  The assignment corresponds to the code:
2271 
2272          --     _Init._Tag := Typ'Tag;
2273 
2274          --  Suppress the tag assignment when not Tagged_Type_Expansion because
2275          --  tags are represented implicitly in objects. It is also suppressed
2276          --  in case of CPP_Class types because in this case the tag is
2277          --  initialized in the C++ side.
2278 
2279          if Is_Tagged_Type (Rec_Type)
2280            and then Tagged_Type_Expansion
2281            and then not No_Run_Time_Mode
2282          then
2283             --  Case 1: Ada tagged types with no CPP ancestor. Set the tags of
2284             --  the actual object and invoke the IP of the parent (in this
2285             --  order). The tag must be initialized before the call to the IP
2286             --  of the parent and the assignments to other components because
2287             --  the initial value of the components may depend on the tag (eg.
2288             --  through a dispatching operation on an access to the current
2289             --  type). The tag assignment is not done when initializing the
2290             --  parent component of a type extension, because in that case the
2291             --  tag is set in the extension.
2292 
2293             if not Is_CPP_Class (Root_Type (Rec_Type)) then
2294 
2295                --  Initialize the primary tag component
2296 
2297                Init_Tags_List := New_List (
2298                  Make_Assignment_Statement (Loc,
2299                    Name =>
2300                      Make_Selected_Component (Loc,
2301                        Prefix        => Make_Identifier (Loc, Name_uInit),
2302                        Selector_Name =>
2303                          New_Occurrence_Of
2304                            (First_Tag_Component (Rec_Type), Loc)),
2305                    Expression =>
2306                      New_Occurrence_Of
2307                        (Node
2308                          (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2309 
2310                --  Ada 2005 (AI-251): Initialize the secondary tags components
2311                --  located at fixed positions (tags whose position depends on
2312                --  variable size components are initialized later ---see below)
2313 
2314                if Ada_Version >= Ada_2005
2315                  and then not Is_Interface (Rec_Type)
2316                  and then Has_Interfaces (Rec_Type)
2317                then
2318                   Init_Secondary_Tags
2319                     (Typ            => Rec_Type,
2320                      Target         => Make_Identifier (Loc, Name_uInit),
2321                      Stmts_List     => Init_Tags_List,
2322                      Fixed_Comps    => True,
2323                      Variable_Comps => False);
2324                end if;
2325 
2326                Prepend_To (Body_Stmts,
2327                  Make_If_Statement (Loc,
2328                    Condition => New_Occurrence_Of (Set_Tag, Loc),
2329                    Then_Statements => Init_Tags_List));
2330 
2331             --  Case 2: CPP type. The imported C++ constructor takes care of
2332             --  tags initialization. No action needed here because the IP
2333             --  is built by Set_CPP_Constructors; in this case the IP is a
2334             --  wrapper that invokes the C++ constructor and copies the C++
2335             --  tags locally. Done to inherit the C++ slots in Ada derivations
2336             --  (see case 3).
2337 
2338             elsif Is_CPP_Class (Rec_Type) then
2339                pragma Assert (False);
2340                null;
2341 
2342             --  Case 3: Combined hierarchy containing C++ types and Ada tagged
2343             --  type derivations. Derivations of imported C++ classes add a
2344             --  complication, because we cannot inhibit tag setting in the
2345             --  constructor for the parent. Hence we initialize the tag after
2346             --  the call to the parent IP (that is, in reverse order compared
2347             --  with pure Ada hierarchies ---see comment on case 1).
2348 
2349             else
2350                --  Initialize the primary tag
2351 
2352                Init_Tags_List := New_List (
2353                  Make_Assignment_Statement (Loc,
2354                    Name =>
2355                      Make_Selected_Component (Loc,
2356                        Prefix        => Make_Identifier (Loc, Name_uInit),
2357                        Selector_Name =>
2358                          New_Occurrence_Of
2359                            (First_Tag_Component (Rec_Type), Loc)),
2360                    Expression =>
2361                      New_Occurrence_Of
2362                        (Node
2363                          (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2364 
2365                --  Ada 2005 (AI-251): Initialize the secondary tags components
2366                --  located at fixed positions (tags whose position depends on
2367                --  variable size components are initialized later ---see below)
2368 
2369                if Ada_Version >= Ada_2005
2370                  and then not Is_Interface (Rec_Type)
2371                  and then Has_Interfaces (Rec_Type)
2372                then
2373                   Init_Secondary_Tags
2374                     (Typ            => Rec_Type,
2375                      Target         => Make_Identifier (Loc, Name_uInit),
2376                      Stmts_List     => Init_Tags_List,
2377                      Fixed_Comps    => True,
2378                      Variable_Comps => False);
2379                end if;
2380 
2381                --  Initialize the tag component after invocation of parent IP.
2382 
2383                --  Generate:
2384                --     parent_IP(_init.parent); // Invokes the C++ constructor
2385                --     [ typIC; ]               // Inherit C++ slots from parent
2386                --     init_tags
2387 
2388                declare
2389                   Ins_Nod : Node_Id;
2390 
2391                begin
2392                   --  Search for the call to the IP of the parent. We assume
2393                   --  that the first init_proc call is for the parent.
2394 
2395                   Ins_Nod := First (Body_Stmts);
2396                   while Present (Next (Ins_Nod))
2397                     and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
2398                                or else not Is_Init_Proc (Name (Ins_Nod)))
2399                   loop
2400                      Next (Ins_Nod);
2401                   end loop;
2402 
2403                   --  The IC routine copies the inherited slots of the C+ part
2404                   --  of the dispatch table from the parent and updates the
2405                   --  overridden C++ slots.
2406 
2407                   if CPP_Num_Prims (Rec_Type) > 0 then
2408                      declare
2409                         Init_DT : Entity_Id;
2410                         New_Nod : Node_Id;
2411 
2412                      begin
2413                         Init_DT := CPP_Init_Proc (Rec_Type);
2414                         pragma Assert (Present (Init_DT));
2415 
2416                         New_Nod :=
2417                           Make_Procedure_Call_Statement (Loc,
2418                             New_Occurrence_Of (Init_DT, Loc));
2419                         Insert_After (Ins_Nod, New_Nod);
2420 
2421                         --  Update location of init tag statements
2422 
2423                         Ins_Nod := New_Nod;
2424                      end;
2425                   end if;
2426 
2427                   Insert_List_After (Ins_Nod, Init_Tags_List);
2428                end;
2429             end if;
2430 
2431             --  Ada 2005 (AI-251): Initialize the secondary tag components
2432             --  located at variable positions. We delay the generation of this
2433             --  code until here because the value of the attribute 'Position
2434             --  applied to variable size components of the parent type that
2435             --  depend on discriminants is only safely read at runtime after
2436             --  the parent components have been initialized.
2437 
2438             if Ada_Version >= Ada_2005
2439               and then not Is_Interface (Rec_Type)
2440               and then Has_Interfaces (Rec_Type)
2441               and then Has_Discriminants (Etype (Rec_Type))
2442               and then Is_Variable_Size_Record (Etype (Rec_Type))
2443             then
2444                Init_Tags_List := New_List;
2445 
2446                Init_Secondary_Tags
2447                  (Typ            => Rec_Type,
2448                   Target         => Make_Identifier (Loc, Name_uInit),
2449                   Stmts_List     => Init_Tags_List,
2450                   Fixed_Comps    => False,
2451                   Variable_Comps => True);
2452 
2453                if Is_Non_Empty_List (Init_Tags_List) then
2454                   Append_List_To (Body_Stmts, Init_Tags_List);
2455                end if;
2456             end if;
2457          end if;
2458 
2459          Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
2460          Set_Statements (Handled_Stmt_Node, Body_Stmts);
2461 
2462          --  Generate:
2463          --    Deep_Finalize (_init, C1, ..., CN);
2464          --    raise;
2465 
2466          if Counter > 0
2467            and then Needs_Finalization (Rec_Type)
2468            and then not Is_Abstract_Type (Rec_Type)
2469            and then not Restriction_Active (No_Exception_Propagation)
2470          then
2471             declare
2472                DF_Call : Node_Id;
2473                DF_Id   : Entity_Id;
2474 
2475             begin
2476                --  Create a local version of Deep_Finalize which has indication
2477                --  of partial initialization state.
2478 
2479                DF_Id := Make_Temporary (Loc, 'F');
2480 
2481                Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
2482 
2483                DF_Call :=
2484                  Make_Procedure_Call_Statement (Loc,
2485                    Name                   => New_Occurrence_Of (DF_Id, Loc),
2486                    Parameter_Associations => New_List (
2487                      Make_Identifier (Loc, Name_uInit),
2488                      New_Occurrence_Of (Standard_False, Loc)));
2489 
2490                --  Do not emit warnings related to the elaboration order when a
2491                --  controlled object is declared before the body of Finalize is
2492                --  seen.
2493 
2494                Set_No_Elaboration_Check (DF_Call);
2495 
2496                Set_Exception_Handlers (Handled_Stmt_Node, New_List (
2497                  Make_Exception_Handler (Loc,
2498                    Exception_Choices => New_List (
2499                      Make_Others_Choice (Loc)),
2500                    Statements        => New_List (
2501                      DF_Call,
2502                      Make_Raise_Statement (Loc)))));
2503             end;
2504          else
2505             Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2506          end if;
2507 
2508          Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2509 
2510          if not Debug_Generated_Code then
2511             Set_Debug_Info_Off (Proc_Id);
2512          end if;
2513 
2514          --  Associate Init_Proc with type, and determine if the procedure
2515          --  is null (happens because of the Initialize_Scalars pragma case,
2516          --  where we have to generate a null procedure in case it is called
2517          --  by a client with Initialize_Scalars set). Such procedures have
2518          --  to be generated, but do not have to be called, so we mark them
2519          --  as null to suppress the call.
2520 
2521          Set_Init_Proc (Rec_Type, Proc_Id);
2522 
2523          if List_Length (Body_Stmts) = 1
2524 
2525            --  We must skip SCIL nodes because they may have been added to this
2526            --  list by Insert_Actions.
2527 
2528            and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
2529          then
2530             Set_Is_Null_Init_Proc (Proc_Id);
2531          end if;
2532       end Build_Init_Procedure;
2533 
2534       ---------------------------
2535       -- Build_Init_Statements --
2536       ---------------------------
2537 
2538       function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
2539          Checks       : constant List_Id := New_List;
2540          Actions      : List_Id          := No_List;
2541          Counter_Id   : Entity_Id        := Empty;
2542          Comp_Loc     : Source_Ptr;
2543          Decl         : Node_Id;
2544          Has_POC      : Boolean;
2545          Id           : Entity_Id;
2546          Parent_Stmts : List_Id;
2547          Stmts        : List_Id;
2548          Typ          : Entity_Id;
2549 
2550          procedure Increment_Counter (Loc : Source_Ptr);
2551          --  Generate an "increment by one" statement for the current counter
2552          --  and append it to the list Stmts.
2553 
2554          procedure Make_Counter (Loc : Source_Ptr);
2555          --  Create a new counter for the current component list. The routine
2556          --  creates a new defining Id, adds an object declaration and sets
2557          --  the Id generator for the next variant.
2558 
2559          -----------------------
2560          -- Increment_Counter --
2561          -----------------------
2562 
2563          procedure Increment_Counter (Loc : Source_Ptr) is
2564          begin
2565             --  Generate:
2566             --    Counter := Counter + 1;
2567 
2568             Append_To (Stmts,
2569               Make_Assignment_Statement (Loc,
2570                 Name       => New_Occurrence_Of (Counter_Id, Loc),
2571                 Expression =>
2572                   Make_Op_Add (Loc,
2573                     Left_Opnd  => New_Occurrence_Of (Counter_Id, Loc),
2574                     Right_Opnd => Make_Integer_Literal (Loc, 1))));
2575          end Increment_Counter;
2576 
2577          ------------------
2578          -- Make_Counter --
2579          ------------------
2580 
2581          procedure Make_Counter (Loc : Source_Ptr) is
2582          begin
2583             --  Increment the Id generator
2584 
2585             Counter := Counter + 1;
2586 
2587             --  Create the entity and declaration
2588 
2589             Counter_Id :=
2590               Make_Defining_Identifier (Loc,
2591                 Chars => New_External_Name ('C', Counter));
2592 
2593             --  Generate:
2594             --    Cnn : Integer := 0;
2595 
2596             Append_To (Decls,
2597               Make_Object_Declaration (Loc,
2598                 Defining_Identifier => Counter_Id,
2599                 Object_Definition   =>
2600                   New_Occurrence_Of (Standard_Integer, Loc),
2601                 Expression          =>
2602                   Make_Integer_Literal (Loc, 0)));
2603          end Make_Counter;
2604 
2605       --  Start of processing for Build_Init_Statements
2606 
2607       begin
2608          if Null_Present (Comp_List) then
2609             return New_List (Make_Null_Statement (Loc));
2610          end if;
2611 
2612          Parent_Stmts := New_List;
2613          Stmts := New_List;
2614 
2615          --  Loop through visible declarations of task types and protected
2616          --  types moving any expanded code from the spec to the body of the
2617          --  init procedure.
2618 
2619          if Is_Task_Record_Type (Rec_Type)
2620            or else Is_Protected_Record_Type (Rec_Type)
2621          then
2622             declare
2623                Decl : constant Node_Id :=
2624                         Parent (Corresponding_Concurrent_Type (Rec_Type));
2625                Def  : Node_Id;
2626                N1   : Node_Id;
2627                N2   : Node_Id;
2628 
2629             begin
2630                if Is_Task_Record_Type (Rec_Type) then
2631                   Def := Task_Definition (Decl);
2632                else
2633                   Def := Protected_Definition (Decl);
2634                end if;
2635 
2636                if Present (Def) then
2637                   N1 := First (Visible_Declarations (Def));
2638                   while Present (N1) loop
2639                      N2 := N1;
2640                      N1 := Next (N1);
2641 
2642                      if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
2643                        or else Nkind (N2) in N_Raise_xxx_Error
2644                        or else Nkind (N2) = N_Procedure_Call_Statement
2645                      then
2646                         Append_To (Stmts,
2647                           New_Copy_Tree (N2, New_Scope => Proc_Id));
2648                         Rewrite (N2, Make_Null_Statement (Sloc (N2)));
2649                         Analyze (N2);
2650                      end if;
2651                   end loop;
2652                end if;
2653             end;
2654          end if;
2655 
2656          --  Loop through components, skipping pragmas, in 2 steps. The first
2657          --  step deals with regular components. The second step deals with
2658          --  components that have per object constraints and no explicit
2659          --  initialization.
2660 
2661          Has_POC := False;
2662 
2663          --  First pass : regular components
2664 
2665          Decl := First_Non_Pragma (Component_Items (Comp_List));
2666          while Present (Decl) loop
2667             Comp_Loc := Sloc (Decl);
2668             Build_Record_Checks
2669               (Subtype_Indication (Component_Definition (Decl)), Checks);
2670 
2671             Id  := Defining_Identifier (Decl);
2672             Typ := Etype (Id);
2673 
2674             --  Leave any processing of per-object constrained component for
2675             --  the second pass.
2676 
2677             if Has_Access_Constraint (Id) and then No (Expression (Decl)) then
2678                Has_POC := True;
2679 
2680             --  Regular component cases
2681 
2682             else
2683                --  In the context of the init proc, references to discriminants
2684                --  resolve to denote the discriminals: this is where we can
2685                --  freeze discriminant dependent component subtypes.
2686 
2687                if not Is_Frozen (Typ) then
2688                   Append_List_To (Stmts, Freeze_Entity (Typ, N));
2689                end if;
2690 
2691                --  Explicit initialization
2692 
2693                if Present (Expression (Decl)) then
2694                   if Is_CPP_Constructor_Call (Expression (Decl)) then
2695                      Actions :=
2696                        Build_Initialization_Call
2697                          (Comp_Loc,
2698                           Id_Ref          =>
2699                             Make_Selected_Component (Comp_Loc,
2700                               Prefix        =>
2701                                 Make_Identifier (Comp_Loc, Name_uInit),
2702                               Selector_Name =>
2703                                 New_Occurrence_Of (Id, Comp_Loc)),
2704                           Typ             => Typ,
2705                           In_Init_Proc    => True,
2706                           Enclos_Type     => Rec_Type,
2707                           Discr_Map       => Discr_Map,
2708                           Constructor_Ref => Expression (Decl));
2709                   else
2710                      Actions := Build_Assignment (Id, Expression (Decl));
2711                   end if;
2712 
2713                --  CPU, Dispatching_Domain, Priority and Size components are
2714                --  filled with the corresponding rep item expression of the
2715                --  concurrent type (if any).
2716 
2717                elsif Ekind (Scope (Id)) = E_Record_Type
2718                  and then Present (Corresponding_Concurrent_Type (Scope (Id)))
2719                  and then Nam_In (Chars (Id), Name_uCPU,
2720                                               Name_uDispatching_Domain,
2721                                               Name_uPriority)
2722                then
2723                   declare
2724                      Exp   : Node_Id;
2725                      Nam   : Name_Id;
2726                      Ritem : Node_Id;
2727 
2728                   begin
2729                      if Chars (Id) = Name_uCPU then
2730                         Nam := Name_CPU;
2731 
2732                      elsif Chars (Id) = Name_uDispatching_Domain then
2733                         Nam := Name_Dispatching_Domain;
2734 
2735                      elsif Chars (Id) = Name_uPriority then
2736                         Nam := Name_Priority;
2737                      end if;
2738 
2739                      --  Get the Rep Item (aspect specification, attribute
2740                      --  definition clause or pragma) of the corresponding
2741                      --  concurrent type.
2742 
2743                      Ritem :=
2744                        Get_Rep_Item
2745                          (Corresponding_Concurrent_Type (Scope (Id)),
2746                           Nam,
2747                           Check_Parents => False);
2748 
2749                      if Present (Ritem) then
2750 
2751                         --  Pragma case
2752 
2753                         if Nkind (Ritem) = N_Pragma then
2754                            Exp := First (Pragma_Argument_Associations (Ritem));
2755 
2756                            if Nkind (Exp) = N_Pragma_Argument_Association then
2757                               Exp := Expression (Exp);
2758                            end if;
2759 
2760                            --  Conversion for Priority expression
2761 
2762                            if Nam = Name_Priority then
2763                               if Pragma_Name (Ritem) = Name_Priority
2764                                 and then not GNAT_Mode
2765                               then
2766                                  Exp := Convert_To (RTE (RE_Priority), Exp);
2767                               else
2768                                  Exp :=
2769                                    Convert_To (RTE (RE_Any_Priority), Exp);
2770                               end if;
2771                            end if;
2772 
2773                         --  Aspect/Attribute definition clause case
2774 
2775                         else
2776                            Exp := Expression (Ritem);
2777 
2778                            --  Conversion for Priority expression
2779 
2780                            if Nam = Name_Priority then
2781                               if Chars (Ritem) = Name_Priority
2782                                 and then not GNAT_Mode
2783                               then
2784                                  Exp := Convert_To (RTE (RE_Priority), Exp);
2785                               else
2786                                  Exp :=
2787                                    Convert_To (RTE (RE_Any_Priority), Exp);
2788                               end if;
2789                            end if;
2790                         end if;
2791 
2792                         --  Conversion for Dispatching_Domain value
2793 
2794                         if Nam = Name_Dispatching_Domain then
2795                            Exp :=
2796                              Unchecked_Convert_To
2797                                (RTE (RE_Dispatching_Domain_Access), Exp);
2798                         end if;
2799 
2800                         Actions := Build_Assignment (Id, Exp);
2801 
2802                      --  Nothing needed if no Rep Item
2803 
2804                      else
2805                         Actions := No_List;
2806                      end if;
2807                   end;
2808 
2809                --  Composite component with its own Init_Proc
2810 
2811                elsif not Is_Interface (Typ)
2812                  and then Has_Non_Null_Base_Init_Proc (Typ)
2813                then
2814                   Actions :=
2815                     Build_Initialization_Call
2816                       (Comp_Loc,
2817                        Make_Selected_Component (Comp_Loc,
2818                          Prefix        =>
2819                            Make_Identifier (Comp_Loc, Name_uInit),
2820                          Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
2821                        Typ,
2822                        In_Init_Proc => True,
2823                        Enclos_Type  => Rec_Type,
2824                        Discr_Map    => Discr_Map);
2825 
2826                   Clean_Task_Names (Typ, Proc_Id);
2827 
2828                --  Simple initialization
2829 
2830                elsif Component_Needs_Simple_Initialization (Typ) then
2831                   Actions :=
2832                     Build_Assignment
2833                       (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)));
2834 
2835                --  Nothing needed for this case
2836 
2837                else
2838                   Actions := No_List;
2839                end if;
2840 
2841                if Present (Checks) then
2842                   if Chars (Id) = Name_uParent then
2843                      Append_List_To (Parent_Stmts, Checks);
2844                   else
2845                      Append_List_To (Stmts, Checks);
2846                   end if;
2847                end if;
2848 
2849                if Present (Actions) then
2850                   if Chars (Id) = Name_uParent then
2851                      Append_List_To (Parent_Stmts, Actions);
2852 
2853                   else
2854                      Append_List_To (Stmts, Actions);
2855 
2856                      --  Preserve initialization state in the current counter
2857 
2858                      if Needs_Finalization (Typ) then
2859                         if No (Counter_Id) then
2860                            Make_Counter (Comp_Loc);
2861                         end if;
2862 
2863                         Increment_Counter (Comp_Loc);
2864                      end if;
2865                   end if;
2866                end if;
2867             end if;
2868 
2869             Next_Non_Pragma (Decl);
2870          end loop;
2871 
2872          --  The parent field must be initialized first because variable
2873          --  size components of the parent affect the location of all the
2874          --  new components.
2875 
2876          Prepend_List_To (Stmts, Parent_Stmts);
2877 
2878          --  Set up tasks and protected object support. This needs to be done
2879          --  before any component with a per-object access discriminant
2880          --  constraint, or any variant part (which may contain such
2881          --  components) is initialized, because the initialization of these
2882          --  components may reference the enclosing concurrent object.
2883 
2884          --  For a task record type, add the task create call and calls to bind
2885          --  any interrupt (signal) entries.
2886 
2887          if Is_Task_Record_Type (Rec_Type) then
2888 
2889             --  In the case of the restricted run time the ATCB has already
2890             --  been preallocated.
2891 
2892             if Restricted_Profile then
2893                Append_To (Stmts,
2894                  Make_Assignment_Statement (Loc,
2895                    Name       =>
2896                      Make_Selected_Component (Loc,
2897                        Prefix        => Make_Identifier (Loc, Name_uInit),
2898                        Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2899                    Expression =>
2900                      Make_Attribute_Reference (Loc,
2901                        Prefix         =>
2902                          Make_Selected_Component (Loc,
2903                            Prefix        => Make_Identifier (Loc, Name_uInit),
2904                            Selector_Name => Make_Identifier (Loc, Name_uATCB)),
2905                        Attribute_Name => Name_Unchecked_Access)));
2906             end if;
2907 
2908             Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
2909 
2910             declare
2911                Task_Type : constant Entity_Id :=
2912                              Corresponding_Concurrent_Type (Rec_Type);
2913                Task_Decl : constant Node_Id := Parent (Task_Type);
2914                Task_Def  : constant Node_Id := Task_Definition (Task_Decl);
2915                Decl_Loc  : Source_Ptr;
2916                Ent       : Entity_Id;
2917                Vis_Decl  : Node_Id;
2918 
2919             begin
2920                if Present (Task_Def) then
2921                   Vis_Decl := First (Visible_Declarations (Task_Def));
2922                   while Present (Vis_Decl) loop
2923                      Decl_Loc := Sloc (Vis_Decl);
2924 
2925                      if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
2926                         if Get_Attribute_Id (Chars (Vis_Decl)) =
2927                                                        Attribute_Address
2928                         then
2929                            Ent := Entity (Name (Vis_Decl));
2930 
2931                            if Ekind (Ent) = E_Entry then
2932                               Append_To (Stmts,
2933                                 Make_Procedure_Call_Statement (Decl_Loc,
2934                                   Name =>
2935                                     New_Occurrence_Of (RTE (
2936                                       RE_Bind_Interrupt_To_Entry), Decl_Loc),
2937                                   Parameter_Associations => New_List (
2938                                     Make_Selected_Component (Decl_Loc,
2939                                       Prefix        =>
2940                                         Make_Identifier (Decl_Loc, Name_uInit),
2941                                       Selector_Name =>
2942                                         Make_Identifier
2943                                          (Decl_Loc, Name_uTask_Id)),
2944                                     Entry_Index_Expression
2945                                       (Decl_Loc, Ent, Empty, Task_Type),
2946                                     Expression (Vis_Decl))));
2947                            end if;
2948                         end if;
2949                      end if;
2950 
2951                      Next (Vis_Decl);
2952                   end loop;
2953                end if;
2954             end;
2955          end if;
2956 
2957          --  For a protected type, add statements generated by
2958          --  Make_Initialize_Protection.
2959 
2960          if Is_Protected_Record_Type (Rec_Type) then
2961             Append_List_To (Stmts,
2962               Make_Initialize_Protection (Rec_Type));
2963          end if;
2964 
2965          --  Second pass: components with per-object constraints
2966 
2967          if Has_POC then
2968             Decl := First_Non_Pragma (Component_Items (Comp_List));
2969             while Present (Decl) loop
2970                Comp_Loc := Sloc (Decl);
2971                Id := Defining_Identifier (Decl);
2972                Typ := Etype (Id);
2973 
2974                if Has_Access_Constraint (Id)
2975                  and then No (Expression (Decl))
2976                then
2977                   if Has_Non_Null_Base_Init_Proc (Typ) then
2978                      Append_List_To (Stmts,
2979                        Build_Initialization_Call (Comp_Loc,
2980                          Make_Selected_Component (Comp_Loc,
2981                            Prefix        =>
2982                              Make_Identifier (Comp_Loc, Name_uInit),
2983                            Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
2984                          Typ,
2985                          In_Init_Proc => True,
2986                          Enclos_Type  => Rec_Type,
2987                          Discr_Map    => Discr_Map));
2988 
2989                      Clean_Task_Names (Typ, Proc_Id);
2990 
2991                      --  Preserve initialization state in the current counter
2992 
2993                      if Needs_Finalization (Typ) then
2994                         if No (Counter_Id) then
2995                            Make_Counter (Comp_Loc);
2996                         end if;
2997 
2998                         Increment_Counter (Comp_Loc);
2999                      end if;
3000 
3001                   elsif Component_Needs_Simple_Initialization (Typ) then
3002                      Append_List_To (Stmts,
3003                        Build_Assignment
3004                          (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
3005                   end if;
3006                end if;
3007 
3008                Next_Non_Pragma (Decl);
3009             end loop;
3010          end if;
3011 
3012          --  Process the variant part
3013 
3014          if Present (Variant_Part (Comp_List)) then
3015             declare
3016                Variant_Alts : constant List_Id := New_List;
3017                Var_Loc      : Source_Ptr;
3018                Variant      : Node_Id;
3019 
3020             begin
3021                Variant :=
3022                  First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3023                while Present (Variant) loop
3024                   Var_Loc := Sloc (Variant);
3025                   Append_To (Variant_Alts,
3026                     Make_Case_Statement_Alternative (Var_Loc,
3027                       Discrete_Choices =>
3028                         New_Copy_List (Discrete_Choices (Variant)),
3029                       Statements =>
3030                         Build_Init_Statements (Component_List (Variant))));
3031                   Next_Non_Pragma (Variant);
3032                end loop;
3033 
3034                --  The expression of the case statement which is a reference
3035                --  to one of the discriminants is replaced by the appropriate
3036                --  formal parameter of the initialization procedure.
3037 
3038                Append_To (Stmts,
3039                  Make_Case_Statement (Var_Loc,
3040                    Expression =>
3041                      New_Occurrence_Of (Discriminal (
3042                        Entity (Name (Variant_Part (Comp_List)))), Var_Loc),
3043                    Alternatives => Variant_Alts));
3044             end;
3045          end if;
3046 
3047          --  If no initializations when generated for component declarations
3048          --  corresponding to this Stmts, append a null statement to Stmts to
3049          --  to make it a valid Ada tree.
3050 
3051          if Is_Empty_List (Stmts) then
3052             Append (Make_Null_Statement (Loc), Stmts);
3053          end if;
3054 
3055          return Stmts;
3056 
3057       exception
3058          when RE_Not_Available =>
3059             return Empty_List;
3060       end Build_Init_Statements;
3061 
3062       -------------------------
3063       -- Build_Record_Checks --
3064       -------------------------
3065 
3066       procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
3067          Subtype_Mark_Id : Entity_Id;
3068 
3069          procedure Constrain_Array
3070            (SI         : Node_Id;
3071             Check_List : List_Id);
3072          --  Apply a list of index constraints to an unconstrained array type.
3073          --  The first parameter is the entity for the resulting subtype.
3074          --  Check_List is a list to which the check actions are appended.
3075 
3076          ---------------------
3077          -- Constrain_Array --
3078          ---------------------
3079 
3080          procedure Constrain_Array
3081            (SI         : Node_Id;
3082             Check_List : List_Id)
3083          is
3084             C                     : constant Node_Id := Constraint (SI);
3085             Number_Of_Constraints : Nat := 0;
3086             Index                 : Node_Id;
3087             S, T                  : Entity_Id;
3088 
3089             procedure Constrain_Index
3090               (Index      : Node_Id;
3091                S          : Node_Id;
3092                Check_List : List_Id);
3093             --  Process an index constraint in a constrained array declaration.
3094             --  The constraint can be either a subtype name or a range with or
3095             --  without an explicit subtype mark. Index is the corresponding
3096             --  index of the unconstrained array. S is the range expression.
3097             --  Check_List is a list to which the check actions are appended.
3098 
3099             ---------------------
3100             -- Constrain_Index --
3101             ---------------------
3102 
3103             procedure Constrain_Index
3104               (Index        : Node_Id;
3105                S            : Node_Id;
3106                Check_List   : List_Id)
3107             is
3108                T : constant Entity_Id := Etype (Index);
3109 
3110             begin
3111                if Nkind (S) = N_Range then
3112                   Process_Range_Expr_In_Decl (S, T, Check_List => Check_List);
3113                end if;
3114             end Constrain_Index;
3115 
3116          --  Start of processing for Constrain_Array
3117 
3118          begin
3119             T := Entity (Subtype_Mark (SI));
3120 
3121             if Is_Access_Type (T) then
3122                T := Designated_Type (T);
3123             end if;
3124 
3125             S := First (Constraints (C));
3126             while Present (S) loop
3127                Number_Of_Constraints := Number_Of_Constraints + 1;
3128                Next (S);
3129             end loop;
3130 
3131             --  In either case, the index constraint must provide a discrete
3132             --  range for each index of the array type and the type of each
3133             --  discrete range must be the same as that of the corresponding
3134             --  index. (RM 3.6.1)
3135 
3136             S := First (Constraints (C));
3137             Index := First_Index (T);
3138             Analyze (Index);
3139 
3140             --  Apply constraints to each index type
3141 
3142             for J in 1 .. Number_Of_Constraints loop
3143                Constrain_Index (Index, S, Check_List);
3144                Next (Index);
3145                Next (S);
3146             end loop;
3147          end Constrain_Array;
3148 
3149       --  Start of processing for Build_Record_Checks
3150 
3151       begin
3152          if Nkind (S) = N_Subtype_Indication then
3153             Find_Type (Subtype_Mark (S));
3154             Subtype_Mark_Id := Entity (Subtype_Mark (S));
3155 
3156             --  Remaining processing depends on type
3157 
3158             case Ekind (Subtype_Mark_Id) is
3159 
3160                when Array_Kind =>
3161                   Constrain_Array (S, Check_List);
3162 
3163                when others =>
3164                   null;
3165             end case;
3166          end if;
3167       end Build_Record_Checks;
3168 
3169       -------------------------------------------
3170       -- Component_Needs_Simple_Initialization --
3171       -------------------------------------------
3172 
3173       function Component_Needs_Simple_Initialization
3174         (T : Entity_Id) return Boolean
3175       is
3176       begin
3177          return
3178            Needs_Simple_Initialization (T)
3179              and then not Is_RTE (T, RE_Tag)
3180 
3181                --  Ada 2005 (AI-251): Check also the tag of abstract interfaces
3182 
3183              and then not Is_RTE (T, RE_Interface_Tag);
3184       end Component_Needs_Simple_Initialization;
3185 
3186       --------------------------------------
3187       -- Parent_Subtype_Renaming_Discrims --
3188       --------------------------------------
3189 
3190       function Parent_Subtype_Renaming_Discrims return Boolean is
3191          De : Entity_Id;
3192          Dp : Entity_Id;
3193 
3194       begin
3195          if Base_Type (Rec_Ent) /= Rec_Ent then
3196             return False;
3197          end if;
3198 
3199          if Etype (Rec_Ent) = Rec_Ent
3200            or else not Has_Discriminants (Rec_Ent)
3201            or else Is_Constrained (Rec_Ent)
3202            or else Is_Tagged_Type (Rec_Ent)
3203          then
3204             return False;
3205          end if;
3206 
3207          --  If there are no explicit stored discriminants we have inherited
3208          --  the root type discriminants so far, so no renamings occurred.
3209 
3210          if First_Discriminant (Rec_Ent) =
3211               First_Stored_Discriminant (Rec_Ent)
3212          then
3213             return False;
3214          end if;
3215 
3216          --  Check if we have done some trivial renaming of the parent
3217          --  discriminants, i.e. something like
3218          --
3219          --    type DT (X1, X2: int) is new PT (X1, X2);
3220 
3221          De := First_Discriminant (Rec_Ent);
3222          Dp := First_Discriminant (Etype (Rec_Ent));
3223          while Present (De) loop
3224             pragma Assert (Present (Dp));
3225 
3226             if Corresponding_Discriminant (De) /= Dp then
3227                return True;
3228             end if;
3229 
3230             Next_Discriminant (De);
3231             Next_Discriminant (Dp);
3232          end loop;
3233 
3234          return Present (Dp);
3235       end Parent_Subtype_Renaming_Discrims;
3236 
3237       ------------------------
3238       -- Requires_Init_Proc --
3239       ------------------------
3240 
3241       function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
3242          Comp_Decl : Node_Id;
3243          Id        : Entity_Id;
3244          Typ       : Entity_Id;
3245 
3246       begin
3247          --  Definitely do not need one if specifically suppressed
3248 
3249          if Initialization_Suppressed (Rec_Id) then
3250             return False;
3251          end if;
3252 
3253          --  If it is a type derived from a type with unknown discriminants,
3254          --  we cannot build an initialization procedure for it.
3255 
3256          if Has_Unknown_Discriminants (Rec_Id)
3257            or else Has_Unknown_Discriminants (Etype (Rec_Id))
3258          then
3259             return False;
3260          end if;
3261 
3262          --  Otherwise we need to generate an initialization procedure if
3263          --  Is_CPP_Class is False and at least one of the following applies:
3264 
3265          --  1. Discriminants are present, since they need to be initialized
3266          --     with the appropriate discriminant constraint expressions.
3267          --     However, the discriminant of an unchecked union does not
3268          --     count, since the discriminant is not present.
3269 
3270          --  2. The type is a tagged type, since the implicit Tag component
3271          --     needs to be initialized with a pointer to the dispatch table.
3272 
3273          --  3. The type contains tasks
3274 
3275          --  4. One or more components has an initial value
3276 
3277          --  5. One or more components is for a type which itself requires
3278          --     an initialization procedure.
3279 
3280          --  6. One or more components is a type that requires simple
3281          --     initialization (see Needs_Simple_Initialization), except
3282          --     that types Tag and Interface_Tag are excluded, since fields
3283          --     of these types are initialized by other means.
3284 
3285          --  7. The type is the record type built for a task type (since at
3286          --     the very least, Create_Task must be called)
3287 
3288          --  8. The type is the record type built for a protected type (since
3289          --     at least Initialize_Protection must be called)
3290 
3291          --  9. The type is marked as a public entity. The reason we add this
3292          --     case (even if none of the above apply) is to properly handle
3293          --     Initialize_Scalars. If a package is compiled without an IS
3294          --     pragma, and the client is compiled with an IS pragma, then
3295          --     the client will think an initialization procedure is present
3296          --     and call it, when in fact no such procedure is required, but
3297          --     since the call is generated, there had better be a routine
3298          --     at the other end of the call, even if it does nothing).
3299 
3300          --  Note: the reason we exclude the CPP_Class case is because in this
3301          --  case the initialization is performed by the C++ constructors, and
3302          --  the IP is built by Set_CPP_Constructors.
3303 
3304          if Is_CPP_Class (Rec_Id) then
3305             return False;
3306 
3307          elsif Is_Interface (Rec_Id) then
3308             return False;
3309 
3310          elsif (Has_Discriminants (Rec_Id)
3311                  and then not Is_Unchecked_Union (Rec_Id))
3312            or else Is_Tagged_Type (Rec_Id)
3313            or else Is_Concurrent_Record_Type (Rec_Id)
3314            or else Has_Task (Rec_Id)
3315          then
3316             return True;
3317          end if;
3318 
3319          Id := First_Component (Rec_Id);
3320          while Present (Id) loop
3321             Comp_Decl := Parent (Id);
3322             Typ := Etype (Id);
3323 
3324             if Present (Expression (Comp_Decl))
3325               or else Has_Non_Null_Base_Init_Proc (Typ)
3326               or else Component_Needs_Simple_Initialization (Typ)
3327             then
3328                return True;
3329             end if;
3330 
3331             Next_Component (Id);
3332          end loop;
3333 
3334          --  As explained above, a record initialization procedure is needed
3335          --  for public types in case Initialize_Scalars applies to a client.
3336          --  However, such a procedure is not needed in the case where either
3337          --  of restrictions No_Initialize_Scalars or No_Default_Initialization
3338          --  applies. No_Initialize_Scalars excludes the possibility of using
3339          --  Initialize_Scalars in any partition, and No_Default_Initialization
3340          --  implies that no initialization should ever be done for objects of
3341          --  the type, so is incompatible with Initialize_Scalars.
3342 
3343          if not Restriction_Active (No_Initialize_Scalars)
3344            and then not Restriction_Active (No_Default_Initialization)
3345            and then Is_Public (Rec_Id)
3346          then
3347             return True;
3348          end if;
3349 
3350          return False;
3351       end Requires_Init_Proc;
3352 
3353    --  Start of processing for Build_Record_Init_Proc
3354 
3355    begin
3356       Rec_Type := Defining_Identifier (N);
3357 
3358       --  This may be full declaration of a private type, in which case
3359       --  the visible entity is a record, and the private entity has been
3360       --  exchanged with it in the private part of the current package.
3361       --  The initialization procedure is built for the record type, which
3362       --  is retrievable from the private entity.
3363 
3364       if Is_Incomplete_Or_Private_Type (Rec_Type) then
3365          Rec_Type := Underlying_Type (Rec_Type);
3366       end if;
3367 
3368       --  If we have a variant record with restriction No_Implicit_Conditionals
3369       --  in effect, then we skip building the procedure. This is safe because
3370       --  if we can see the restriction, so can any caller, calls to initialize
3371       --  such records are not allowed for variant records if this restriction
3372       --  is active.
3373 
3374       if Has_Variant_Part (Rec_Type)
3375         and then Restriction_Active (No_Implicit_Conditionals)
3376       then
3377          return;
3378       end if;
3379 
3380       --  If there are discriminants, build the discriminant map to replace
3381       --  discriminants by their discriminals in complex bound expressions.
3382       --  These only arise for the corresponding records of synchronized types.
3383 
3384       if Is_Concurrent_Record_Type (Rec_Type)
3385         and then Has_Discriminants (Rec_Type)
3386       then
3387          declare
3388             Disc : Entity_Id;
3389          begin
3390             Disc := First_Discriminant (Rec_Type);
3391             while Present (Disc) loop
3392                Append_Elmt (Disc, Discr_Map);
3393                Append_Elmt (Discriminal (Disc), Discr_Map);
3394                Next_Discriminant (Disc);
3395             end loop;
3396          end;
3397       end if;
3398 
3399       --  Derived types that have no type extension can use the initialization
3400       --  procedure of their parent and do not need a procedure of their own.
3401       --  This is only correct if there are no representation clauses for the
3402       --  type or its parent, and if the parent has in fact been frozen so
3403       --  that its initialization procedure exists.
3404 
3405       if Is_Derived_Type (Rec_Type)
3406         and then not Is_Tagged_Type (Rec_Type)
3407         and then not Is_Unchecked_Union (Rec_Type)
3408         and then not Has_New_Non_Standard_Rep (Rec_Type)
3409         and then not Parent_Subtype_Renaming_Discrims
3410         and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
3411       then
3412          Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
3413 
3414       --  Otherwise if we need an initialization procedure, then build one,
3415       --  mark it as public and inlinable and as having a completion.
3416 
3417       elsif Requires_Init_Proc (Rec_Type)
3418         or else Is_Unchecked_Union (Rec_Type)
3419       then
3420          Proc_Id :=
3421            Make_Defining_Identifier (Loc,
3422              Chars => Make_Init_Proc_Name (Rec_Type));
3423 
3424          --  If No_Default_Initialization restriction is active, then we don't
3425          --  want to build an init_proc, but we need to mark that an init_proc
3426          --  would be needed if this restriction was not active (so that we can
3427          --  detect attempts to call it), so set a dummy init_proc in place.
3428 
3429          if Restriction_Active (No_Default_Initialization) then
3430             Set_Init_Proc (Rec_Type, Proc_Id);
3431             return;
3432          end if;
3433 
3434          Build_Offset_To_Top_Functions;
3435          Build_CPP_Init_Procedure;
3436          Build_Init_Procedure;
3437 
3438          Set_Is_Public      (Proc_Id, Is_Public (Rec_Ent));
3439          Set_Is_Internal    (Proc_Id);
3440          Set_Has_Completion (Proc_Id);
3441 
3442          if not Debug_Generated_Code then
3443             Set_Debug_Info_Off (Proc_Id);
3444          end if;
3445 
3446          Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type));
3447 
3448          --  Do not build an aggregate if Modify_Tree_For_C, this isn't
3449          --  needed and may generate early references to non frozen types
3450          --  since we expand aggregate much more systematically.
3451 
3452          if Modify_Tree_For_C then
3453             return;
3454          end if;
3455 
3456          declare
3457             Agg : constant Node_Id :=
3458                     Build_Equivalent_Record_Aggregate (Rec_Type);
3459 
3460             procedure Collect_Itypes (Comp : Node_Id);
3461             --  Generate references to itypes in the aggregate, because
3462             --  the first use of the aggregate may be in a nested scope.
3463 
3464             --------------------
3465             -- Collect_Itypes --
3466             --------------------
3467 
3468             procedure Collect_Itypes (Comp : Node_Id) is
3469                Ref      : Node_Id;
3470                Sub_Aggr : Node_Id;
3471                Typ      : constant Entity_Id := Etype (Comp);
3472 
3473             begin
3474                if Is_Array_Type (Typ) and then Is_Itype (Typ) then
3475                   Ref := Make_Itype_Reference (Loc);
3476                   Set_Itype (Ref, Typ);
3477                   Append_Freeze_Action (Rec_Type, Ref);
3478 
3479                   Ref := Make_Itype_Reference (Loc);
3480                   Set_Itype (Ref, Etype (First_Index (Typ)));
3481                   Append_Freeze_Action (Rec_Type, Ref);
3482 
3483                   --  Recurse on nested arrays
3484 
3485                   Sub_Aggr := First (Expressions (Comp));
3486                   while Present (Sub_Aggr) loop
3487                      Collect_Itypes (Sub_Aggr);
3488                      Next (Sub_Aggr);
3489                   end loop;
3490                end if;
3491             end Collect_Itypes;
3492 
3493          begin
3494             --  If there is a static initialization aggregate for the type,
3495             --  generate itype references for the types of its (sub)components,
3496             --  to prevent out-of-scope errors in the resulting tree.
3497             --  The aggregate may have been rewritten as a Raise node, in which
3498             --  case there are no relevant itypes.
3499 
3500             if Present (Agg) and then Nkind (Agg) = N_Aggregate then
3501                Set_Static_Initialization (Proc_Id, Agg);
3502 
3503                declare
3504                   Comp  : Node_Id;
3505                begin
3506                   Comp := First (Component_Associations (Agg));
3507                   while Present (Comp) loop
3508                      Collect_Itypes (Expression (Comp));
3509                      Next (Comp);
3510                   end loop;
3511                end;
3512             end if;
3513          end;
3514       end if;
3515    end Build_Record_Init_Proc;
3516 
3517    ----------------------------
3518    -- Build_Slice_Assignment --
3519    ----------------------------
3520 
3521    --  Generates the following subprogram:
3522 
3523    --    procedure Assign
3524    --     (Source,  Target    : Array_Type,
3525    --      Left_Lo, Left_Hi   : Index;
3526    --      Right_Lo, Right_Hi : Index;
3527    --      Rev                : Boolean)
3528    --    is
3529    --       Li1 : Index;
3530    --       Ri1 : Index;
3531 
3532    --    begin
3533 
3534    --       if Left_Hi < Left_Lo then
3535    --          return;
3536    --       end if;
3537 
3538    --       if Rev then
3539    --          Li1 := Left_Hi;
3540    --          Ri1 := Right_Hi;
3541    --       else
3542    --          Li1 := Left_Lo;
3543    --          Ri1 := Right_Lo;
3544    --       end if;
3545 
3546    --       loop
3547    --          Target (Li1) := Source (Ri1);
3548 
3549    --          if Rev then
3550    --             exit when Li1 = Left_Lo;
3551    --             Li1 := Index'pred (Li1);
3552    --             Ri1 := Index'pred (Ri1);
3553    --          else
3554    --             exit when Li1 = Left_Hi;
3555    --             Li1 := Index'succ (Li1);
3556    --             Ri1 := Index'succ (Ri1);
3557    --          end if;
3558    --       end loop;
3559    --    end Assign;
3560 
3561    procedure Build_Slice_Assignment (Typ : Entity_Id) is
3562       Loc   : constant Source_Ptr := Sloc (Typ);
3563       Index : constant Entity_Id  := Base_Type (Etype (First_Index (Typ)));
3564 
3565       Larray    : constant Entity_Id := Make_Temporary (Loc, 'A');
3566       Rarray    : constant Entity_Id := Make_Temporary (Loc, 'R');
3567       Left_Lo   : constant Entity_Id := Make_Temporary (Loc, 'L');
3568       Left_Hi   : constant Entity_Id := Make_Temporary (Loc, 'L');
3569       Right_Lo  : constant Entity_Id := Make_Temporary (Loc, 'R');
3570       Right_Hi  : constant Entity_Id := Make_Temporary (Loc, 'R');
3571       Rev       : constant Entity_Id := Make_Temporary (Loc, 'D');
3572       --  Formal parameters of procedure
3573 
3574       Proc_Name : constant Entity_Id :=
3575                     Make_Defining_Identifier (Loc,
3576                       Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
3577 
3578       Lnn : constant Entity_Id := Make_Temporary (Loc, 'L');
3579       Rnn : constant Entity_Id := Make_Temporary (Loc, 'R');
3580       --  Subscripts for left and right sides
3581 
3582       Decls : List_Id;
3583       Loops : Node_Id;
3584       Stats : List_Id;
3585 
3586    begin
3587       --  Build declarations for indexes
3588 
3589       Decls := New_List;
3590 
3591       Append_To (Decls,
3592          Make_Object_Declaration (Loc,
3593            Defining_Identifier => Lnn,
3594            Object_Definition  =>
3595              New_Occurrence_Of (Index, Loc)));
3596 
3597       Append_To (Decls,
3598         Make_Object_Declaration (Loc,
3599           Defining_Identifier => Rnn,
3600           Object_Definition  =>
3601             New_Occurrence_Of (Index, Loc)));
3602 
3603       Stats := New_List;
3604 
3605       --  Build test for empty slice case
3606 
3607       Append_To (Stats,
3608         Make_If_Statement (Loc,
3609           Condition =>
3610              Make_Op_Lt (Loc,
3611                Left_Opnd  => New_Occurrence_Of (Left_Hi, Loc),
3612                Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
3613           Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
3614 
3615       --  Build initializations for indexes
3616 
3617       declare
3618          F_Init : constant List_Id := New_List;
3619          B_Init : constant List_Id := New_List;
3620 
3621       begin
3622          Append_To (F_Init,
3623            Make_Assignment_Statement (Loc,
3624              Name => New_Occurrence_Of (Lnn, Loc),
3625              Expression => New_Occurrence_Of (Left_Lo, Loc)));
3626 
3627          Append_To (F_Init,
3628            Make_Assignment_Statement (Loc,
3629              Name => New_Occurrence_Of (Rnn, Loc),
3630              Expression => New_Occurrence_Of (Right_Lo, Loc)));
3631 
3632          Append_To (B_Init,
3633            Make_Assignment_Statement (Loc,
3634              Name => New_Occurrence_Of (Lnn, Loc),
3635              Expression => New_Occurrence_Of (Left_Hi, Loc)));
3636 
3637          Append_To (B_Init,
3638            Make_Assignment_Statement (Loc,
3639              Name => New_Occurrence_Of (Rnn, Loc),
3640              Expression => New_Occurrence_Of (Right_Hi, Loc)));
3641 
3642          Append_To (Stats,
3643            Make_If_Statement (Loc,
3644              Condition => New_Occurrence_Of (Rev, Loc),
3645              Then_Statements => B_Init,
3646              Else_Statements => F_Init));
3647       end;
3648 
3649       --  Now construct the assignment statement
3650 
3651       Loops :=
3652         Make_Loop_Statement (Loc,
3653           Statements => New_List (
3654             Make_Assignment_Statement (Loc,
3655               Name =>
3656                 Make_Indexed_Component (Loc,
3657                   Prefix => New_Occurrence_Of (Larray, Loc),
3658                   Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
3659               Expression =>
3660                 Make_Indexed_Component (Loc,
3661                   Prefix => New_Occurrence_Of (Rarray, Loc),
3662                   Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
3663           End_Label  => Empty);
3664 
3665       --  Build the exit condition and increment/decrement statements
3666 
3667       declare
3668          F_Ass : constant List_Id := New_List;
3669          B_Ass : constant List_Id := New_List;
3670 
3671       begin
3672          Append_To (F_Ass,
3673            Make_Exit_Statement (Loc,
3674              Condition =>
3675                Make_Op_Eq (Loc,
3676                  Left_Opnd  => New_Occurrence_Of (Lnn, Loc),
3677                  Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
3678 
3679          Append_To (F_Ass,
3680            Make_Assignment_Statement (Loc,
3681              Name => New_Occurrence_Of (Lnn, Loc),
3682              Expression =>
3683                Make_Attribute_Reference (Loc,
3684                  Prefix =>
3685                    New_Occurrence_Of (Index, Loc),
3686                  Attribute_Name => Name_Succ,
3687                  Expressions => New_List (
3688                    New_Occurrence_Of (Lnn, Loc)))));
3689 
3690          Append_To (F_Ass,
3691            Make_Assignment_Statement (Loc,
3692              Name => New_Occurrence_Of (Rnn, Loc),
3693              Expression =>
3694                Make_Attribute_Reference (Loc,
3695                  Prefix =>
3696                    New_Occurrence_Of (Index, Loc),
3697                  Attribute_Name => Name_Succ,
3698                  Expressions => New_List (
3699                    New_Occurrence_Of (Rnn, Loc)))));
3700 
3701          Append_To (B_Ass,
3702            Make_Exit_Statement (Loc,
3703              Condition =>
3704                Make_Op_Eq (Loc,
3705                  Left_Opnd  => New_Occurrence_Of (Lnn, Loc),
3706                  Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
3707 
3708          Append_To (B_Ass,
3709            Make_Assignment_Statement (Loc,
3710              Name => New_Occurrence_Of (Lnn, Loc),
3711              Expression =>
3712                Make_Attribute_Reference (Loc,
3713                  Prefix =>
3714                    New_Occurrence_Of (Index, Loc),
3715                  Attribute_Name => Name_Pred,
3716                    Expressions => New_List (
3717                      New_Occurrence_Of (Lnn, Loc)))));
3718 
3719          Append_To (B_Ass,
3720            Make_Assignment_Statement (Loc,
3721              Name => New_Occurrence_Of (Rnn, Loc),
3722              Expression =>
3723                Make_Attribute_Reference (Loc,
3724                  Prefix =>
3725                    New_Occurrence_Of (Index, Loc),
3726                  Attribute_Name => Name_Pred,
3727                  Expressions => New_List (
3728                    New_Occurrence_Of (Rnn, Loc)))));
3729 
3730          Append_To (Statements (Loops),
3731            Make_If_Statement (Loc,
3732              Condition => New_Occurrence_Of (Rev, Loc),
3733              Then_Statements => B_Ass,
3734              Else_Statements => F_Ass));
3735       end;
3736 
3737       Append_To (Stats, Loops);
3738 
3739       declare
3740          Spec    : Node_Id;
3741          Formals : List_Id := New_List;
3742 
3743       begin
3744          Formals := New_List (
3745            Make_Parameter_Specification (Loc,
3746              Defining_Identifier => Larray,
3747              Out_Present => True,
3748              Parameter_Type =>
3749                New_Occurrence_Of (Base_Type (Typ), Loc)),
3750 
3751            Make_Parameter_Specification (Loc,
3752              Defining_Identifier => Rarray,
3753              Parameter_Type =>
3754                New_Occurrence_Of (Base_Type (Typ), Loc)),
3755 
3756            Make_Parameter_Specification (Loc,
3757              Defining_Identifier => Left_Lo,
3758              Parameter_Type =>
3759                New_Occurrence_Of (Index, Loc)),
3760 
3761            Make_Parameter_Specification (Loc,
3762              Defining_Identifier => Left_Hi,
3763              Parameter_Type =>
3764                New_Occurrence_Of (Index, Loc)),
3765 
3766            Make_Parameter_Specification (Loc,
3767              Defining_Identifier => Right_Lo,
3768              Parameter_Type =>
3769                New_Occurrence_Of (Index, Loc)),
3770 
3771            Make_Parameter_Specification (Loc,
3772              Defining_Identifier => Right_Hi,
3773              Parameter_Type =>
3774                New_Occurrence_Of (Index, Loc)));
3775 
3776          Append_To (Formals,
3777            Make_Parameter_Specification (Loc,
3778              Defining_Identifier => Rev,
3779              Parameter_Type =>
3780                New_Occurrence_Of (Standard_Boolean, Loc)));
3781 
3782          Spec :=
3783            Make_Procedure_Specification (Loc,
3784              Defining_Unit_Name       => Proc_Name,
3785              Parameter_Specifications => Formals);
3786 
3787          Discard_Node (
3788            Make_Subprogram_Body (Loc,
3789              Specification              => Spec,
3790              Declarations               => Decls,
3791              Handled_Statement_Sequence =>
3792                Make_Handled_Sequence_Of_Statements (Loc,
3793                  Statements => Stats)));
3794       end;
3795 
3796       Set_TSS (Typ, Proc_Name);
3797       Set_Is_Pure (Proc_Name);
3798    end Build_Slice_Assignment;
3799 
3800    -----------------------------
3801    -- Build_Untagged_Equality --
3802    -----------------------------
3803 
3804    procedure Build_Untagged_Equality (Typ : Entity_Id) is
3805       Build_Eq : Boolean;
3806       Comp     : Entity_Id;
3807       Decl     : Node_Id;
3808       Op       : Entity_Id;
3809       Prim     : Elmt_Id;
3810       Eq_Op    : Entity_Id;
3811 
3812       function User_Defined_Eq (T : Entity_Id) return Entity_Id;
3813       --  Check whether the type T has a user-defined primitive equality. If so
3814       --  return it, else return Empty. If true for a component of Typ, we have
3815       --  to build the primitive equality for it.
3816 
3817       ---------------------
3818       -- User_Defined_Eq --
3819       ---------------------
3820 
3821       function User_Defined_Eq (T : Entity_Id) return Entity_Id is
3822          Prim : Elmt_Id;
3823          Op   : Entity_Id;
3824 
3825       begin
3826          Op := TSS (T, TSS_Composite_Equality);
3827 
3828          if Present (Op) then
3829             return Op;
3830          end if;
3831 
3832          Prim := First_Elmt (Collect_Primitive_Operations (T));
3833          while Present (Prim) loop
3834             Op := Node (Prim);
3835 
3836             if Chars (Op) = Name_Op_Eq
3837               and then Etype (Op) = Standard_Boolean
3838               and then Etype (First_Formal (Op)) = T
3839               and then Etype (Next_Formal (First_Formal (Op))) = T
3840             then
3841                return Op;
3842             end if;
3843 
3844             Next_Elmt (Prim);
3845          end loop;
3846 
3847          return Empty;
3848       end User_Defined_Eq;
3849 
3850    --  Start of processing for Build_Untagged_Equality
3851 
3852    begin
3853       --  If a record component has a primitive equality operation, we must
3854       --  build the corresponding one for the current type.
3855 
3856       Build_Eq := False;
3857       Comp := First_Component (Typ);
3858       while Present (Comp) loop
3859          if Is_Record_Type (Etype (Comp))
3860            and then Present (User_Defined_Eq (Etype (Comp)))
3861          then
3862             Build_Eq := True;
3863          end if;
3864 
3865          Next_Component (Comp);
3866       end loop;
3867 
3868       --  If there is a user-defined equality for the type, we do not create
3869       --  the implicit one.
3870 
3871       Prim := First_Elmt (Collect_Primitive_Operations (Typ));
3872       Eq_Op := Empty;
3873       while Present (Prim) loop
3874          if Chars (Node (Prim)) = Name_Op_Eq
3875            and then Comes_From_Source (Node (Prim))
3876 
3877          --  Don't we also need to check formal types and return type as in
3878          --  User_Defined_Eq above???
3879 
3880          then
3881             Eq_Op := Node (Prim);
3882             Build_Eq := False;
3883             exit;
3884          end if;
3885 
3886          Next_Elmt (Prim);
3887       end loop;
3888 
3889       --  If the type is derived, inherit the operation, if present, from the
3890       --  parent type. It may have been declared after the type derivation. If
3891       --  the parent type itself is derived, it may have inherited an operation
3892       --  that has itself been overridden, so update its alias and related
3893       --  flags. Ditto for inequality.
3894 
3895       if No (Eq_Op) and then Is_Derived_Type (Typ) then
3896          Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
3897          while Present (Prim) loop
3898             if Chars (Node (Prim)) = Name_Op_Eq then
3899                Copy_TSS (Node (Prim), Typ);
3900                Build_Eq := False;
3901 
3902                declare
3903                   Op    : constant Entity_Id := User_Defined_Eq (Typ);
3904                   Eq_Op : constant Entity_Id := Node (Prim);
3905                   NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
3906 
3907                begin
3908                   if Present (Op) then
3909                      Set_Alias (Op, Eq_Op);
3910                      Set_Is_Abstract_Subprogram
3911                        (Op, Is_Abstract_Subprogram (Eq_Op));
3912 
3913                      if Chars (Next_Entity (Op)) = Name_Op_Ne then
3914                         Set_Is_Abstract_Subprogram
3915                           (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
3916                      end if;
3917                   end if;
3918                end;
3919 
3920                exit;
3921             end if;
3922 
3923             Next_Elmt (Prim);
3924          end loop;
3925       end if;
3926 
3927       --  If not inherited and not user-defined, build body as for a type with
3928       --  tagged components.
3929 
3930       if Build_Eq then
3931          Decl :=
3932            Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
3933          Op := Defining_Entity (Decl);
3934          Set_TSS (Typ, Op);
3935          Set_Is_Pure (Op);
3936 
3937          if Is_Library_Level_Entity (Typ) then
3938             Set_Is_Public (Op);
3939          end if;
3940       end if;
3941    end Build_Untagged_Equality;
3942 
3943    -----------------------------------
3944    -- Build_Variant_Record_Equality --
3945    -----------------------------------
3946 
3947    --  Generates:
3948 
3949    --    function _Equality (X, Y : T) return Boolean is
3950    --    begin
3951    --       --  Compare discriminants
3952 
3953    --       if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
3954    --          return False;
3955    --       end if;
3956 
3957    --       --  Compare components
3958 
3959    --       if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
3960    --          return False;
3961    --       end if;
3962 
3963    --       --  Compare variant part
3964 
3965    --       case X.D1 is
3966    --          when V1 =>
3967    --             if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
3968    --                return False;
3969    --             end if;
3970    --          ...
3971    --          when Vn =>
3972    --             if X.Cn /= Y.Cn or else ... then
3973    --                return False;
3974    --             end if;
3975    --       end case;
3976 
3977    --       return True;
3978    --    end _Equality;
3979 
3980    procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
3981       Loc : constant Source_Ptr := Sloc (Typ);
3982 
3983       F : constant Entity_Id :=
3984             Make_Defining_Identifier (Loc,
3985               Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
3986 
3987       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
3988       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
3989 
3990       Def    : constant Node_Id := Parent (Typ);
3991       Comps  : constant Node_Id := Component_List (Type_Definition (Def));
3992       Stmts  : constant List_Id := New_List;
3993       Pspecs : constant List_Id := New_List;
3994 
3995    begin
3996       --  If we have a variant record with restriction No_Implicit_Conditionals
3997       --  in effect, then we skip building the procedure. This is safe because
3998       --  if we can see the restriction, so can any caller, calls to equality
3999       --  test routines are not allowed for variant records if this restriction
4000       --  is active.
4001 
4002       if Restriction_Active (No_Implicit_Conditionals) then
4003          return;
4004       end if;
4005 
4006       --  Derived Unchecked_Union types no longer inherit the equality function
4007       --  of their parent.
4008 
4009       if Is_Derived_Type (Typ)
4010         and then not Is_Unchecked_Union (Typ)
4011         and then not Has_New_Non_Standard_Rep (Typ)
4012       then
4013          declare
4014             Parent_Eq : constant Entity_Id :=
4015                           TSS (Root_Type (Typ), TSS_Composite_Equality);
4016          begin
4017             if Present (Parent_Eq) then
4018                Copy_TSS (Parent_Eq, Typ);
4019                return;
4020             end if;
4021          end;
4022       end if;
4023 
4024       Discard_Node (
4025         Make_Subprogram_Body (Loc,
4026           Specification =>
4027             Make_Function_Specification (Loc,
4028               Defining_Unit_Name       => F,
4029               Parameter_Specifications => Pspecs,
4030               Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
4031           Declarations               => New_List,
4032           Handled_Statement_Sequence =>
4033             Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
4034 
4035       Append_To (Pspecs,
4036         Make_Parameter_Specification (Loc,
4037           Defining_Identifier => X,
4038           Parameter_Type      => New_Occurrence_Of (Typ, Loc)));
4039 
4040       Append_To (Pspecs,
4041         Make_Parameter_Specification (Loc,
4042           Defining_Identifier => Y,
4043           Parameter_Type      => New_Occurrence_Of (Typ, Loc)));
4044 
4045       --  Unchecked_Unions require additional machinery to support equality.
4046       --  Two extra parameters (A and B) are added to the equality function
4047       --  parameter list for each discriminant of the type, in order to
4048       --  capture the inferred values of the discriminants in equality calls.
4049       --  The names of the parameters match the names of the corresponding
4050       --  discriminant, with an added suffix.
4051 
4052       if Is_Unchecked_Union (Typ) then
4053          declare
4054             Discr      : Entity_Id;
4055             Discr_Type : Entity_Id;
4056             A, B       : Entity_Id;
4057             New_Discrs : Elist_Id;
4058 
4059          begin
4060             New_Discrs := New_Elmt_List;
4061 
4062             Discr := First_Discriminant (Typ);
4063             while Present (Discr) loop
4064                Discr_Type := Etype (Discr);
4065                A := Make_Defining_Identifier (Loc,
4066                       Chars => New_External_Name (Chars (Discr), 'A'));
4067 
4068                B := Make_Defining_Identifier (Loc,
4069                       Chars => New_External_Name (Chars (Discr), 'B'));
4070 
4071                --  Add new parameters to the parameter list
4072 
4073                Append_To (Pspecs,
4074                  Make_Parameter_Specification (Loc,
4075                    Defining_Identifier => A,
4076                    Parameter_Type      =>
4077                      New_Occurrence_Of (Discr_Type, Loc)));
4078 
4079                Append_To (Pspecs,
4080                  Make_Parameter_Specification (Loc,
4081                    Defining_Identifier => B,
4082                    Parameter_Type      =>
4083                      New_Occurrence_Of (Discr_Type, Loc)));
4084 
4085                Append_Elmt (A, New_Discrs);
4086 
4087                --  Generate the following code to compare each of the inferred
4088                --  discriminants:
4089 
4090                --  if a /= b then
4091                --     return False;
4092                --  end if;
4093 
4094                Append_To (Stmts,
4095                  Make_If_Statement (Loc,
4096                    Condition       =>
4097                      Make_Op_Ne (Loc,
4098                        Left_Opnd  => New_Occurrence_Of (A, Loc),
4099                        Right_Opnd => New_Occurrence_Of (B, Loc)),
4100                    Then_Statements => New_List (
4101                      Make_Simple_Return_Statement (Loc,
4102                        Expression =>
4103                          New_Occurrence_Of (Standard_False, Loc)))));
4104                Next_Discriminant (Discr);
4105             end loop;
4106 
4107             --  Generate component-by-component comparison. Note that we must
4108             --  propagate the inferred discriminants formals to act as
4109             --  the case statement switch. Their value is added when an
4110             --  equality call on unchecked unions is expanded.
4111 
4112             Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs));
4113          end;
4114 
4115       --  Normal case (not unchecked union)
4116 
4117       else
4118          Append_To (Stmts,
4119            Make_Eq_If (Typ, Discriminant_Specifications (Def)));
4120          Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
4121       end if;
4122 
4123       Append_To (Stmts,
4124         Make_Simple_Return_Statement (Loc,
4125           Expression => New_Occurrence_Of (Standard_True, Loc)));
4126 
4127       Set_TSS (Typ, F);
4128       Set_Is_Pure (F);
4129 
4130       if not Debug_Generated_Code then
4131          Set_Debug_Info_Off (F);
4132       end if;
4133    end Build_Variant_Record_Equality;
4134 
4135    -----------------------------
4136    -- Check_Stream_Attributes --
4137    -----------------------------
4138 
4139    procedure Check_Stream_Attributes (Typ : Entity_Id) is
4140       Comp      : Entity_Id;
4141       Par_Read  : constant Boolean :=
4142                     Stream_Attribute_Available (Typ, TSS_Stream_Read)
4143                       and then not Has_Specified_Stream_Read (Typ);
4144       Par_Write : constant Boolean :=
4145                     Stream_Attribute_Available (Typ, TSS_Stream_Write)
4146                       and then not Has_Specified_Stream_Write (Typ);
4147 
4148       procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
4149       --  Check that Comp has a user-specified Nam stream attribute
4150 
4151       ----------------
4152       -- Check_Attr --
4153       ----------------
4154 
4155       procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
4156       begin
4157          if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
4158             Error_Msg_Name_1 := Nam;
4159             Error_Msg_N
4160               ("|component& in limited extension must have% attribute", Comp);
4161          end if;
4162       end Check_Attr;
4163 
4164    --  Start of processing for Check_Stream_Attributes
4165 
4166    begin
4167       if Par_Read or else Par_Write then
4168          Comp := First_Component (Typ);
4169          while Present (Comp) loop
4170             if Comes_From_Source (Comp)
4171               and then Original_Record_Component (Comp) = Comp
4172               and then Is_Limited_Type (Etype (Comp))
4173             then
4174                if Par_Read then
4175                   Check_Attr (Name_Read, TSS_Stream_Read);
4176                end if;
4177 
4178                if Par_Write then
4179                   Check_Attr (Name_Write, TSS_Stream_Write);
4180                end if;
4181             end if;
4182 
4183             Next_Component (Comp);
4184          end loop;
4185       end if;
4186    end Check_Stream_Attributes;
4187 
4188    ----------------------
4189    -- Clean_Task_Names --
4190    ----------------------
4191 
4192    procedure Clean_Task_Names
4193      (Typ     : Entity_Id;
4194       Proc_Id : Entity_Id)
4195    is
4196    begin
4197       if Has_Task (Typ)
4198         and then not Restriction_Active (No_Implicit_Heap_Allocations)
4199         and then not Global_Discard_Names
4200         and then Tagged_Type_Expansion
4201       then
4202          Set_Uses_Sec_Stack (Proc_Id);
4203       end if;
4204    end Clean_Task_Names;
4205 
4206    ------------------------------
4207    -- Expand_Freeze_Array_Type --
4208    ------------------------------
4209 
4210    procedure Expand_Freeze_Array_Type (N : Node_Id) is
4211       Typ      : constant Entity_Id := Entity (N);
4212       Base     : constant Entity_Id := Base_Type (Typ);
4213       Comp_Typ : constant Entity_Id := Component_Type (Typ);
4214 
4215       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4216 
4217    begin
4218       --  Ensure that all freezing activities are properly flagged as Ghost
4219 
4220       Set_Ghost_Mode_From_Entity (Typ);
4221 
4222       if not Is_Bit_Packed_Array (Typ) then
4223 
4224          --  If the component contains tasks, so does the array type. This may
4225          --  not be indicated in the array type because the component may have
4226          --  been a private type at the point of definition. Same if component
4227          --  type is controlled or contains protected objects.
4228 
4229          Propagate_Concurrent_Flags (Base, Comp_Typ);
4230          Set_Has_Controlled_Component
4231            (Base, Has_Controlled_Component (Comp_Typ)
4232                     or else Is_Controlled (Comp_Typ));
4233 
4234          if No (Init_Proc (Base)) then
4235 
4236             --  If this is an anonymous array created for a declaration with
4237             --  an initial value, its init_proc will never be called. The
4238             --  initial value itself may have been expanded into assignments,
4239             --  in which case the object declaration is carries the
4240             --  No_Initialization flag.
4241 
4242             if Is_Itype (Base)
4243               and then Nkind (Associated_Node_For_Itype (Base)) =
4244                                                     N_Object_Declaration
4245               and then
4246                 (Present (Expression (Associated_Node_For_Itype (Base)))
4247                   or else No_Initialization (Associated_Node_For_Itype (Base)))
4248             then
4249                null;
4250 
4251             --  We do not need an init proc for string or wide [wide] string,
4252             --  since the only time these need initialization in normalize or
4253             --  initialize scalars mode, and these types are treated specially
4254             --  and do not need initialization procedures.
4255 
4256             elsif Is_Standard_String_Type (Base) then
4257                null;
4258 
4259             --  Otherwise we have to build an init proc for the subtype
4260 
4261             else
4262                Build_Array_Init_Proc (Base, N);
4263             end if;
4264          end if;
4265 
4266          if Typ = Base and then Has_Controlled_Component (Base) then
4267             Build_Controlling_Procs (Base);
4268 
4269             if not Is_Limited_Type (Comp_Typ)
4270               and then Number_Dimensions (Typ) = 1
4271             then
4272                Build_Slice_Assignment (Typ);
4273             end if;
4274          end if;
4275 
4276       --  For packed case, default initialization, except if the component type
4277       --  is itself a packed structure with an initialization procedure, or
4278       --  initialize/normalize scalars active, and we have a base type, or the
4279       --  type is public, because in that case a client might specify
4280       --  Normalize_Scalars and there better be a public Init_Proc for it.
4281 
4282       elsif (Present (Init_Proc (Component_Type (Base)))
4283               and then No (Base_Init_Proc (Base)))
4284         or else (Init_Or_Norm_Scalars and then Base = Typ)
4285         or else Is_Public (Typ)
4286       then
4287          Build_Array_Init_Proc (Base, N);
4288       end if;
4289 
4290       Ghost_Mode := Save_Ghost_Mode;
4291    end Expand_Freeze_Array_Type;
4292 
4293    -----------------------------------
4294    -- Expand_Freeze_Class_Wide_Type --
4295    -----------------------------------
4296 
4297    procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
4298       function Is_C_Derivation (Typ : Entity_Id) return Boolean;
4299       --  Given a type, determine whether it is derived from a C or C++ root
4300 
4301       ---------------------
4302       -- Is_C_Derivation --
4303       ---------------------
4304 
4305       function Is_C_Derivation (Typ : Entity_Id) return Boolean is
4306          T : Entity_Id;
4307 
4308       begin
4309          T := Typ;
4310          loop
4311             if Is_CPP_Class (T)
4312               or else Convention (T) = Convention_C
4313               or else Convention (T) = Convention_CPP
4314             then
4315                return True;
4316             end if;
4317 
4318             exit when T = Etype (T);
4319 
4320             T := Etype (T);
4321          end loop;
4322 
4323          return False;
4324       end Is_C_Derivation;
4325 
4326       --  Local variables
4327 
4328       Typ  : constant Entity_Id := Entity (N);
4329       Root : constant Entity_Id := Root_Type (Typ);
4330 
4331       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4332 
4333    --  Start of processing for Expand_Freeze_Class_Wide_Type
4334 
4335    begin
4336       --  Certain run-time configurations and targets do not provide support
4337       --  for controlled types.
4338 
4339       if Restriction_Active (No_Finalization) then
4340          return;
4341 
4342       --  Do not create TSS routine Finalize_Address when dispatching calls are
4343       --  disabled since the core of the routine is a dispatching call.
4344 
4345       elsif Restriction_Active (No_Dispatching_Calls) then
4346          return;
4347 
4348       --  Do not create TSS routine Finalize_Address for concurrent class-wide
4349       --  types. Ignore C, C++, CIL and Java types since it is assumed that the
4350       --  non-Ada side will handle their destruction.
4351 
4352       elsif Is_Concurrent_Type (Root)
4353         or else Is_C_Derivation (Root)
4354         or else Convention (Typ) = Convention_CPP
4355       then
4356          return;
4357 
4358       --  Do not create TSS routine Finalize_Address when compiling in CodePeer
4359       --  mode since the routine contains an Unchecked_Conversion.
4360 
4361       elsif CodePeer_Mode then
4362          return;
4363       end if;
4364 
4365       --  Ensure that all freezing activities are properly flagged as Ghost
4366 
4367       Set_Ghost_Mode_From_Entity (Typ);
4368 
4369       --  Create the body of TSS primitive Finalize_Address. This automatically
4370       --  sets the TSS entry for the class-wide type.
4371 
4372       Make_Finalize_Address_Body (Typ);
4373       Ghost_Mode := Save_Ghost_Mode;
4374    end Expand_Freeze_Class_Wide_Type;
4375 
4376    ------------------------------------
4377    -- Expand_Freeze_Enumeration_Type --
4378    ------------------------------------
4379 
4380    procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
4381       Typ : constant Entity_Id  := Entity (N);
4382       Loc : constant Source_Ptr := Sloc (Typ);
4383 
4384       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4385 
4386       Arr           : Entity_Id;
4387       Ent           : Entity_Id;
4388       Fent          : Entity_Id;
4389       Is_Contiguous : Boolean;
4390       Ityp          : Entity_Id;
4391       Last_Repval   : Uint;
4392       Lst           : List_Id;
4393       Num           : Nat;
4394       Pos_Expr      : Node_Id;
4395 
4396       Func : Entity_Id;
4397       pragma Warnings (Off, Func);
4398 
4399    begin
4400       --  Ensure that all freezing activities are properly flagged as Ghost
4401 
4402       Set_Ghost_Mode_From_Entity (Typ);
4403 
4404       --  Various optimizations possible if given representation is contiguous
4405 
4406       Is_Contiguous := True;
4407 
4408       Ent := First_Literal (Typ);
4409       Last_Repval := Enumeration_Rep (Ent);
4410 
4411       Next_Literal (Ent);
4412       while Present (Ent) loop
4413          if Enumeration_Rep (Ent) - Last_Repval /= 1 then
4414             Is_Contiguous := False;
4415             exit;
4416          else
4417             Last_Repval := Enumeration_Rep (Ent);
4418          end if;
4419 
4420          Next_Literal (Ent);
4421       end loop;
4422 
4423       if Is_Contiguous then
4424          Set_Has_Contiguous_Rep (Typ);
4425          Ent := First_Literal (Typ);
4426          Num := 1;
4427          Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent)));
4428 
4429       else
4430          --  Build list of literal references
4431 
4432          Lst := New_List;
4433          Num := 0;
4434 
4435          Ent := First_Literal (Typ);
4436          while Present (Ent) loop
4437             Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
4438             Num := Num + 1;
4439             Next_Literal (Ent);
4440          end loop;
4441       end if;
4442 
4443       --  Now build an array declaration
4444 
4445       --    typA : array (Natural range 0 .. num - 1) of ctype :=
4446       --             (v, v, v, v, v, ....)
4447 
4448       --  where ctype is the corresponding integer type. If the representation
4449       --  is contiguous, we only keep the first literal, which provides the
4450       --  offset for Pos_To_Rep computations.
4451 
4452       Arr :=
4453         Make_Defining_Identifier (Loc,
4454           Chars => New_External_Name (Chars (Typ), 'A'));
4455 
4456       Append_Freeze_Action (Typ,
4457         Make_Object_Declaration (Loc,
4458           Defining_Identifier => Arr,
4459           Constant_Present    => True,
4460 
4461           Object_Definition   =>
4462             Make_Constrained_Array_Definition (Loc,
4463               Discrete_Subtype_Definitions => New_List (
4464                 Make_Subtype_Indication (Loc,
4465                   Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
4466                   Constraint =>
4467                     Make_Range_Constraint (Loc,
4468                       Range_Expression =>
4469                         Make_Range (Loc,
4470                           Low_Bound  =>
4471                             Make_Integer_Literal (Loc, 0),
4472                           High_Bound =>
4473                             Make_Integer_Literal (Loc, Num - 1))))),
4474 
4475               Component_Definition =>
4476                 Make_Component_Definition (Loc,
4477                   Aliased_Present => False,
4478                   Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
4479 
4480           Expression =>
4481             Make_Aggregate (Loc,
4482               Expressions => Lst)));
4483 
4484       Set_Enum_Pos_To_Rep (Typ, Arr);
4485 
4486       --  Now we build the function that converts representation values to
4487       --  position values. This function has the form:
4488 
4489       --    function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
4490       --    begin
4491       --       case ityp!(A) is
4492       --         when enum-lit'Enum_Rep => return posval;
4493       --         when enum-lit'Enum_Rep => return posval;
4494       --         ...
4495       --         when others   =>
4496       --           [raise Constraint_Error when F "invalid data"]
4497       --           return -1;
4498       --       end case;
4499       --    end;
4500 
4501       --  Note: the F parameter determines whether the others case (no valid
4502       --  representation) raises Constraint_Error or returns a unique value
4503       --  of minus one. The latter case is used, e.g. in 'Valid code.
4504 
4505       --  Note: the reason we use Enum_Rep values in the case here is to avoid
4506       --  the code generator making inappropriate assumptions about the range
4507       --  of the values in the case where the value is invalid. ityp is a
4508       --  signed or unsigned integer type of appropriate width.
4509 
4510       --  Note: if exceptions are not supported, then we suppress the raise
4511       --  and return -1 unconditionally (this is an erroneous program in any
4512       --  case and there is no obligation to raise Constraint_Error here). We
4513       --  also do this if pragma Restrictions (No_Exceptions) is active.
4514 
4515       --  Is this right??? What about No_Exception_Propagation???
4516 
4517       --  Representations are signed
4518 
4519       if Enumeration_Rep (First_Literal (Typ)) < 0 then
4520 
4521          --  The underlying type is signed. Reset the Is_Unsigned_Type
4522          --  explicitly, because it might have been inherited from
4523          --  parent type.
4524 
4525          Set_Is_Unsigned_Type (Typ, False);
4526 
4527          if Esize (Typ) <= Standard_Integer_Size then
4528             Ityp := Standard_Integer;
4529          else
4530             Ityp := Universal_Integer;
4531          end if;
4532 
4533       --  Representations are unsigned
4534 
4535       else
4536          if Esize (Typ) <= Standard_Integer_Size then
4537             Ityp := RTE (RE_Unsigned);
4538          else
4539             Ityp := RTE (RE_Long_Long_Unsigned);
4540          end if;
4541       end if;
4542 
4543       --  The body of the function is a case statement. First collect case
4544       --  alternatives, or optimize the contiguous case.
4545 
4546       Lst := New_List;
4547 
4548       --  If representation is contiguous, Pos is computed by subtracting
4549       --  the representation of the first literal.
4550 
4551       if Is_Contiguous then
4552          Ent := First_Literal (Typ);
4553 
4554          if Enumeration_Rep (Ent) = Last_Repval then
4555 
4556             --  Another special case: for a single literal, Pos is zero
4557 
4558             Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
4559 
4560          else
4561             Pos_Expr :=
4562               Convert_To (Standard_Integer,
4563                 Make_Op_Subtract (Loc,
4564                   Left_Opnd  =>
4565                     Unchecked_Convert_To
4566                      (Ityp, Make_Identifier (Loc, Name_uA)),
4567                   Right_Opnd =>
4568                     Make_Integer_Literal (Loc,
4569                       Intval => Enumeration_Rep (First_Literal (Typ)))));
4570          end if;
4571 
4572          Append_To (Lst,
4573            Make_Case_Statement_Alternative (Loc,
4574              Discrete_Choices => New_List (
4575                Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
4576                  Low_Bound =>
4577                    Make_Integer_Literal (Loc,
4578                     Intval =>  Enumeration_Rep (Ent)),
4579                  High_Bound =>
4580                    Make_Integer_Literal (Loc, Intval => Last_Repval))),
4581 
4582              Statements => New_List (
4583                Make_Simple_Return_Statement (Loc,
4584                  Expression => Pos_Expr))));
4585 
4586       else
4587          Ent := First_Literal (Typ);
4588          while Present (Ent) loop
4589             Append_To (Lst,
4590               Make_Case_Statement_Alternative (Loc,
4591                 Discrete_Choices => New_List (
4592                   Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
4593                     Intval => Enumeration_Rep (Ent))),
4594 
4595                 Statements => New_List (
4596                   Make_Simple_Return_Statement (Loc,
4597                     Expression =>
4598                       Make_Integer_Literal (Loc,
4599                         Intval => Enumeration_Pos (Ent))))));
4600 
4601             Next_Literal (Ent);
4602          end loop;
4603       end if;
4604 
4605       --  In normal mode, add the others clause with the test.
4606       --  If Predicates_Ignored is True, validity checks do not apply to
4607       --  the subtype.
4608 
4609       if not No_Exception_Handlers_Set
4610         and then not Predicates_Ignored (Typ)
4611       then
4612          Append_To (Lst,
4613            Make_Case_Statement_Alternative (Loc,
4614              Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4615              Statements       => New_List (
4616                Make_Raise_Constraint_Error (Loc,
4617                  Condition => Make_Identifier (Loc, Name_uF),
4618                  Reason    => CE_Invalid_Data),
4619                Make_Simple_Return_Statement (Loc,
4620                  Expression => Make_Integer_Literal (Loc, -1)))));
4621 
4622       --  If either of the restrictions No_Exceptions_Handlers/Propagation is
4623       --  active then return -1 (we cannot usefully raise Constraint_Error in
4624       --  this case). See description above for further details.
4625 
4626       else
4627          Append_To (Lst,
4628            Make_Case_Statement_Alternative (Loc,
4629              Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4630              Statements       => New_List (
4631                Make_Simple_Return_Statement (Loc,
4632                  Expression => Make_Integer_Literal (Loc, -1)))));
4633       end if;
4634 
4635       --  Now we can build the function body
4636 
4637       Fent :=
4638         Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
4639 
4640       Func :=
4641         Make_Subprogram_Body (Loc,
4642           Specification =>
4643             Make_Function_Specification (Loc,
4644               Defining_Unit_Name       => Fent,
4645               Parameter_Specifications => New_List (
4646                 Make_Parameter_Specification (Loc,
4647                   Defining_Identifier =>
4648                     Make_Defining_Identifier (Loc, Name_uA),
4649                   Parameter_Type => New_Occurrence_Of (Typ, Loc)),
4650                 Make_Parameter_Specification (Loc,
4651                   Defining_Identifier =>
4652                     Make_Defining_Identifier (Loc, Name_uF),
4653                   Parameter_Type =>
4654                     New_Occurrence_Of (Standard_Boolean, Loc))),
4655 
4656               Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
4657 
4658             Declarations => Empty_List,
4659 
4660             Handled_Statement_Sequence =>
4661               Make_Handled_Sequence_Of_Statements (Loc,
4662                 Statements => New_List (
4663                   Make_Case_Statement (Loc,
4664                     Expression =>
4665                       Unchecked_Convert_To
4666                         (Ityp, Make_Identifier (Loc, Name_uA)),
4667                     Alternatives => Lst))));
4668 
4669       Set_TSS (Typ, Fent);
4670 
4671       --  Set Pure flag (it will be reset if the current context is not Pure).
4672       --  We also pretend there was a pragma Pure_Function so that for purposes
4673       --  of optimization and constant-folding, we will consider the function
4674       --  Pure even if we are not in a Pure context).
4675 
4676       Set_Is_Pure (Fent);
4677       Set_Has_Pragma_Pure_Function (Fent);
4678 
4679       --  Unless we are in -gnatD mode, where we are debugging generated code,
4680       --  this is an internal entity for which we don't need debug info.
4681 
4682       if not Debug_Generated_Code then
4683          Set_Debug_Info_Off (Fent);
4684       end if;
4685 
4686       Ghost_Mode := Save_Ghost_Mode;
4687 
4688    exception
4689       when RE_Not_Available =>
4690          Ghost_Mode := Save_Ghost_Mode;
4691          return;
4692    end Expand_Freeze_Enumeration_Type;
4693 
4694    -------------------------------
4695    -- Expand_Freeze_Record_Type --
4696    -------------------------------
4697 
4698    procedure Expand_Freeze_Record_Type (N : Node_Id) is
4699       Typ      : constant Node_Id := Entity (N);
4700       Typ_Decl : constant Node_Id := Parent (Typ);
4701 
4702       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4703 
4704       Comp        : Entity_Id;
4705       Comp_Typ    : Entity_Id;
4706       Predef_List : List_Id;
4707 
4708       Wrapper_Decl_List : List_Id := No_List;
4709       Wrapper_Body_List : List_Id := No_List;
4710 
4711       Renamed_Eq : Node_Id := Empty;
4712       --  Defining unit name for the predefined equality function in the case
4713       --  where the type has a primitive operation that is a renaming of
4714       --  predefined equality (but only if there is also an overriding
4715       --  user-defined equality function). Used to pass this entity from
4716       --  Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
4717 
4718    --  Start of processing for Expand_Freeze_Record_Type
4719 
4720    begin
4721       --  Ensure that all freezing activities are properly flagged as Ghost
4722 
4723       Set_Ghost_Mode_From_Entity (Typ);
4724 
4725       --  Build discriminant checking functions if not a derived type (for
4726       --  derived types that are not tagged types, always use the discriminant
4727       --  checking functions of the parent type). However, for untagged types
4728       --  the derivation may have taken place before the parent was frozen, so
4729       --  we copy explicitly the discriminant checking functions from the
4730       --  parent into the components of the derived type.
4731 
4732       if not Is_Derived_Type (Typ)
4733         or else Has_New_Non_Standard_Rep (Typ)
4734         or else Is_Tagged_Type (Typ)
4735       then
4736          Build_Discr_Checking_Funcs (Typ_Decl);
4737 
4738       elsif Is_Derived_Type (Typ)
4739         and then not Is_Tagged_Type (Typ)
4740 
4741         --  If we have a derived Unchecked_Union, we do not inherit the
4742         --  discriminant checking functions from the parent type since the
4743         --  discriminants are non existent.
4744 
4745         and then not Is_Unchecked_Union (Typ)
4746         and then Has_Discriminants (Typ)
4747       then
4748          declare
4749             Old_Comp : Entity_Id;
4750 
4751          begin
4752             Old_Comp :=
4753               First_Component (Base_Type (Underlying_Type (Etype (Typ))));
4754             Comp := First_Component (Typ);
4755             while Present (Comp) loop
4756                if Ekind (Comp) = E_Component
4757                  and then Chars (Comp) = Chars (Old_Comp)
4758                then
4759                   Set_Discriminant_Checking_Func
4760                     (Comp, Discriminant_Checking_Func (Old_Comp));
4761                end if;
4762 
4763                Next_Component (Old_Comp);
4764                Next_Component (Comp);
4765             end loop;
4766          end;
4767       end if;
4768 
4769       if Is_Derived_Type (Typ)
4770         and then Is_Limited_Type (Typ)
4771         and then Is_Tagged_Type (Typ)
4772       then
4773          Check_Stream_Attributes (Typ);
4774       end if;
4775 
4776       --  Update task, protected, and controlled component flags, because some
4777       --  of the component types may have been private at the point of the
4778       --  record declaration. Detect anonymous access-to-controlled components.
4779 
4780       Comp := First_Component (Typ);
4781       while Present (Comp) loop
4782          Comp_Typ := Etype (Comp);
4783 
4784          Propagate_Concurrent_Flags (Typ, Comp_Typ);
4785 
4786          --  Do not set Has_Controlled_Component on a class-wide equivalent
4787          --  type. See Make_CW_Equivalent_Type.
4788 
4789          if not Is_Class_Wide_Equivalent_Type (Typ)
4790            and then
4791              (Has_Controlled_Component (Comp_Typ)
4792                or else (Chars (Comp) /= Name_uParent
4793                          and then (Is_Controlled_Active (Comp_Typ))))
4794          then
4795             Set_Has_Controlled_Component (Typ);
4796          end if;
4797 
4798          Next_Component (Comp);
4799       end loop;
4800 
4801       --  Handle constructors of untagged CPP_Class types
4802 
4803       if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then
4804          Set_CPP_Constructors (Typ);
4805       end if;
4806 
4807       --  Creation of the Dispatch Table. Note that a Dispatch Table is built
4808       --  for regular tagged types as well as for Ada types deriving from a C++
4809       --  Class, but not for tagged types directly corresponding to C++ classes
4810       --  In the later case we assume that it is created in the C++ side and we
4811       --  just use it.
4812 
4813       if Is_Tagged_Type (Typ) then
4814 
4815          --  Add the _Tag component
4816 
4817          if Underlying_Type (Etype (Typ)) = Typ then
4818             Expand_Tagged_Root (Typ);
4819          end if;
4820 
4821          if Is_CPP_Class (Typ) then
4822             Set_All_DT_Position (Typ);
4823 
4824             --  Create the tag entities with a minimum decoration
4825 
4826             if Tagged_Type_Expansion then
4827                Append_Freeze_Actions (Typ, Make_Tags (Typ));
4828             end if;
4829 
4830             Set_CPP_Constructors (Typ);
4831 
4832          else
4833             if not Building_Static_DT (Typ) then
4834 
4835                --  Usually inherited primitives are not delayed but the first
4836                --  Ada extension of a CPP_Class is an exception since the
4837                --  address of the inherited subprogram has to be inserted in
4838                --  the new Ada Dispatch Table and this is a freezing action.
4839 
4840                --  Similarly, if this is an inherited operation whose parent is
4841                --  not frozen yet, it is not in the DT of the parent, and we
4842                --  generate an explicit freeze node for the inherited operation
4843                --  so it is properly inserted in the DT of the current type.
4844 
4845                declare
4846                   Elmt : Elmt_Id;
4847                   Subp : Entity_Id;
4848 
4849                begin
4850                   Elmt := First_Elmt (Primitive_Operations (Typ));
4851                   while Present (Elmt) loop
4852                      Subp := Node (Elmt);
4853 
4854                      if Present (Alias (Subp)) then
4855                         if Is_CPP_Class (Etype (Typ)) then
4856                            Set_Has_Delayed_Freeze (Subp);
4857 
4858                         elsif Has_Delayed_Freeze (Alias (Subp))
4859                           and then not Is_Frozen (Alias (Subp))
4860                         then
4861                            Set_Is_Frozen (Subp, False);
4862                            Set_Has_Delayed_Freeze (Subp);
4863                         end if;
4864                      end if;
4865 
4866                      Next_Elmt (Elmt);
4867                   end loop;
4868                end;
4869             end if;
4870 
4871             --  Unfreeze momentarily the type to add the predefined primitives
4872             --  operations. The reason we unfreeze is so that these predefined
4873             --  operations will indeed end up as primitive operations (which
4874             --  must be before the freeze point).
4875 
4876             Set_Is_Frozen (Typ, False);
4877 
4878             --  Do not add the spec of predefined primitives in case of
4879             --  CPP tagged type derivations that have convention CPP.
4880 
4881             if Is_CPP_Class (Root_Type (Typ))
4882               and then Convention (Typ) = Convention_CPP
4883             then
4884                null;
4885 
4886             --  Do not add the spec of the predefined primitives if we are
4887             --  compiling under restriction No_Dispatching_Calls.
4888 
4889             elsif not Restriction_Active (No_Dispatching_Calls) then
4890                Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq);
4891                Insert_List_Before_And_Analyze (N, Predef_List);
4892             end if;
4893 
4894             --  Ada 2005 (AI-391): For a nonabstract null extension, create
4895             --  wrapper functions for each nonoverridden inherited function
4896             --  with a controlling result of the type. The wrapper for such
4897             --  a function returns an extension aggregate that invokes the
4898             --  parent function.
4899 
4900             if Ada_Version >= Ada_2005
4901               and then not Is_Abstract_Type (Typ)
4902               and then Is_Null_Extension (Typ)
4903             then
4904                Make_Controlling_Function_Wrappers
4905                  (Typ, Wrapper_Decl_List, Wrapper_Body_List);
4906                Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
4907             end if;
4908 
4909             --  Ada 2005 (AI-251): For a nonabstract type extension, build
4910             --  null procedure declarations for each set of homographic null
4911             --  procedures that are inherited from interface types but not
4912             --  overridden. This is done to ensure that the dispatch table
4913             --  entry associated with such null primitives are properly filled.
4914 
4915             if Ada_Version >= Ada_2005
4916               and then Etype (Typ) /= Typ
4917               and then not Is_Abstract_Type (Typ)
4918               and then Has_Interfaces (Typ)
4919             then
4920                Insert_Actions (N, Make_Null_Procedure_Specs (Typ));
4921             end if;
4922 
4923             Set_Is_Frozen (Typ);
4924 
4925             if not Is_Derived_Type (Typ)
4926               or else Is_Tagged_Type (Etype (Typ))
4927             then
4928                Set_All_DT_Position (Typ);
4929 
4930             --  If this is a type derived from an untagged private type whose
4931             --  full view is tagged, the type is marked tagged for layout
4932             --  reasons, but it has no dispatch table.
4933 
4934             elsif Is_Derived_Type (Typ)
4935               and then Is_Private_Type (Etype (Typ))
4936               and then not Is_Tagged_Type (Etype (Typ))
4937             then
4938                return;
4939             end if;
4940 
4941             --  Create and decorate the tags. Suppress their creation when
4942             --  not Tagged_Type_Expansion because the dispatching mechanism is
4943             --  handled internally by the virtual target.
4944 
4945             if Tagged_Type_Expansion then
4946                Append_Freeze_Actions (Typ, Make_Tags (Typ));
4947 
4948                --  Generate dispatch table of locally defined tagged type.
4949                --  Dispatch tables of library level tagged types are built
4950                --  later (see Analyze_Declarations).
4951 
4952                if not Building_Static_DT (Typ) then
4953                   Append_Freeze_Actions (Typ, Make_DT (Typ));
4954                end if;
4955             end if;
4956 
4957             --  If the type has unknown discriminants, propagate dispatching
4958             --  information to its underlying record view, which does not get
4959             --  its own dispatch table.
4960 
4961             if Is_Derived_Type (Typ)
4962               and then Has_Unknown_Discriminants (Typ)
4963               and then Present (Underlying_Record_View (Typ))
4964             then
4965                declare
4966                   Rep : constant Entity_Id := Underlying_Record_View (Typ);
4967                begin
4968                   Set_Access_Disp_Table
4969                     (Rep, Access_Disp_Table           (Typ));
4970                   Set_Dispatch_Table_Wrappers
4971                     (Rep, Dispatch_Table_Wrappers     (Typ));
4972                   Set_Direct_Primitive_Operations
4973                     (Rep, Direct_Primitive_Operations (Typ));
4974                end;
4975             end if;
4976 
4977             --  Make sure that the primitives Initialize, Adjust and Finalize
4978             --  are Frozen before other TSS subprograms. We don't want them
4979             --  Frozen inside.
4980 
4981             if Is_Controlled (Typ) then
4982                if not Is_Limited_Type (Typ) then
4983                   Append_Freeze_Actions (Typ,
4984                     Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ));
4985                end if;
4986 
4987                Append_Freeze_Actions (Typ,
4988                  Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ));
4989 
4990                Append_Freeze_Actions (Typ,
4991                  Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ));
4992             end if;
4993 
4994             --  Freeze rest of primitive operations. There is no need to handle
4995             --  the predefined primitives if we are compiling under restriction
4996             --  No_Dispatching_Calls.
4997 
4998             if not Restriction_Active (No_Dispatching_Calls) then
4999                Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ));
5000             end if;
5001          end if;
5002 
5003       --  In the untagged case, ever since Ada 83 an equality function must
5004       --  be  provided for variant records that are not unchecked unions.
5005       --  In Ada 2012 the equality function composes, and thus must be built
5006       --  explicitly just as for tagged records.
5007 
5008       elsif Has_Discriminants (Typ)
5009         and then not Is_Limited_Type (Typ)
5010       then
5011          declare
5012             Comps : constant Node_Id :=
5013                       Component_List (Type_Definition (Typ_Decl));
5014          begin
5015             if Present (Comps)
5016               and then Present (Variant_Part (Comps))
5017             then
5018                Build_Variant_Record_Equality (Typ);
5019             end if;
5020          end;
5021 
5022       --  Otherwise create primitive equality operation (AI05-0123)
5023 
5024       --  This is done unconditionally to ensure that tools can be linked
5025       --  properly with user programs compiled with older language versions.
5026       --  In addition, this is needed because "=" composes for bounded strings
5027       --  in all language versions (see Exp_Ch4.Expand_Composite_Equality).
5028 
5029       elsif Comes_From_Source (Typ)
5030         and then Convention (Typ) = Convention_Ada
5031         and then not Is_Limited_Type (Typ)
5032       then
5033          Build_Untagged_Equality (Typ);
5034       end if;
5035 
5036       --  Before building the record initialization procedure, if we are
5037       --  dealing with a concurrent record value type, then we must go through
5038       --  the discriminants, exchanging discriminals between the concurrent
5039       --  type and the concurrent record value type. See the section "Handling
5040       --  of Discriminants" in the Einfo spec for details.
5041 
5042       if Is_Concurrent_Record_Type (Typ)
5043         and then Has_Discriminants (Typ)
5044       then
5045          declare
5046             Ctyp       : constant Entity_Id :=
5047                            Corresponding_Concurrent_Type (Typ);
5048             Conc_Discr : Entity_Id;
5049             Rec_Discr  : Entity_Id;
5050             Temp       : Entity_Id;
5051 
5052          begin
5053             Conc_Discr := First_Discriminant (Ctyp);
5054             Rec_Discr  := First_Discriminant (Typ);
5055             while Present (Conc_Discr) loop
5056                Temp := Discriminal (Conc_Discr);
5057                Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
5058                Set_Discriminal (Rec_Discr, Temp);
5059 
5060                Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
5061                Set_Discriminal_Link (Discriminal (Rec_Discr),  Rec_Discr);
5062 
5063                Next_Discriminant (Conc_Discr);
5064                Next_Discriminant (Rec_Discr);
5065             end loop;
5066          end;
5067       end if;
5068 
5069       if Has_Controlled_Component (Typ) then
5070          Build_Controlling_Procs (Typ);
5071       end if;
5072 
5073       Adjust_Discriminants (Typ);
5074 
5075       --  Do not need init for interfaces on virtual targets since they're
5076       --  abstract.
5077 
5078       if Tagged_Type_Expansion or else not Is_Interface (Typ) then
5079          Build_Record_Init_Proc (Typ_Decl, Typ);
5080       end if;
5081 
5082       --  For tagged type that are not interfaces, build bodies of primitive
5083       --  operations. Note: do this after building the record initialization
5084       --  procedure, since the primitive operations may need the initialization
5085       --  routine. There is no need to add predefined primitives of interfaces
5086       --  because all their predefined primitives are abstract.
5087 
5088       if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
5089 
5090          --  Do not add the body of predefined primitives in case of CPP tagged
5091          --  type derivations that have convention CPP.
5092 
5093          if Is_CPP_Class (Root_Type (Typ))
5094            and then Convention (Typ) = Convention_CPP
5095          then
5096             null;
5097 
5098          --  Do not add the body of the predefined primitives if we are
5099          --  compiling under restriction No_Dispatching_Calls or if we are
5100          --  compiling a CPP tagged type.
5101 
5102          elsif not Restriction_Active (No_Dispatching_Calls) then
5103 
5104             --  Create the body of TSS primitive Finalize_Address. This must
5105             --  be done before the bodies of all predefined primitives are
5106             --  created. If Typ is limited, Stream_Input and Stream_Read may
5107             --  produce build-in-place allocations and for those the expander
5108             --  needs Finalize_Address.
5109 
5110             Make_Finalize_Address_Body (Typ);
5111             Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
5112             Append_Freeze_Actions (Typ, Predef_List);
5113          end if;
5114 
5115          --  Ada 2005 (AI-391): If any wrappers were created for nonoverridden
5116          --  inherited functions, then add their bodies to the freeze actions.
5117 
5118          if Present (Wrapper_Body_List) then
5119             Append_Freeze_Actions (Typ, Wrapper_Body_List);
5120          end if;
5121 
5122          --  Create extra formals for the primitive operations of the type.
5123          --  This must be done before analyzing the body of the initialization
5124          --  procedure, because a self-referential type might call one of these
5125          --  primitives in the body of the init_proc itself.
5126 
5127          declare
5128             Elmt : Elmt_Id;
5129             Subp : Entity_Id;
5130 
5131          begin
5132             Elmt := First_Elmt (Primitive_Operations (Typ));
5133             while Present (Elmt) loop
5134                Subp := Node (Elmt);
5135                if not Has_Foreign_Convention (Subp)
5136                  and then not Is_Predefined_Dispatching_Operation (Subp)
5137                then
5138                   Create_Extra_Formals (Subp);
5139                end if;
5140 
5141                Next_Elmt (Elmt);
5142             end loop;
5143          end;
5144       end if;
5145 
5146       Ghost_Mode := Save_Ghost_Mode;
5147    end Expand_Freeze_Record_Type;
5148 
5149    ------------------------------------
5150    -- Expand_N_Full_Type_Declaration --
5151    ------------------------------------
5152 
5153    procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
5154       procedure Build_Master (Ptr_Typ : Entity_Id);
5155       --  Create the master associated with Ptr_Typ
5156 
5157       ------------------
5158       -- Build_Master --
5159       ------------------
5160 
5161       procedure Build_Master (Ptr_Typ : Entity_Id) is
5162          Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
5163 
5164       begin
5165          --  If the designated type is an incomplete view coming from a
5166          --  limited-with'ed package, we need to use the nonlimited view in
5167          --  case it has tasks.
5168 
5169          if Ekind (Desig_Typ) in Incomplete_Kind
5170            and then Present (Non_Limited_View (Desig_Typ))
5171          then
5172             Desig_Typ := Non_Limited_View (Desig_Typ);
5173          end if;
5174 
5175          --  Anonymous access types are created for the components of the
5176          --  record parameter for an entry declaration. No master is created
5177          --  for such a type.
5178 
5179          if Comes_From_Source (N) and then Has_Task (Desig_Typ) then
5180             Build_Master_Entity (Ptr_Typ);
5181             Build_Master_Renaming (Ptr_Typ);
5182 
5183          --  Create a class-wide master because a Master_Id must be generated
5184          --  for access-to-limited-class-wide types whose root may be extended
5185          --  with task components.
5186 
5187          --  Note: This code covers access-to-limited-interfaces because they
5188          --        can be used to reference tasks implementing them.
5189 
5190          elsif Is_Limited_Class_Wide_Type (Desig_Typ)
5191            and then Tasking_Allowed
5192          then
5193             Build_Class_Wide_Master (Ptr_Typ);
5194          end if;
5195       end Build_Master;
5196 
5197       --  Local declarations
5198 
5199       Def_Id : constant Entity_Id := Defining_Identifier (N);
5200       B_Id   : constant Entity_Id := Base_Type (Def_Id);
5201       FN     : Node_Id;
5202       Par_Id : Entity_Id;
5203 
5204    --  Start of processing for Expand_N_Full_Type_Declaration
5205 
5206    begin
5207       if Is_Access_Type (Def_Id) then
5208          Build_Master (Def_Id);
5209 
5210          if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
5211             Expand_Access_Protected_Subprogram_Type (N);
5212          end if;
5213 
5214       --  Array of anonymous access-to-task pointers
5215 
5216       elsif Ada_Version >= Ada_2005
5217         and then Is_Array_Type (Def_Id)
5218         and then Is_Access_Type (Component_Type (Def_Id))
5219         and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
5220       then
5221          Build_Master (Component_Type (Def_Id));
5222 
5223       elsif Has_Task (Def_Id) then
5224          Expand_Previous_Access_Type (Def_Id);
5225 
5226       --  Check the components of a record type or array of records for
5227       --  anonymous access-to-task pointers.
5228 
5229       elsif Ada_Version >= Ada_2005
5230         and then (Is_Record_Type (Def_Id)
5231                    or else
5232                      (Is_Array_Type (Def_Id)
5233                        and then Is_Record_Type (Component_Type (Def_Id))))
5234       then
5235          declare
5236             Comp  : Entity_Id;
5237             First : Boolean;
5238             M_Id  : Entity_Id;
5239             Typ   : Entity_Id;
5240 
5241          begin
5242             if Is_Array_Type (Def_Id) then
5243                Comp := First_Entity (Component_Type (Def_Id));
5244             else
5245                Comp := First_Entity (Def_Id);
5246             end if;
5247 
5248             --  Examine all components looking for anonymous access-to-task
5249             --  types.
5250 
5251             First := True;
5252             while Present (Comp) loop
5253                Typ := Etype (Comp);
5254 
5255                if Ekind (Typ) = E_Anonymous_Access_Type
5256                  and then Has_Task (Available_View (Designated_Type (Typ)))
5257                  and then No (Master_Id (Typ))
5258                then
5259                   --  Ensure that the record or array type have a _master
5260 
5261                   if First then
5262                      Build_Master_Entity (Def_Id);
5263                      Build_Master_Renaming (Typ);
5264                      M_Id := Master_Id (Typ);
5265 
5266                      First := False;
5267 
5268                   --  Reuse the same master to service any additional types
5269 
5270                   else
5271                      Set_Master_Id (Typ, M_Id);
5272                   end if;
5273                end if;
5274 
5275                Next_Entity (Comp);
5276             end loop;
5277          end;
5278       end if;
5279 
5280       Par_Id := Etype (B_Id);
5281 
5282       --  The parent type is private then we need to inherit any TSS operations
5283       --  from the full view.
5284 
5285       if Ekind (Par_Id) in Private_Kind
5286         and then Present (Full_View (Par_Id))
5287       then
5288          Par_Id := Base_Type (Full_View (Par_Id));
5289       end if;
5290 
5291       if Nkind (Type_Definition (Original_Node (N))) =
5292                                                    N_Derived_Type_Definition
5293         and then not Is_Tagged_Type (Def_Id)
5294         and then Present (Freeze_Node (Par_Id))
5295         and then Present (TSS_Elist (Freeze_Node (Par_Id)))
5296       then
5297          Ensure_Freeze_Node (B_Id);
5298          FN := Freeze_Node (B_Id);
5299 
5300          if No (TSS_Elist (FN)) then
5301             Set_TSS_Elist (FN, New_Elmt_List);
5302          end if;
5303 
5304          declare
5305             T_E  : constant Elist_Id := TSS_Elist (FN);
5306             Elmt : Elmt_Id;
5307 
5308          begin
5309             Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
5310             while Present (Elmt) loop
5311                if Chars (Node (Elmt)) /= Name_uInit then
5312                   Append_Elmt (Node (Elmt), T_E);
5313                end if;
5314 
5315                Next_Elmt (Elmt);
5316             end loop;
5317 
5318             --  If the derived type itself is private with a full view, then
5319             --  associate the full view with the inherited TSS_Elist as well.
5320 
5321             if Ekind (B_Id) in Private_Kind
5322               and then Present (Full_View (B_Id))
5323             then
5324                Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
5325                Set_TSS_Elist
5326                  (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
5327             end if;
5328          end;
5329       end if;
5330    end Expand_N_Full_Type_Declaration;
5331 
5332    ---------------------------------
5333    -- Expand_N_Object_Declaration --
5334    ---------------------------------
5335 
5336    procedure Expand_N_Object_Declaration (N : Node_Id) is
5337       Loc      : constant Source_Ptr := Sloc (N);
5338       Def_Id   : constant Entity_Id  := Defining_Identifier (N);
5339       Expr     : constant Node_Id    := Expression (N);
5340       Obj_Def  : constant Node_Id    := Object_Definition (N);
5341       Typ      : constant Entity_Id  := Etype (Def_Id);
5342       Base_Typ : constant Entity_Id  := Base_Type (Typ);
5343       Expr_Q   : Node_Id;
5344 
5345       function Build_Equivalent_Aggregate return Boolean;
5346       --  If the object has a constrained discriminated type and no initial
5347       --  value, it may be possible to build an equivalent aggregate instead,
5348       --  and prevent an actual call to the initialization procedure.
5349 
5350       procedure Default_Initialize_Object (After : Node_Id);
5351       --  Generate all default initialization actions for object Def_Id. Any
5352       --  new code is inserted after node After.
5353 
5354       function Rewrite_As_Renaming return Boolean;
5355       --  Indicate whether to rewrite a declaration with initialization into an
5356       --  object renaming declaration (see below).
5357 
5358       --------------------------------
5359       -- Build_Equivalent_Aggregate --
5360       --------------------------------
5361 
5362       function Build_Equivalent_Aggregate return Boolean is
5363          Aggr      : Node_Id;
5364          Comp      : Entity_Id;
5365          Discr     : Elmt_Id;
5366          Full_Type : Entity_Id;
5367 
5368       begin
5369          Full_Type := Typ;
5370 
5371          if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
5372             Full_Type := Full_View (Typ);
5373          end if;
5374 
5375          --  Only perform this transformation if Elaboration_Code is forbidden
5376          --  or undesirable, and if this is a global entity of a constrained
5377          --  record type.
5378 
5379          --  If Initialize_Scalars might be active this  transformation cannot
5380          --  be performed either, because it will lead to different semantics
5381          --  or because elaboration code will in fact be created.
5382 
5383          if Ekind (Full_Type) /= E_Record_Subtype
5384            or else not Has_Discriminants (Full_Type)
5385            or else not Is_Constrained (Full_Type)
5386            or else Is_Controlled (Full_Type)
5387            or else Is_Limited_Type (Full_Type)
5388            or else not Restriction_Active (No_Initialize_Scalars)
5389          then
5390             return False;
5391          end if;
5392 
5393          if Ekind (Current_Scope) = E_Package
5394            and then
5395              (Restriction_Active (No_Elaboration_Code)
5396                or else Is_Preelaborated (Current_Scope))
5397          then
5398             --  Building a static aggregate is possible if the discriminants
5399             --  have static values and the other components have static
5400             --  defaults or none.
5401 
5402             Discr := First_Elmt (Discriminant_Constraint (Full_Type));
5403             while Present (Discr) loop
5404                if not Is_OK_Static_Expression (Node (Discr)) then
5405                   return False;
5406                end if;
5407 
5408                Next_Elmt (Discr);
5409             end loop;
5410 
5411             --  Check that initialized components are OK, and that non-
5412             --  initialized components do not require a call to their own
5413             --  initialization procedure.
5414 
5415             Comp := First_Component (Full_Type);
5416             while Present (Comp) loop
5417                if Ekind (Comp) = E_Component
5418                  and then Present (Expression (Parent (Comp)))
5419                  and then
5420                    not Is_OK_Static_Expression (Expression (Parent (Comp)))
5421                then
5422                   return False;
5423 
5424                elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
5425                   return False;
5426 
5427                end if;
5428 
5429                Next_Component (Comp);
5430             end loop;
5431 
5432             --  Everything is static, assemble the aggregate, discriminant
5433             --  values first.
5434 
5435             Aggr :=
5436                Make_Aggregate (Loc,
5437                 Expressions            => New_List,
5438                 Component_Associations => New_List);
5439 
5440             Discr := First_Elmt (Discriminant_Constraint (Full_Type));
5441             while Present (Discr) loop
5442                Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
5443                Next_Elmt (Discr);
5444             end loop;
5445 
5446             --  Now collect values of initialized components
5447 
5448             Comp := First_Component (Full_Type);
5449             while Present (Comp) loop
5450                if Ekind (Comp) = E_Component
5451                  and then Present (Expression (Parent (Comp)))
5452                then
5453                   Append_To (Component_Associations (Aggr),
5454                     Make_Component_Association (Loc,
5455                       Choices    => New_List (New_Occurrence_Of (Comp, Loc)),
5456                       Expression => New_Copy_Tree
5457                                       (Expression (Parent (Comp)))));
5458                end if;
5459 
5460                Next_Component (Comp);
5461             end loop;
5462 
5463             --  Finally, box-initialize remaining components
5464 
5465             Append_To (Component_Associations (Aggr),
5466               Make_Component_Association (Loc,
5467                 Choices    => New_List (Make_Others_Choice (Loc)),
5468                 Expression => Empty));
5469             Set_Box_Present (Last (Component_Associations (Aggr)));
5470             Set_Expression (N, Aggr);
5471 
5472             if Typ /= Full_Type then
5473                Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
5474                Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
5475                Analyze_And_Resolve (Aggr, Typ);
5476             else
5477                Analyze_And_Resolve (Aggr, Full_Type);
5478             end if;
5479 
5480             return True;
5481 
5482          else
5483             return False;
5484          end if;
5485       end Build_Equivalent_Aggregate;
5486 
5487       -------------------------------
5488       -- Default_Initialize_Object --
5489       -------------------------------
5490 
5491       procedure Default_Initialize_Object (After : Node_Id) is
5492          function New_Object_Reference return Node_Id;
5493          --  Return a new reference to Def_Id with attributes Assignment_OK and
5494          --  Must_Not_Freeze already set.
5495 
5496          --------------------------
5497          -- New_Object_Reference --
5498          --------------------------
5499 
5500          function New_Object_Reference return Node_Id is
5501             Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
5502 
5503          begin
5504             --  The call to the type init proc or [Deep_]Finalize must not
5505             --  freeze the related object as the call is internally generated.
5506             --  This way legal rep clauses that apply to the object will not be
5507             --  flagged. Note that the initialization call may be removed if
5508             --  pragma Import is encountered or moved to the freeze actions of
5509             --  the object because of an address clause.
5510 
5511             Set_Assignment_OK   (Obj_Ref);
5512             Set_Must_Not_Freeze (Obj_Ref);
5513 
5514             return Obj_Ref;
5515          end New_Object_Reference;
5516 
5517          --  Local variables
5518 
5519          Exceptions_OK : constant Boolean :=
5520                            not Restriction_Active (No_Exception_Propagation);
5521 
5522          Abrt_Blk    : Node_Id;
5523          Abrt_Blk_Id : Entity_Id;
5524          Abrt_HSS    : Node_Id;
5525          Aggr_Init   : Node_Id;
5526          AUD         : Entity_Id;
5527          Comp_Init   : List_Id := No_List;
5528          Fin_Call    : Node_Id;
5529          Init_Stmts  : List_Id := No_List;
5530          Obj_Init    : Node_Id := Empty;
5531          Obj_Ref     : Node_Id;
5532 
5533       --  Start of processing for Default_Initialize_Object
5534 
5535       begin
5536          --  Default initialization is suppressed for objects that are already
5537          --  known to be imported (i.e. whose declaration specifies the Import
5538          --  aspect). Note that for objects with a pragma Import, we generate
5539          --  initialization here, and then remove it downstream when processing
5540          --  the pragma. It is also suppressed for variables for which a pragma
5541          --  Suppress_Initialization has been explicitly given
5542 
5543          if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
5544             return;
5545          end if;
5546 
5547          --  The expansion performed by this routine is as follows:
5548 
5549          --    begin
5550          --       Abort_Defer;
5551          --       Type_Init_Proc (Obj);
5552 
5553          --       begin
5554          --          [Deep_]Initialize (Obj);
5555 
5556          --       exception
5557          --          when others =>
5558          --             [Deep_]Finalize (Obj, Self => False);
5559          --             raise;
5560          --       end;
5561          --    at end
5562          --       Abort_Undefer_Direct;
5563          --    end;
5564 
5565          --  Initialize the components of the object
5566 
5567          if Has_Non_Null_Base_Init_Proc (Typ)
5568            and then not No_Initialization (N)
5569            and then not Initialization_Suppressed (Typ)
5570          then
5571             --  Do not initialize the components if No_Default_Initialization
5572             --  applies as the actual restriction check will occur later
5573             --  when the object is frozen as it is not known yet whether the
5574             --  object is imported or not.
5575 
5576             if not Restriction_Active (No_Default_Initialization) then
5577 
5578                --  If the values of the components are compile-time known, use
5579                --  their prebuilt aggregate form directly.
5580 
5581                Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
5582 
5583                if Present (Aggr_Init) then
5584                   Set_Expression
5585                     (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
5586 
5587                --  If type has discriminants, try to build an equivalent
5588                --  aggregate using discriminant values from the declaration.
5589                --  This is a useful optimization, in particular if restriction
5590                --  No_Elaboration_Code is active.
5591 
5592                elsif Build_Equivalent_Aggregate then
5593                   null;
5594 
5595                --  Otherwise invoke the type init proc, generate:
5596                --    Type_Init_Proc (Obj);
5597 
5598                else
5599                   Obj_Ref := New_Object_Reference;
5600 
5601                   if Comes_From_Source (Def_Id) then
5602                      Initialization_Warning (Obj_Ref);
5603                   end if;
5604 
5605                   Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
5606                end if;
5607             end if;
5608 
5609          --  Provide a default value if the object needs simple initialization
5610          --  and does not already have an initial value. A generated temporary
5611          --  does not require initialization because it will be assigned later.
5612 
5613          elsif Needs_Simple_Initialization
5614                  (Typ, Initialize_Scalars
5615                          and then No (Following_Address_Clause (N)))
5616            and then not Is_Internal (Def_Id)
5617            and then not Has_Init_Expression (N)
5618          then
5619             Set_No_Initialization (N, False);
5620             Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
5621             Analyze_And_Resolve (Expression (N), Typ);
5622          end if;
5623 
5624          --  Initialize the object, generate:
5625          --    [Deep_]Initialize (Obj);
5626 
5627          if Needs_Finalization (Typ) and then not No_Initialization (N) then
5628             Obj_Init :=
5629               Make_Init_Call
5630                 (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
5631                  Typ     => Typ);
5632          end if;
5633 
5634          --  Build a special finalization block when both the object and its
5635          --  controlled components are to be initialized. The block finalizes
5636          --  the components if the object initialization fails. Generate:
5637 
5638          --    begin
5639          --       <Obj_Init>
5640 
5641          --    exception
5642          --       when others =>
5643          --          <Fin_Call>
5644          --          raise;
5645          --    end;
5646 
5647          if Has_Controlled_Component (Typ)
5648            and then Present (Comp_Init)
5649            and then Present (Obj_Init)
5650            and then Exceptions_OK
5651          then
5652             Init_Stmts := Comp_Init;
5653 
5654             Fin_Call :=
5655               Make_Final_Call
5656                 (Obj_Ref   => New_Object_Reference,
5657                  Typ       => Typ,
5658                  Skip_Self => True);
5659 
5660             if Present (Fin_Call) then
5661 
5662                --  Do not emit warnings related to the elaboration order when a
5663                --  controlled object is declared before the body of Finalize is
5664                --  seen.
5665 
5666                Set_No_Elaboration_Check (Fin_Call);
5667 
5668                Append_To (Init_Stmts,
5669                  Make_Block_Statement (Loc,
5670                    Declarations               => No_List,
5671 
5672                    Handled_Statement_Sequence =>
5673                      Make_Handled_Sequence_Of_Statements (Loc,
5674                        Statements         => New_List (Obj_Init),
5675 
5676                        Exception_Handlers => New_List (
5677                          Make_Exception_Handler (Loc,
5678                            Exception_Choices => New_List (
5679                              Make_Others_Choice (Loc)),
5680 
5681                            Statements        => New_List (
5682                              Fin_Call,
5683                              Make_Raise_Statement (Loc)))))));
5684             end if;
5685 
5686          --  Otherwise finalization is not required, the initialization calls
5687          --  are passed to the abort block building circuitry, generate:
5688 
5689          --    Type_Init_Proc (Obj);
5690          --    [Deep_]Initialize (Obj);
5691 
5692          else
5693             if Present (Comp_Init) then
5694                Init_Stmts := Comp_Init;
5695             end if;
5696 
5697             if Present (Obj_Init) then
5698                if No (Init_Stmts) then
5699                   Init_Stmts := New_List;
5700                end if;
5701 
5702                Append_To (Init_Stmts, Obj_Init);
5703             end if;
5704          end if;
5705 
5706          --  Build an abort block to protect the initialization calls
5707 
5708          if Abort_Allowed
5709            and then Present (Comp_Init)
5710            and then Present (Obj_Init)
5711          then
5712             --  Generate:
5713             --    Abort_Defer;
5714 
5715             Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
5716 
5717             --  When exceptions are propagated, abort deferral must take place
5718             --  in the presence of initialization or finalization exceptions.
5719             --  Generate:
5720 
5721             --    begin
5722             --       Abort_Defer;
5723             --       <Init_Stmts>
5724             --    at end
5725             --       Abort_Undefer_Direct;
5726             --    end;
5727 
5728             if Exceptions_OK then
5729                AUD := RTE (RE_Abort_Undefer_Direct);
5730 
5731                Abrt_HSS :=
5732                  Make_Handled_Sequence_Of_Statements (Loc,
5733                    Statements  => Init_Stmts,
5734                    At_End_Proc => New_Occurrence_Of (AUD, Loc));
5735 
5736                Abrt_Blk :=
5737                  Make_Block_Statement (Loc,
5738                    Handled_Statement_Sequence => Abrt_HSS);
5739 
5740                Add_Block_Identifier  (Abrt_Blk, Abrt_Blk_Id);
5741                Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
5742 
5743                --  Present the Abort_Undefer_Direct function to the backend so
5744                --  that it can inline the call to the function.
5745 
5746                Add_Inlined_Body (AUD, N);
5747 
5748                Init_Stmts := New_List (Abrt_Blk);
5749 
5750             --  Otherwise exceptions are not propagated. Generate:
5751 
5752             --    Abort_Defer;
5753             --    <Init_Stmts>
5754             --    Abort_Undefer;
5755 
5756             else
5757                Append_To (Init_Stmts,
5758                  Build_Runtime_Call (Loc, RE_Abort_Undefer));
5759             end if;
5760          end if;
5761 
5762          --  Insert the whole initialization sequence into the tree. If the
5763          --  object has a delayed freeze, as will be the case when it has
5764          --  aspect specifications, the initialization sequence is part of
5765          --  the freeze actions.
5766 
5767          if Present (Init_Stmts) then
5768             if Has_Delayed_Freeze (Def_Id) then
5769                Append_Freeze_Actions (Def_Id, Init_Stmts);
5770             else
5771                Insert_Actions_After (After, Init_Stmts);
5772             end if;
5773          end if;
5774       end Default_Initialize_Object;
5775 
5776       -------------------------
5777       -- Rewrite_As_Renaming --
5778       -------------------------
5779 
5780       function Rewrite_As_Renaming return Boolean is
5781       begin
5782          --  If the object declaration appears in the form
5783 
5784          --    Obj : Ctrl_Typ := Func (...);
5785 
5786          --  where Ctrl_Typ is controlled but not immutably limited type, then
5787          --  the expansion of the function call should use a dereference of the
5788          --  result to reference the value on the secondary stack.
5789 
5790          --    Obj : Ctrl_Typ renames Func (...).all;
5791 
5792          --  As a result, the call avoids an extra copy. This an optimization,
5793          --  but it is required for passing ACATS tests in some cases where it
5794          --  would otherwise make two copies. The RM allows removing redunant
5795          --  Adjust/Finalize calls, but does not allow insertion of extra ones.
5796 
5797          --  This part is disabled for now, because it breaks GPS builds
5798 
5799          return (False -- ???
5800              and then Nkind (Expr_Q) = N_Explicit_Dereference
5801              and then not Comes_From_Source (Expr_Q)
5802              and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
5803              and then Nkind (Object_Definition (N)) in N_Has_Entity
5804              and then (Needs_Finalization (Entity (Object_Definition (N)))))
5805 
5806            --  If the initializing expression is for a variable with attribute
5807            --  OK_To_Rename set, then transform:
5808 
5809            --     Obj : Typ := Expr;
5810 
5811            --  into
5812 
5813            --     Obj : Typ renames Expr;
5814 
5815            --  provided that Obj is not aliased. The aliased case has to be
5816            --  excluded in general because Expr will not be aliased in
5817            --  general.
5818 
5819            or else
5820              (not Aliased_Present (N)
5821                and then Is_Entity_Name (Expr_Q)
5822                and then Ekind (Entity (Expr_Q)) = E_Variable
5823                and then OK_To_Rename (Entity (Expr_Q))
5824                and then Is_Entity_Name (Obj_Def));
5825       end Rewrite_As_Renaming;
5826 
5827       --  Local variables
5828 
5829       Next_N     : constant Node_Id := Next (N);
5830       Id_Ref     : Node_Id;
5831       Tag_Assign : Node_Id;
5832 
5833       Init_After : Node_Id := N;
5834       --  Node after which the initialization actions are to be inserted. This
5835       --  is normally N, except for the case of a shared passive variable, in
5836       --  which case the init proc call must be inserted only after the bodies
5837       --  of the shared variable procedures have been seen.
5838 
5839    --  Start of processing for Expand_N_Object_Declaration
5840 
5841    begin
5842       --  Don't do anything for deferred constants. All proper actions will be
5843       --  expanded during the full declaration.
5844 
5845       if No (Expr) and Constant_Present (N) then
5846          return;
5847       end if;
5848 
5849       --  The type of the object cannot be abstract. This is diagnosed at the
5850       --  point the object is frozen, which happens after the declaration is
5851       --  fully expanded, so simply return now.
5852 
5853       if Is_Abstract_Type (Typ) then
5854          return;
5855       end if;
5856 
5857       --  First we do special processing for objects of a tagged type where
5858       --  this is the point at which the type is frozen. The creation of the
5859       --  dispatch table and the initialization procedure have to be deferred
5860       --  to this point, since we reference previously declared primitive
5861       --  subprograms.
5862 
5863       --  Force construction of dispatch tables of library level tagged types
5864 
5865       if Tagged_Type_Expansion
5866         and then Static_Dispatch_Tables
5867         and then Is_Library_Level_Entity (Def_Id)
5868         and then Is_Library_Level_Tagged_Type (Base_Typ)
5869         and then Ekind_In (Base_Typ, E_Record_Type,
5870                                      E_Protected_Type,
5871                                      E_Task_Type)
5872         and then not Has_Dispatch_Table (Base_Typ)
5873       then
5874          declare
5875             New_Nodes : List_Id := No_List;
5876 
5877          begin
5878             if Is_Concurrent_Type (Base_Typ) then
5879                New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
5880             else
5881                New_Nodes := Make_DT (Base_Typ, N);
5882             end if;
5883 
5884             if not Is_Empty_List (New_Nodes) then
5885                Insert_List_Before (N, New_Nodes);
5886             end if;
5887          end;
5888       end if;
5889 
5890       --  Make shared memory routines for shared passive variable
5891 
5892       if Is_Shared_Passive (Def_Id) then
5893          Init_After := Make_Shared_Var_Procs (N);
5894       end if;
5895 
5896       --  If tasks being declared, make sure we have an activation chain
5897       --  defined for the tasks (has no effect if we already have one), and
5898       --  also that a Master variable is established and that the appropriate
5899       --  enclosing construct is established as a task master.
5900 
5901       if Has_Task (Typ) then
5902          Build_Activation_Chain_Entity (N);
5903          Build_Master_Entity (Def_Id);
5904       end if;
5905 
5906       --  Default initialization required, and no expression present
5907 
5908       if No (Expr) then
5909 
5910          --  If we have a type with a variant part, the initialization proc
5911          --  will contain implicit tests of the discriminant values, which
5912          --  counts as a violation of the restriction No_Implicit_Conditionals.
5913 
5914          if Has_Variant_Part (Typ) then
5915             declare
5916                Msg : Boolean;
5917 
5918             begin
5919                Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
5920 
5921                if Msg then
5922                   Error_Msg_N
5923                     ("\initialization of variant record tests discriminants",
5924                      Obj_Def);
5925                   return;
5926                end if;
5927             end;
5928          end if;
5929 
5930          --  For the default initialization case, if we have a private type
5931          --  with invariants, and invariant checks are enabled, then insert an
5932          --  invariant check after the object declaration. Note that it is OK
5933          --  to clobber the object with an invalid value since if the exception
5934          --  is raised, then the object will go out of scope. In the case where
5935          --  an array object is initialized with an aggregate, the expression
5936          --  is removed. Check flag Has_Init_Expression to avoid generating a
5937          --  junk invariant check and flag No_Initialization to avoid checking
5938          --  an uninitialized object such as a compiler temporary used for an
5939          --  aggregate.
5940 
5941          if Has_Invariants (Base_Typ)
5942            and then Present (Invariant_Procedure (Base_Typ))
5943            and then not Has_Init_Expression (N)
5944            and then not No_Initialization (N)
5945          then
5946             --  If entity has an address clause or aspect, make invariant
5947             --  call into a freeze action for the explicit freeze node for
5948             --  object. Otherwise insert invariant check after declaration.
5949 
5950             if Present (Following_Address_Clause (N))
5951               or else Has_Aspect (Def_Id, Aspect_Address)
5952             then
5953                Ensure_Freeze_Node (Def_Id);
5954                Set_Has_Delayed_Freeze (Def_Id);
5955                Set_Is_Frozen (Def_Id, False);
5956 
5957                if not Partial_View_Has_Unknown_Discr (Typ) then
5958                   Append_Freeze_Action (Def_Id,
5959                     Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
5960                end if;
5961 
5962             elsif not Partial_View_Has_Unknown_Discr (Typ) then
5963                Insert_After (N,
5964                  Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
5965             end if;
5966          end if;
5967 
5968          Default_Initialize_Object (Init_After);
5969 
5970          --  Generate attribute for Persistent_BSS if needed
5971 
5972          if Persistent_BSS_Mode
5973            and then Comes_From_Source (N)
5974            and then Is_Potentially_Persistent_Type (Typ)
5975            and then not Has_Init_Expression (N)
5976            and then Is_Library_Level_Entity (Def_Id)
5977          then
5978             declare
5979                Prag : Node_Id;
5980             begin
5981                Prag :=
5982                  Make_Linker_Section_Pragma
5983                    (Def_Id, Sloc (N), ".persistent.bss");
5984                Insert_After (N, Prag);
5985                Analyze (Prag);
5986             end;
5987          end if;
5988 
5989          --  If access type, then we know it is null if not initialized
5990 
5991          if Is_Access_Type (Typ) then
5992             Set_Is_Known_Null (Def_Id);
5993          end if;
5994 
5995       --  Explicit initialization present
5996 
5997       else
5998          --  Obtain actual expression from qualified expression
5999 
6000          if Nkind (Expr) = N_Qualified_Expression then
6001             Expr_Q := Expression (Expr);
6002          else
6003             Expr_Q := Expr;
6004          end if;
6005 
6006          --  When we have the appropriate type of aggregate in the expression
6007          --  (it has been determined during analysis of the aggregate by
6008          --  setting the delay flag), let's perform in place assignment and
6009          --  thus avoid creating a temporary.
6010 
6011          if Is_Delayed_Aggregate (Expr_Q) then
6012             Convert_Aggr_In_Object_Decl (N);
6013 
6014          --  Ada 2005 (AI-318-02): If the initialization expression is a call
6015          --  to a build-in-place function, then access to the declared object
6016          --  must be passed to the function. Currently we limit such functions
6017          --  to those with constrained limited result subtypes, but eventually
6018          --  plan to expand the allowed forms of functions that are treated as
6019          --  build-in-place.
6020 
6021          elsif Ada_Version >= Ada_2005
6022            and then Is_Build_In_Place_Function_Call (Expr_Q)
6023          then
6024             Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
6025 
6026             --  The previous call expands the expression initializing the
6027             --  built-in-place object into further code that will be analyzed
6028             --  later. No further expansion needed here.
6029 
6030             return;
6031 
6032          --  Ada 2005 (AI-251): Rewrite the expression that initializes a
6033          --  class-wide interface object to ensure that we copy the full
6034          --  object, unless we are targetting a VM where interfaces are handled
6035          --  by VM itself. Note that if the root type of Typ is an ancestor of
6036          --  Expr's type, both types share the same dispatch table and there is
6037          --  no need to displace the pointer.
6038 
6039          elsif Is_Interface (Typ)
6040 
6041            --  Avoid never-ending recursion because if Equivalent_Type is set
6042            --  then we've done it already and must not do it again.
6043 
6044            and then not
6045              (Nkind (Obj_Def) = N_Identifier
6046                and then Present (Equivalent_Type (Entity (Obj_Def))))
6047          then
6048             pragma Assert (Is_Class_Wide_Type (Typ));
6049 
6050             --  If the object is a return object of an inherently limited type,
6051             --  which implies build-in-place treatment, bypass the special
6052             --  treatment of class-wide interface initialization below. In this
6053             --  case, the expansion of the return statement will take care of
6054             --  creating the object (via allocator) and initializing it.
6055 
6056             if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
6057                null;
6058 
6059             elsif Tagged_Type_Expansion then
6060                declare
6061                   Iface    : constant Entity_Id := Root_Type (Typ);
6062                   Expr_N   : Node_Id := Expr;
6063                   Expr_Typ : Entity_Id;
6064                   New_Expr : Node_Id;
6065                   Obj_Id   : Entity_Id;
6066                   Tag_Comp : Node_Id;
6067 
6068                begin
6069                   --  If the original node of the expression was a conversion
6070                   --  to this specific class-wide interface type then restore
6071                   --  the original node because we must copy the object before
6072                   --  displacing the pointer to reference the secondary tag
6073                   --  component. This code must be kept synchronized with the
6074                   --  expansion done by routine Expand_Interface_Conversion
6075 
6076                   if not Comes_From_Source (Expr_N)
6077                     and then Nkind (Expr_N) = N_Explicit_Dereference
6078                     and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
6079                     and then Etype (Original_Node (Expr_N)) = Typ
6080                   then
6081                      Rewrite (Expr_N, Original_Node (Expression (N)));
6082                   end if;
6083 
6084                   --  Avoid expansion of redundant interface conversion
6085 
6086                   if Is_Interface (Etype (Expr_N))
6087                     and then Nkind (Expr_N) = N_Type_Conversion
6088                     and then Etype (Expr_N) = Typ
6089                   then
6090                      Expr_N := Expression (Expr_N);
6091                      Set_Expression (N, Expr_N);
6092                   end if;
6093 
6094                   Obj_Id   := Make_Temporary (Loc, 'D', Expr_N);
6095                   Expr_Typ := Base_Type (Etype (Expr_N));
6096 
6097                   if Is_Class_Wide_Type (Expr_Typ) then
6098                      Expr_Typ := Root_Type (Expr_Typ);
6099                   end if;
6100 
6101                   --  Replace
6102                   --     CW : I'Class := Obj;
6103                   --  by
6104                   --     Tmp : T := Obj;
6105                   --     type Ityp is not null access I'Class;
6106                   --     CW  : I'Class renames Ityp (Tmp.I_Tag'Address).all;
6107 
6108                   if Comes_From_Source (Expr_N)
6109                     and then Nkind (Expr_N) = N_Identifier
6110                     and then not Is_Interface (Expr_Typ)
6111                     and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
6112                     and then (Expr_Typ = Etype (Expr_Typ)
6113                                or else not
6114                                  Is_Variable_Size_Record (Etype (Expr_Typ)))
6115                   then
6116                      --  Copy the object
6117 
6118                      Insert_Action (N,
6119                        Make_Object_Declaration (Loc,
6120                          Defining_Identifier => Obj_Id,
6121                          Object_Definition   =>
6122                            New_Occurrence_Of (Expr_Typ, Loc),
6123                          Expression          => Relocate_Node (Expr_N)));
6124 
6125                      --  Statically reference the tag associated with the
6126                      --  interface
6127 
6128                      Tag_Comp :=
6129                        Make_Selected_Component (Loc,
6130                          Prefix        => New_Occurrence_Of (Obj_Id, Loc),
6131                          Selector_Name =>
6132                            New_Occurrence_Of
6133                              (Find_Interface_Tag (Expr_Typ, Iface), Loc));
6134 
6135                   --  Replace
6136                   --     IW : I'Class := Obj;
6137                   --  by
6138                   --     type Equiv_Record is record ... end record;
6139                   --     implicit subtype CW is <Class_Wide_Subtype>;
6140                   --     Tmp : CW := CW!(Obj);
6141                   --     type Ityp is not null access I'Class;
6142                   --     IW : I'Class renames
6143                   --            Ityp!(Displace (Temp'Address, I'Tag)).all;
6144 
6145                   else
6146                      --  Generate the equivalent record type and update the
6147                      --  subtype indication to reference it.
6148 
6149                      Expand_Subtype_From_Expr
6150                        (N             => N,
6151                         Unc_Type      => Typ,
6152                         Subtype_Indic => Obj_Def,
6153                         Exp           => Expr_N);
6154 
6155                      if not Is_Interface (Etype (Expr_N)) then
6156                         New_Expr := Relocate_Node (Expr_N);
6157 
6158                      --  For interface types we use 'Address which displaces
6159                      --  the pointer to the base of the object (if required)
6160 
6161                      else
6162                         New_Expr :=
6163                           Unchecked_Convert_To (Etype (Obj_Def),
6164                             Make_Explicit_Dereference (Loc,
6165                               Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6166                                 Make_Attribute_Reference (Loc,
6167                                   Prefix => Relocate_Node (Expr_N),
6168                                   Attribute_Name => Name_Address))));
6169                      end if;
6170 
6171                      --  Copy the object
6172 
6173                      if not Is_Limited_Record (Expr_Typ) then
6174                         Insert_Action (N,
6175                           Make_Object_Declaration (Loc,
6176                             Defining_Identifier => Obj_Id,
6177                             Object_Definition   =>
6178                               New_Occurrence_Of (Etype (Obj_Def), Loc),
6179                             Expression => New_Expr));
6180 
6181                      --  Rename limited type object since they cannot be copied
6182                      --  This case occurs when the initialization expression
6183                      --  has been previously expanded into a temporary object.
6184 
6185                      else pragma Assert (not Comes_From_Source (Expr_Q));
6186                         Insert_Action (N,
6187                           Make_Object_Renaming_Declaration (Loc,
6188                             Defining_Identifier => Obj_Id,
6189                             Subtype_Mark        =>
6190                               New_Occurrence_Of (Etype (Obj_Def), Loc),
6191                             Name                =>
6192                               Unchecked_Convert_To
6193                                 (Etype (Obj_Def), New_Expr)));
6194                      end if;
6195 
6196                      --  Dynamically reference the tag associated with the
6197                      --  interface.
6198 
6199                      Tag_Comp :=
6200                        Make_Function_Call (Loc,
6201                          Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
6202                          Parameter_Associations => New_List (
6203                            Make_Attribute_Reference (Loc,
6204                              Prefix => New_Occurrence_Of (Obj_Id, Loc),
6205                              Attribute_Name => Name_Address),
6206                            New_Occurrence_Of
6207                              (Node (First_Elmt (Access_Disp_Table (Iface))),
6208                               Loc)));
6209                   end if;
6210 
6211                   Rewrite (N,
6212                     Make_Object_Renaming_Declaration (Loc,
6213                       Defining_Identifier => Make_Temporary (Loc, 'D'),
6214                       Subtype_Mark        => New_Occurrence_Of (Typ, Loc),
6215                       Name                =>
6216                         Convert_Tag_To_Interface (Typ, Tag_Comp)));
6217 
6218                   --  If the original entity comes from source, then mark the
6219                   --  new entity as needing debug information, even though it's
6220                   --  defined by a generated renaming that does not come from
6221                   --  source, so that Materialize_Entity will be set on the
6222                   --  entity when Debug_Renaming_Declaration is called during
6223                   --  analysis.
6224 
6225                   if Comes_From_Source (Def_Id) then
6226                      Set_Debug_Info_Needed (Defining_Identifier (N));
6227                   end if;
6228 
6229                   Analyze (N, Suppress => All_Checks);
6230 
6231                   --  Replace internal identifier of rewritten node by the
6232                   --  identifier found in the sources. We also have to exchange
6233                   --  entities containing their defining identifiers to ensure
6234                   --  the correct replacement of the object declaration by this
6235                   --  object renaming declaration because these identifiers
6236                   --  were previously added by Enter_Name to the current scope.
6237                   --  We must preserve the homonym chain of the source entity
6238                   --  as well. We must also preserve the kind of the entity,
6239                   --  which may be a constant. Preserve entity chain because
6240                   --  itypes may have been generated already, and the full
6241                   --  chain must be preserved for final freezing. Finally,
6242                   --  preserve Comes_From_Source setting, so that debugging
6243                   --  and cross-referencing information is properly kept, and
6244                   --  preserve source location, to prevent spurious errors when
6245                   --  entities are declared (they must have their own Sloc).
6246 
6247                   declare
6248                      New_Id    : constant Entity_Id := Defining_Identifier (N);
6249                      Next_Temp : constant Entity_Id := Next_Entity (New_Id);
6250                      S_Flag    : constant Boolean   :=
6251                                    Comes_From_Source (Def_Id);
6252 
6253                   begin
6254                      Set_Next_Entity (New_Id, Next_Entity (Def_Id));
6255                      Set_Next_Entity (Def_Id, Next_Temp);
6256 
6257                      Set_Chars   (Defining_Identifier (N), Chars   (Def_Id));
6258                      Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
6259                      Set_Ekind   (Defining_Identifier (N), Ekind   (Def_Id));
6260                      Set_Sloc    (Defining_Identifier (N), Sloc    (Def_Id));
6261 
6262                      Set_Comes_From_Source (Def_Id, False);
6263                      Exchange_Entities (Defining_Identifier (N), Def_Id);
6264                      Set_Comes_From_Source (Def_Id, S_Flag);
6265                   end;
6266                end;
6267             end if;
6268 
6269             return;
6270 
6271          --  Common case of explicit object initialization
6272 
6273          else
6274             --  In most cases, we must check that the initial value meets any
6275             --  constraint imposed by the declared type. However, there is one
6276             --  very important exception to this rule. If the entity has an
6277             --  unconstrained nominal subtype, then it acquired its constraints
6278             --  from the expression in the first place, and not only does this
6279             --  mean that the constraint check is not needed, but an attempt to
6280             --  perform the constraint check can cause order of elaboration
6281             --  problems.
6282 
6283             if not Is_Constr_Subt_For_U_Nominal (Typ) then
6284 
6285                --  If this is an allocator for an aggregate that has been
6286                --  allocated in place, delay checks until assignments are
6287                --  made, because the discriminants are not initialized.
6288 
6289                if Nkind (Expr) = N_Allocator and then No_Initialization (Expr)
6290                then
6291                   null;
6292 
6293                --  Otherwise apply a constraint check now if no prev error
6294 
6295                elsif Nkind (Expr) /= N_Error then
6296                   Apply_Constraint_Check (Expr, Typ);
6297 
6298                   --  Deal with possible range check
6299 
6300                   if Do_Range_Check (Expr) then
6301 
6302                      --  If assignment checks are suppressed, turn off flag
6303 
6304                      if Suppress_Assignment_Checks (N) then
6305                         Set_Do_Range_Check (Expr, False);
6306 
6307                      --  Otherwise generate the range check
6308 
6309                      else
6310                         Generate_Range_Check
6311                           (Expr, Typ, CE_Range_Check_Failed);
6312                      end if;
6313                   end if;
6314                end if;
6315             end if;
6316 
6317             --  If the type is controlled and not inherently limited, then
6318             --  the target is adjusted after the copy and attached to the
6319             --  finalization list. However, no adjustment is done in the case
6320             --  where the object was initialized by a call to a function whose
6321             --  result is built in place, since no copy occurred. (Eventually
6322             --  we plan to support in-place function results for some cases
6323             --  of nonlimited types. ???) Similarly, no adjustment is required
6324             --  if we are going to rewrite the object declaration into a
6325             --  renaming declaration.
6326 
6327             if Needs_Finalization (Typ)
6328               and then not Is_Limited_View (Typ)
6329               and then not Rewrite_As_Renaming
6330             then
6331                Insert_Action_After (Init_After,
6332                  Make_Adjust_Call (
6333                    Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
6334                    Typ     => Base_Typ));
6335             end if;
6336 
6337             --  For tagged types, when an init value is given, the tag has to
6338             --  be re-initialized separately in order to avoid the propagation
6339             --  of a wrong tag coming from a view conversion unless the type
6340             --  is class wide (in this case the tag comes from the init value).
6341             --  Suppress the tag assignment when not Tagged_Type_Expansion
6342             --  because tags are represented implicitly in objects. Ditto for
6343             --  types that are CPP_CLASS, and for initializations that are
6344             --  aggregates, because they have to have the right tag.
6345 
6346             --  The re-assignment of the tag has to be done even if the object
6347             --  is a constant. The assignment must be analyzed after the
6348             --  declaration. If an address clause follows, this is handled as
6349             --  part of the freeze actions for the object, otherwise insert
6350             --  tag assignment here.
6351 
6352             Tag_Assign := Make_Tag_Assignment (N);
6353 
6354             if Present (Tag_Assign) then
6355                if Present (Following_Address_Clause (N)) then
6356                   Ensure_Freeze_Node (Def_Id);
6357 
6358                else
6359                   Insert_Action_After (Init_After, Tag_Assign);
6360                end if;
6361 
6362             --  Handle C++ constructor calls. Note that we do not check that
6363             --  Typ is a tagged type since the equivalent Ada type of a C++
6364             --  class that has no virtual methods is an untagged limited
6365             --  record type.
6366 
6367             elsif Is_CPP_Constructor_Call (Expr) then
6368 
6369                --  The call to the initialization procedure does NOT freeze the
6370                --  object being initialized.
6371 
6372                Id_Ref := New_Occurrence_Of (Def_Id, Loc);
6373                Set_Must_Not_Freeze (Id_Ref);
6374                Set_Assignment_OK (Id_Ref);
6375 
6376                Insert_Actions_After (Init_After,
6377                  Build_Initialization_Call (Loc, Id_Ref, Typ,
6378                    Constructor_Ref => Expr));
6379 
6380                --  We remove here the original call to the constructor
6381                --  to avoid its management in the backend
6382 
6383                Set_Expression (N, Empty);
6384                return;
6385 
6386             --  Handle initialization of limited tagged types
6387 
6388             elsif Is_Tagged_Type (Typ)
6389               and then Is_Class_Wide_Type (Typ)
6390               and then Is_Limited_Record (Typ)
6391               and then not Is_Limited_Interface (Typ)
6392             then
6393                --  Given that the type is limited we cannot perform a copy. If
6394                --  Expr_Q is the reference to a variable we mark the variable
6395                --  as OK_To_Rename to expand this declaration into a renaming
6396                --  declaration (see bellow).
6397 
6398                if Is_Entity_Name (Expr_Q) then
6399                   Set_OK_To_Rename (Entity (Expr_Q));
6400 
6401                --  If we cannot convert the expression into a renaming we must
6402                --  consider it an internal error because the backend does not
6403                --  have support to handle it.
6404 
6405                else
6406                   pragma Assert (False);
6407                   raise Program_Error;
6408                end if;
6409 
6410             --  For discrete types, set the Is_Known_Valid flag if the
6411             --  initializing value is known to be valid. Only do this for
6412             --  source assignments, since otherwise we can end up turning
6413             --  on the known valid flag prematurely from inserted code.
6414 
6415             elsif Comes_From_Source (N)
6416               and then Is_Discrete_Type (Typ)
6417               and then Expr_Known_Valid (Expr)
6418             then
6419                Set_Is_Known_Valid (Def_Id);
6420 
6421             elsif Is_Access_Type (Typ) then
6422 
6423                --  For access types set the Is_Known_Non_Null flag if the
6424                --  initializing value is known to be non-null. We can also set
6425                --  Can_Never_Be_Null if this is a constant.
6426 
6427                if Known_Non_Null (Expr) then
6428                   Set_Is_Known_Non_Null (Def_Id, True);
6429 
6430                   if Constant_Present (N) then
6431                      Set_Can_Never_Be_Null (Def_Id);
6432                   end if;
6433                end if;
6434             end if;
6435 
6436             --  If validity checking on copies, validate initial expression.
6437             --  But skip this if declaration is for a generic type, since it
6438             --  makes no sense to validate generic types. Not clear if this
6439             --  can happen for legal programs, but it definitely can arise
6440             --  from previous instantiation errors.
6441 
6442             if Validity_Checks_On
6443               and then Comes_From_Source (N)
6444               and then Validity_Check_Copies
6445               and then not Is_Generic_Type (Etype (Def_Id))
6446             then
6447                Ensure_Valid (Expr);
6448                Set_Is_Known_Valid (Def_Id);
6449             end if;
6450          end if;
6451 
6452          --  Cases where the back end cannot handle the initialization directly
6453          --  In such cases, we expand an assignment that will be appropriately
6454          --  handled by Expand_N_Assignment_Statement.
6455 
6456          --  The exclusion of the unconstrained case is wrong, but for now it
6457          --  is too much trouble ???
6458 
6459          if (Is_Possibly_Unaligned_Slice (Expr)
6460               or else (Is_Possibly_Unaligned_Object (Expr)
6461                         and then not Represented_As_Scalar (Etype (Expr))))
6462            and then not (Is_Array_Type (Etype (Expr))
6463                           and then not Is_Constrained (Etype (Expr)))
6464          then
6465             declare
6466                Stat : constant Node_Id :=
6467                        Make_Assignment_Statement (Loc,
6468                          Name       => New_Occurrence_Of (Def_Id, Loc),
6469                          Expression => Relocate_Node (Expr));
6470             begin
6471                Set_Expression (N, Empty);
6472                Set_No_Initialization (N);
6473                Set_Assignment_OK (Name (Stat));
6474                Set_No_Ctrl_Actions (Stat);
6475                Insert_After_And_Analyze (Init_After, Stat);
6476             end;
6477          end if;
6478       end if;
6479 
6480       if Nkind (Obj_Def) = N_Access_Definition
6481         and then not Is_Local_Anonymous_Access (Etype (Def_Id))
6482       then
6483          --  An Ada 2012 stand-alone object of an anonymous access type
6484 
6485          declare
6486             Loc : constant Source_Ptr := Sloc (N);
6487 
6488             Level : constant Entity_Id :=
6489                       Make_Defining_Identifier (Sloc (N),
6490                         Chars =>
6491                           New_External_Name (Chars (Def_Id), Suffix => "L"));
6492 
6493             Level_Expr : Node_Id;
6494             Level_Decl : Node_Id;
6495 
6496          begin
6497             Set_Ekind (Level, Ekind (Def_Id));
6498             Set_Etype (Level, Standard_Natural);
6499             Set_Scope (Level, Scope (Def_Id));
6500 
6501             if No (Expr) then
6502 
6503                --  Set accessibility level of null
6504 
6505                Level_Expr :=
6506                  Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
6507 
6508             else
6509                Level_Expr := Dynamic_Accessibility_Level (Expr);
6510             end if;
6511 
6512             Level_Decl :=
6513               Make_Object_Declaration (Loc,
6514                 Defining_Identifier => Level,
6515                 Object_Definition   =>
6516                   New_Occurrence_Of (Standard_Natural, Loc),
6517                 Expression          => Level_Expr,
6518                 Constant_Present    => Constant_Present (N),
6519                 Has_Init_Expression => True);
6520 
6521             Insert_Action_After (Init_After, Level_Decl);
6522 
6523             Set_Extra_Accessibility (Def_Id, Level);
6524          end;
6525       end if;
6526 
6527       --  If the object is default initialized and its type is subject to
6528       --  pragma Default_Initial_Condition, add a runtime check to verify
6529       --  the assumption of the pragma (SPARK RM 7.3.3). Generate:
6530 
6531       --    <Base_Typ>Default_Init_Cond (<Base_Typ> (Def_Id));
6532 
6533       --  Note that the check is generated for source objects only
6534 
6535       if Comes_From_Source (Def_Id)
6536         and then (Has_Default_Init_Cond (Typ)
6537                    or else Has_Inherited_Default_Init_Cond (Typ))
6538         and then not Has_Init_Expression (N)
6539         and then Present (Default_Init_Cond_Procedure (Typ))
6540       then
6541          declare
6542             DIC_Call : constant Node_Id :=
6543                          Build_Default_Init_Cond_Call (Loc, Def_Id, Typ);
6544          begin
6545             if Present (Next_N) then
6546                Insert_Before_And_Analyze (Next_N, DIC_Call);
6547 
6548             --  The object declaration is the last node in a declarative or a
6549             --  statement list.
6550 
6551             else
6552                Append_To (List_Containing (N), DIC_Call);
6553                Analyze (DIC_Call);
6554             end if;
6555          end;
6556       end if;
6557 
6558       --  Final transformation - turn the object declaration into a renaming
6559       --  if appropriate. If this is the completion of a deferred constant
6560       --  declaration, then this transformation generates what would be
6561       --  illegal code if written by hand, but that's OK.
6562 
6563       if Present (Expr) then
6564          if Rewrite_As_Renaming then
6565             Rewrite (N,
6566               Make_Object_Renaming_Declaration (Loc,
6567                 Defining_Identifier => Defining_Identifier (N),
6568                 Subtype_Mark        => Obj_Def,
6569                 Name                => Expr_Q));
6570 
6571             --  We do not analyze this renaming declaration, because all its
6572             --  components have already been analyzed, and if we were to go
6573             --  ahead and analyze it, we would in effect be trying to generate
6574             --  another declaration of X, which won't do.
6575 
6576             Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
6577             Set_Analyzed (N);
6578 
6579             --  We do need to deal with debug issues for this renaming
6580 
6581             --  First, if entity comes from source, then mark it as needing
6582             --  debug information, even though it is defined by a generated
6583             --  renaming that does not come from source.
6584 
6585             if Comes_From_Source (Defining_Identifier (N)) then
6586                Set_Debug_Info_Needed (Defining_Identifier (N));
6587             end if;
6588 
6589             --  Now call the routine to generate debug info for the renaming
6590 
6591             declare
6592                Decl : constant Node_Id := Debug_Renaming_Declaration (N);
6593             begin
6594                if Present (Decl) then
6595                   Insert_Action (N, Decl);
6596                end if;
6597             end;
6598          end if;
6599       end if;
6600 
6601    --  Exception on library entity not available
6602 
6603    exception
6604       when RE_Not_Available =>
6605          return;
6606    end Expand_N_Object_Declaration;
6607 
6608    ---------------------------------
6609    -- Expand_N_Subtype_Indication --
6610    ---------------------------------
6611 
6612    --  Add a check on the range of the subtype. The static case is partially
6613    --  duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
6614    --  to check here for the static case in order to avoid generating
6615    --  extraneous expanded code. Also deal with validity checking.
6616 
6617    procedure Expand_N_Subtype_Indication (N : Node_Id) is
6618       Ran : constant Node_Id   := Range_Expression (Constraint (N));
6619       Typ : constant Entity_Id := Entity (Subtype_Mark (N));
6620 
6621    begin
6622       if Nkind (Constraint (N)) = N_Range_Constraint then
6623          Validity_Check_Range (Range_Expression (Constraint (N)));
6624       end if;
6625 
6626       if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
6627          Apply_Range_Check (Ran, Typ);
6628       end if;
6629    end Expand_N_Subtype_Indication;
6630 
6631    ---------------------------
6632    -- Expand_N_Variant_Part --
6633    ---------------------------
6634 
6635    --  Note: this procedure no longer has any effect. It used to be that we
6636    --  would replace the choices in the last variant by a when others, and
6637    --  also expanded static predicates in variant choices here, but both of
6638    --  those activities were being done too early, since we can't check the
6639    --  choices until the statically predicated subtypes are frozen, which can
6640    --  happen as late as the free point of the record, and we can't change the
6641    --  last choice to an others before checking the choices, which is now done
6642    --  at the freeze point of the record.
6643 
6644    procedure Expand_N_Variant_Part (N : Node_Id) is
6645    begin
6646       null;
6647    end Expand_N_Variant_Part;
6648 
6649    ---------------------------------
6650    -- Expand_Previous_Access_Type --
6651    ---------------------------------
6652 
6653    procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
6654       Ptr_Typ : Entity_Id;
6655 
6656    begin
6657       --  Find all access types in the current scope whose designated type is
6658       --  Def_Id and build master renamings for them.
6659 
6660       Ptr_Typ := First_Entity (Current_Scope);
6661       while Present (Ptr_Typ) loop
6662          if Is_Access_Type (Ptr_Typ)
6663            and then Designated_Type (Ptr_Typ) = Def_Id
6664            and then No (Master_Id (Ptr_Typ))
6665          then
6666             --  Ensure that the designated type has a master
6667 
6668             Build_Master_Entity (Def_Id);
6669 
6670             --  Private and incomplete types complicate the insertion of master
6671             --  renamings because the access type may precede the full view of
6672             --  the designated type. For this reason, the master renamings are
6673             --  inserted relative to the designated type.
6674 
6675             Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
6676          end if;
6677 
6678          Next_Entity (Ptr_Typ);
6679       end loop;
6680    end Expand_Previous_Access_Type;
6681 
6682    -----------------------------
6683    -- Expand_Record_Extension --
6684    -----------------------------
6685 
6686    --  Add a field _parent at the beginning of the record extension. This is
6687    --  used to implement inheritance. Here are some examples of expansion:
6688 
6689    --  1. no discriminants
6690    --      type T2 is new T1 with null record;
6691    --   gives
6692    --      type T2 is new T1 with record
6693    --        _Parent : T1;
6694    --      end record;
6695 
6696    --  2. renamed discriminants
6697    --    type T2 (B, C : Int) is new T1 (A => B) with record
6698    --       _Parent : T1 (A => B);
6699    --       D : Int;
6700    --    end;
6701 
6702    --  3. inherited discriminants
6703    --    type T2 is new T1 with record -- discriminant A inherited
6704    --       _Parent : T1 (A);
6705    --       D : Int;
6706    --    end;
6707 
6708    procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
6709       Indic        : constant Node_Id    := Subtype_Indication (Def);
6710       Loc          : constant Source_Ptr := Sloc (Def);
6711       Rec_Ext_Part : Node_Id             := Record_Extension_Part (Def);
6712       Par_Subtype  : Entity_Id;
6713       Comp_List    : Node_Id;
6714       Comp_Decl    : Node_Id;
6715       Parent_N     : Node_Id;
6716       D            : Entity_Id;
6717       List_Constr  : constant List_Id    := New_List;
6718 
6719    begin
6720       --  Expand_Record_Extension is called directly from the semantics, so
6721       --  we must check to see whether expansion is active before proceeding,
6722       --  because this affects the visibility of selected components in bodies
6723       --  of instances.
6724 
6725       if not Expander_Active then
6726          return;
6727       end if;
6728 
6729       --  This may be a derivation of an untagged private type whose full
6730       --  view is tagged, in which case the Derived_Type_Definition has no
6731       --  extension part. Build an empty one now.
6732 
6733       if No (Rec_Ext_Part) then
6734          Rec_Ext_Part :=
6735            Make_Record_Definition (Loc,
6736              End_Label      => Empty,
6737              Component_List => Empty,
6738              Null_Present   => True);
6739 
6740          Set_Record_Extension_Part (Def, Rec_Ext_Part);
6741          Mark_Rewrite_Insertion (Rec_Ext_Part);
6742       end if;
6743 
6744       Comp_List := Component_List (Rec_Ext_Part);
6745 
6746       Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
6747 
6748       --  If the derived type inherits its discriminants the type of the
6749       --  _parent field must be constrained by the inherited discriminants
6750 
6751       if Has_Discriminants (T)
6752         and then Nkind (Indic) /= N_Subtype_Indication
6753         and then not Is_Constrained (Entity (Indic))
6754       then
6755          D := First_Discriminant (T);
6756          while Present (D) loop
6757             Append_To (List_Constr, New_Occurrence_Of (D, Loc));
6758             Next_Discriminant (D);
6759          end loop;
6760 
6761          Par_Subtype :=
6762            Process_Subtype (
6763              Make_Subtype_Indication (Loc,
6764                Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
6765                Constraint   =>
6766                  Make_Index_Or_Discriminant_Constraint (Loc,
6767                    Constraints => List_Constr)),
6768              Def);
6769 
6770       --  Otherwise the original subtype_indication is just what is needed
6771 
6772       else
6773          Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
6774       end if;
6775 
6776       Set_Parent_Subtype (T, Par_Subtype);
6777 
6778       Comp_Decl :=
6779         Make_Component_Declaration (Loc,
6780           Defining_Identifier => Parent_N,
6781           Component_Definition =>
6782             Make_Component_Definition (Loc,
6783               Aliased_Present => False,
6784               Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
6785 
6786       if Null_Present (Rec_Ext_Part) then
6787          Set_Component_List (Rec_Ext_Part,
6788            Make_Component_List (Loc,
6789              Component_Items => New_List (Comp_Decl),
6790              Variant_Part => Empty,
6791              Null_Present => False));
6792          Set_Null_Present (Rec_Ext_Part, False);
6793 
6794       elsif Null_Present (Comp_List)
6795         or else Is_Empty_List (Component_Items (Comp_List))
6796       then
6797          Set_Component_Items (Comp_List, New_List (Comp_Decl));
6798          Set_Null_Present (Comp_List, False);
6799 
6800       else
6801          Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
6802       end if;
6803 
6804       Analyze (Comp_Decl);
6805    end Expand_Record_Extension;
6806 
6807    ------------------------
6808    -- Expand_Tagged_Root --
6809    ------------------------
6810 
6811    procedure Expand_Tagged_Root (T : Entity_Id) is
6812       Def       : constant Node_Id := Type_Definition (Parent (T));
6813       Comp_List : Node_Id;
6814       Comp_Decl : Node_Id;
6815       Sloc_N    : Source_Ptr;
6816 
6817    begin
6818       if Null_Present (Def) then
6819          Set_Component_List (Def,
6820            Make_Component_List (Sloc (Def),
6821              Component_Items => Empty_List,
6822              Variant_Part => Empty,
6823              Null_Present => True));
6824       end if;
6825 
6826       Comp_List := Component_List (Def);
6827 
6828       if Null_Present (Comp_List)
6829         or else Is_Empty_List (Component_Items (Comp_List))
6830       then
6831          Sloc_N := Sloc (Comp_List);
6832       else
6833          Sloc_N := Sloc (First (Component_Items (Comp_List)));
6834       end if;
6835 
6836       Comp_Decl :=
6837         Make_Component_Declaration (Sloc_N,
6838           Defining_Identifier => First_Tag_Component (T),
6839           Component_Definition =>
6840             Make_Component_Definition (Sloc_N,
6841               Aliased_Present => False,
6842               Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
6843 
6844       if Null_Present (Comp_List)
6845         or else Is_Empty_List (Component_Items (Comp_List))
6846       then
6847          Set_Component_Items (Comp_List, New_List (Comp_Decl));
6848          Set_Null_Present (Comp_List, False);
6849 
6850       else
6851          Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
6852       end if;
6853 
6854       --  We don't Analyze the whole expansion because the tag component has
6855       --  already been analyzed previously. Here we just insure that the tree
6856       --  is coherent with the semantic decoration
6857 
6858       Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
6859 
6860    exception
6861       when RE_Not_Available =>
6862          return;
6863    end Expand_Tagged_Root;
6864 
6865    ------------------------------
6866    -- Freeze_Stream_Operations --
6867    ------------------------------
6868 
6869    procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
6870       Names     : constant array (1 .. 4) of TSS_Name_Type :=
6871                     (TSS_Stream_Input,
6872                      TSS_Stream_Output,
6873                      TSS_Stream_Read,
6874                      TSS_Stream_Write);
6875       Stream_Op : Entity_Id;
6876 
6877    begin
6878       --  Primitive operations of tagged types are frozen when the dispatch
6879       --  table is constructed.
6880 
6881       if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then
6882          return;
6883       end if;
6884 
6885       for J in Names'Range loop
6886          Stream_Op := TSS (Typ, Names (J));
6887 
6888          if Present (Stream_Op)
6889            and then Is_Subprogram (Stream_Op)
6890            and then Nkind (Unit_Declaration_Node (Stream_Op)) =
6891                                                     N_Subprogram_Declaration
6892            and then not Is_Frozen (Stream_Op)
6893          then
6894             Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
6895          end if;
6896       end loop;
6897    end Freeze_Stream_Operations;
6898 
6899    -----------------
6900    -- Freeze_Type --
6901    -----------------
6902 
6903    --  Full type declarations are expanded at the point at which the type is
6904    --  frozen. The formal N is the Freeze_Node for the type. Any statements or
6905    --  declarations generated by the freezing (e.g. the procedure generated
6906    --  for initialization) are chained in the Actions field list of the freeze
6907    --  node using Append_Freeze_Actions.
6908 
6909    function Freeze_Type (N : Node_Id) return Boolean is
6910       procedure Process_RACW_Types (Typ : Entity_Id);
6911       --  Validate and generate stubs for all RACW types associated with type
6912       --  Typ.
6913 
6914       procedure Process_Pending_Access_Types (Typ : Entity_Id);
6915       --  Associate type Typ's Finalize_Address primitive with the finalization
6916       --  masters of pending access-to-Typ types.
6917 
6918       ------------------------
6919       -- Process_RACW_Types --
6920       ------------------------
6921 
6922       procedure Process_RACW_Types (Typ : Entity_Id) is
6923          List : constant Elist_Id := Access_Types_To_Process (N);
6924          E    : Elmt_Id;
6925          Seen : Boolean := False;
6926 
6927       begin
6928          if Present (List) then
6929             E := First_Elmt (List);
6930             while Present (E) loop
6931                if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
6932                   Validate_RACW_Primitives (Node (E));
6933                   Seen := True;
6934                end if;
6935 
6936                Next_Elmt (E);
6937             end loop;
6938          end if;
6939 
6940          --  If there are RACWs designating this type, make stubs now
6941 
6942          if Seen then
6943             Remote_Types_Tagged_Full_View_Encountered (Typ);
6944          end if;
6945       end Process_RACW_Types;
6946 
6947       ----------------------------------
6948       -- Process_Pending_Access_Types --
6949       ----------------------------------
6950 
6951       procedure Process_Pending_Access_Types (Typ : Entity_Id) is
6952          E : Elmt_Id;
6953 
6954       begin
6955          --  Finalize_Address is not generated in CodePeer mode because the
6956          --  body contains address arithmetic. This processing is disabled.
6957 
6958          if CodePeer_Mode then
6959             null;
6960 
6961          --  Certain itypes are generated for contexts that cannot allocate
6962          --  objects and should not set primitive Finalize_Address.
6963 
6964          elsif Is_Itype (Typ)
6965            and then Nkind (Associated_Node_For_Itype (Typ)) =
6966                       N_Explicit_Dereference
6967          then
6968             null;
6969 
6970          --  When an access type is declared after the incomplete view of a
6971          --  Taft-amendment type, the access type is considered pending in
6972          --  case the full view of the Taft-amendment type is controlled. If
6973          --  this is indeed the case, associate the Finalize_Address routine
6974          --  of the full view with the finalization masters of all pending
6975          --  access types. This scenario applies to anonymous access types as
6976          --  well.
6977 
6978          elsif Needs_Finalization (Typ)
6979            and then Present (Pending_Access_Types (Typ))
6980          then
6981             E := First_Elmt (Pending_Access_Types (Typ));
6982             while Present (E) loop
6983 
6984                --  Generate:
6985                --    Set_Finalize_Address
6986                --      (Ptr_Typ, <Typ>FD'Unrestricted_Access);
6987 
6988                Append_Freeze_Action (Typ,
6989                  Make_Set_Finalize_Address_Call
6990                    (Loc     => Sloc (N),
6991                     Ptr_Typ => Node (E)));
6992 
6993                Next_Elmt (E);
6994             end loop;
6995          end if;
6996       end Process_Pending_Access_Types;
6997 
6998       --  Local variables
6999 
7000       Def_Id : constant Entity_Id := Entity (N);
7001       Result : Boolean := False;
7002 
7003       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
7004 
7005    --  Start of processing for Freeze_Type
7006 
7007    begin
7008       --  The type being frozen may be subject to pragma Ghost. Set the mode
7009       --  now to ensure that any nodes generated during freezing are properly
7010       --  marked as Ghost.
7011 
7012       Set_Ghost_Mode (N, Def_Id);
7013 
7014       --  Process any remote access-to-class-wide types designating the type
7015       --  being frozen.
7016 
7017       Process_RACW_Types (Def_Id);
7018 
7019       --  Freeze processing for record types
7020 
7021       if Is_Record_Type (Def_Id) then
7022          if Ekind (Def_Id) = E_Record_Type then
7023             Expand_Freeze_Record_Type (N);
7024          elsif Is_Class_Wide_Type (Def_Id) then
7025             Expand_Freeze_Class_Wide_Type (N);
7026          end if;
7027 
7028       --  Freeze processing for array types
7029 
7030       elsif Is_Array_Type (Def_Id) then
7031          Expand_Freeze_Array_Type (N);
7032 
7033       --  Freeze processing for access types
7034 
7035       --  For pool-specific access types, find out the pool object used for
7036       --  this type, needs actual expansion of it in some cases. Here are the
7037       --  different cases :
7038 
7039       --  1. Rep Clause "for Def_Id'Storage_Size use 0;"
7040       --      ---> don't use any storage pool
7041 
7042       --  2. Rep Clause : for Def_Id'Storage_Size use Expr.
7043       --     Expand:
7044       --      Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
7045 
7046       --  3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
7047       --      ---> Storage Pool is the specified one
7048 
7049       --  See GNAT Pool packages in the Run-Time for more details
7050 
7051       elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then
7052          declare
7053             Loc        : constant Source_Ptr := Sloc (N);
7054             Desig_Type : constant Entity_Id  := Designated_Type (Def_Id);
7055 
7056             Freeze_Action_Typ : Entity_Id;
7057             Pool_Object       : Entity_Id;
7058 
7059          begin
7060             --  Case 1
7061 
7062             --    Rep Clause "for Def_Id'Storage_Size use 0;"
7063             --    ---> don't use any storage pool
7064 
7065             if No_Pool_Assigned (Def_Id) then
7066                null;
7067 
7068             --  Case 2
7069 
7070             --    Rep Clause : for Def_Id'Storage_Size use Expr.
7071             --    ---> Expand:
7072             --           Def_Id__Pool : Stack_Bounded_Pool
7073             --                            (Expr, DT'Size, DT'Alignment);
7074 
7075             elsif Has_Storage_Size_Clause (Def_Id) then
7076                declare
7077                   DT_Align : Node_Id;
7078                   DT_Size  : Node_Id;
7079 
7080                begin
7081                   --  For unconstrained composite types we give a size of zero
7082                   --  so that the pool knows that it needs a special algorithm
7083                   --  for variable size object allocation.
7084 
7085                   if Is_Composite_Type (Desig_Type)
7086                     and then not Is_Constrained (Desig_Type)
7087                   then
7088                      DT_Size  := Make_Integer_Literal (Loc, 0);
7089                      DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment);
7090 
7091                   else
7092                      DT_Size :=
7093                        Make_Attribute_Reference (Loc,
7094                          Prefix         => New_Occurrence_Of (Desig_Type, Loc),
7095                          Attribute_Name => Name_Max_Size_In_Storage_Elements);
7096 
7097                      DT_Align :=
7098                        Make_Attribute_Reference (Loc,
7099                          Prefix         => New_Occurrence_Of (Desig_Type, Loc),
7100                          Attribute_Name => Name_Alignment);
7101                   end if;
7102 
7103                   Pool_Object :=
7104                     Make_Defining_Identifier (Loc,
7105                       Chars => New_External_Name (Chars (Def_Id), 'P'));
7106 
7107                   --  We put the code associated with the pools in the entity
7108                   --  that has the later freeze node, usually the access type
7109                   --  but it can also be the designated_type; because the pool
7110                   --  code requires both those types to be frozen
7111 
7112                   if Is_Frozen (Desig_Type)
7113                     and then (No (Freeze_Node (Desig_Type))
7114                                or else Analyzed (Freeze_Node (Desig_Type)))
7115                   then
7116                      Freeze_Action_Typ := Def_Id;
7117 
7118                   --  A Taft amendment type cannot get the freeze actions
7119                   --  since the full view is not there.
7120 
7121                   elsif Is_Incomplete_Or_Private_Type (Desig_Type)
7122                     and then No (Full_View (Desig_Type))
7123                   then
7124                      Freeze_Action_Typ := Def_Id;
7125 
7126                   else
7127                      Freeze_Action_Typ := Desig_Type;
7128                   end if;
7129 
7130                   Append_Freeze_Action (Freeze_Action_Typ,
7131                     Make_Object_Declaration (Loc,
7132                       Defining_Identifier => Pool_Object,
7133                       Object_Definition   =>
7134                         Make_Subtype_Indication (Loc,
7135                           Subtype_Mark =>
7136                             New_Occurrence_Of
7137                               (RTE (RE_Stack_Bounded_Pool), Loc),
7138 
7139                           Constraint   =>
7140                             Make_Index_Or_Discriminant_Constraint (Loc,
7141                               Constraints => New_List (
7142 
7143                                 --  First discriminant is the Pool Size
7144 
7145                                 New_Occurrence_Of (
7146                                   Storage_Size_Variable (Def_Id), Loc),
7147 
7148                                 --  Second discriminant is the element size
7149 
7150                                 DT_Size,
7151 
7152                                 --  Third discriminant is the alignment
7153 
7154                                 DT_Align)))));
7155                end;
7156 
7157                Set_Associated_Storage_Pool (Def_Id, Pool_Object);
7158 
7159             --  Case 3
7160 
7161             --    Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
7162             --    ---> Storage Pool is the specified one
7163 
7164             --  When compiling in Ada 2012 mode, ensure that the accessibility
7165             --  level of the subpool access type is not deeper than that of the
7166             --  pool_with_subpools.
7167 
7168             elsif Ada_Version >= Ada_2012
7169               and then Present (Associated_Storage_Pool (Def_Id))
7170 
7171               --  Omit this check for the case of a configurable run-time that
7172               --  does not provide package System.Storage_Pools.Subpools.
7173 
7174               and then RTE_Available (RE_Root_Storage_Pool_With_Subpools)
7175             then
7176                declare
7177                   Loc   : constant Source_Ptr := Sloc (Def_Id);
7178                   Pool  : constant Entity_Id :=
7179                             Associated_Storage_Pool (Def_Id);
7180                   RSPWS : constant Entity_Id :=
7181                             RTE (RE_Root_Storage_Pool_With_Subpools);
7182 
7183                begin
7184                   --  It is known that the accessibility level of the access
7185                   --  type is deeper than that of the pool.
7186 
7187                   if Type_Access_Level (Def_Id) > Object_Access_Level (Pool)
7188                     and then not Accessibility_Checks_Suppressed (Def_Id)
7189                     and then not Accessibility_Checks_Suppressed (Pool)
7190                   then
7191                      --  Static case: the pool is known to be a descendant of
7192                      --  Root_Storage_Pool_With_Subpools.
7193 
7194                      if Is_Ancestor (RSPWS, Etype (Pool)) then
7195                         Error_Msg_N
7196                           ("??subpool access type has deeper accessibility "
7197                            & "level than pool", Def_Id);
7198 
7199                         Append_Freeze_Action (Def_Id,
7200                           Make_Raise_Program_Error (Loc,
7201                             Reason => PE_Accessibility_Check_Failed));
7202 
7203                      --  Dynamic case: when the pool is of a class-wide type,
7204                      --  it may or may not support subpools depending on the
7205                      --  path of derivation. Generate:
7206 
7207                      --    if Def_Id in RSPWS'Class then
7208                      --       raise Program_Error;
7209                      --    end if;
7210 
7211                      elsif Is_Class_Wide_Type (Etype (Pool)) then
7212                         Append_Freeze_Action (Def_Id,
7213                           Make_If_Statement (Loc,
7214                             Condition       =>
7215                               Make_In (Loc,
7216                                 Left_Opnd  => New_Occurrence_Of (Pool, Loc),
7217                                 Right_Opnd =>
7218                                   New_Occurrence_Of
7219                                     (Class_Wide_Type (RSPWS), Loc)),
7220 
7221                             Then_Statements => New_List (
7222                               Make_Raise_Program_Error (Loc,
7223                                 Reason => PE_Accessibility_Check_Failed))));
7224                      end if;
7225                   end if;
7226                end;
7227             end if;
7228 
7229             --  For access-to-controlled types (including class-wide types and
7230             --  Taft-amendment types, which potentially have controlled
7231             --  components), expand the list controller object that will store
7232             --  the dynamically allocated objects. Don't do this transformation
7233             --  for expander-generated access types, but do it for types that
7234             --  are the full view of types derived from other private types.
7235             --  Also suppress the list controller in the case of a designated
7236             --  type with convention Java, since this is used when binding to
7237             --  Java API specs, where there's no equivalent of a finalization
7238             --  list and we don't want to pull in the finalization support if
7239             --  not needed.
7240 
7241             if not Comes_From_Source (Def_Id)
7242               and then not Has_Private_Declaration (Def_Id)
7243             then
7244                null;
7245 
7246             --  An exception is made for types defined in the run-time because
7247             --  Ada.Tags.Tag itself is such a type and cannot afford this
7248             --  unnecessary overhead that would generates a loop in the
7249             --  expansion scheme. Another exception is if Restrictions
7250             --  (No_Finalization) is active, since then we know nothing is
7251             --  controlled.
7252 
7253             elsif Restriction_Active (No_Finalization)
7254               or else In_Runtime (Def_Id)
7255             then
7256                null;
7257 
7258             --  Create a finalization master for an access-to-controlled type
7259             --  or an access-to-incomplete type. It is assumed that the full
7260             --  view will be controlled.
7261 
7262             elsif Needs_Finalization (Desig_Type)
7263               or else (Is_Incomplete_Type (Desig_Type)
7264                         and then No (Full_View (Desig_Type)))
7265             then
7266                Build_Finalization_Master (Def_Id);
7267 
7268             --  Create a finalization master when the designated type contains
7269             --  a private component. It is assumed that the full view will be
7270             --  controlled.
7271 
7272             elsif Has_Private_Component (Desig_Type) then
7273                Build_Finalization_Master
7274                  (Typ            => Def_Id,
7275                   For_Private    => True,
7276                   Context_Scope  => Scope (Def_Id),
7277                   Insertion_Node => Declaration_Node (Desig_Type));
7278             end if;
7279          end;
7280 
7281       --  Freeze processing for enumeration types
7282 
7283       elsif Ekind (Def_Id) = E_Enumeration_Type then
7284 
7285          --  We only have something to do if we have a non-standard
7286          --  representation (i.e. at least one literal whose pos value
7287          --  is not the same as its representation)
7288 
7289          if Has_Non_Standard_Rep (Def_Id) then
7290             Expand_Freeze_Enumeration_Type (N);
7291          end if;
7292 
7293       --  Private types that are completed by a derivation from a private
7294       --  type have an internally generated full view, that needs to be
7295       --  frozen. This must be done explicitly because the two views share
7296       --  the freeze node, and the underlying full view is not visible when
7297       --  the freeze node is analyzed.
7298 
7299       elsif Is_Private_Type (Def_Id)
7300         and then Is_Derived_Type (Def_Id)
7301         and then Present (Full_View (Def_Id))
7302         and then Is_Itype (Full_View (Def_Id))
7303         and then Has_Private_Declaration (Full_View (Def_Id))
7304         and then Freeze_Node (Full_View (Def_Id)) = N
7305       then
7306          Set_Entity (N, Full_View (Def_Id));
7307          Result := Freeze_Type (N);
7308          Set_Entity (N, Def_Id);
7309 
7310       --  All other types require no expander action. There are such cases
7311       --  (e.g. task types and protected types). In such cases, the freeze
7312       --  nodes are there for use by Gigi.
7313 
7314       end if;
7315 
7316       --  Complete the initialization of all pending access types' finalization
7317       --  masters now that the designated type has been is frozen and primitive
7318       --  Finalize_Address generated.
7319 
7320       Process_Pending_Access_Types (Def_Id);
7321       Freeze_Stream_Operations (N, Def_Id);
7322 
7323       --  Generate the [spec and] body of the invariant procedure tasked with
7324       --  the runtime verification of all invariants that pertain to the type.
7325       --  This includes invariants on the partial and full view, inherited
7326       --  class-wide invariants from parent types or interfaces, and invariants
7327       --  on array elements or record components.
7328 
7329       if Has_Invariants (Def_Id) then
7330          Build_Invariant_Procedure_Body (Def_Id);
7331       end if;
7332 
7333       Ghost_Mode := Save_Ghost_Mode;
7334       return Result;
7335 
7336    exception
7337       when RE_Not_Available =>
7338          Ghost_Mode := Save_Ghost_Mode;
7339          return False;
7340    end Freeze_Type;
7341 
7342    -------------------------
7343    -- Get_Simple_Init_Val --
7344    -------------------------
7345 
7346    function Get_Simple_Init_Val
7347      (T    : Entity_Id;
7348       N    : Node_Id;
7349       Size : Uint := No_Uint) return Node_Id
7350    is
7351       Loc    : constant Source_Ptr := Sloc (N);
7352       Val    : Node_Id;
7353       Result : Node_Id;
7354       Val_RE : RE_Id;
7355 
7356       Size_To_Use : Uint;
7357       --  This is the size to be used for computation of the appropriate
7358       --  initial value for the Normalize_Scalars and Initialize_Scalars case.
7359 
7360       IV_Attribute : constant Boolean :=
7361                        Nkind (N) = N_Attribute_Reference
7362                          and then Attribute_Name (N) = Name_Invalid_Value;
7363 
7364       Lo_Bound : Uint;
7365       Hi_Bound : Uint;
7366       --  These are the values computed by the procedure Check_Subtype_Bounds
7367 
7368       procedure Check_Subtype_Bounds;
7369       --  This procedure examines the subtype T, and its ancestor subtypes and
7370       --  derived types to determine the best known information about the
7371       --  bounds of the subtype. After the call Lo_Bound is set either to
7372       --  No_Uint if no information can be determined, or to a value which
7373       --  represents a known low bound, i.e. a valid value of the subtype can
7374       --  not be less than this value. Hi_Bound is similarly set to a known
7375       --  high bound (valid value cannot be greater than this).
7376 
7377       --------------------------
7378       -- Check_Subtype_Bounds --
7379       --------------------------
7380 
7381       procedure Check_Subtype_Bounds is
7382          ST1  : Entity_Id;
7383          ST2  : Entity_Id;
7384          Lo   : Node_Id;
7385          Hi   : Node_Id;
7386          Loval : Uint;
7387          Hival : Uint;
7388 
7389       begin
7390          Lo_Bound := No_Uint;
7391          Hi_Bound := No_Uint;
7392 
7393          --  Loop to climb ancestor subtypes and derived types
7394 
7395          ST1 := T;
7396          loop
7397             if not Is_Discrete_Type (ST1) then
7398                return;
7399             end if;
7400 
7401             Lo := Type_Low_Bound (ST1);
7402             Hi := Type_High_Bound (ST1);
7403 
7404             if Compile_Time_Known_Value (Lo) then
7405                Loval := Expr_Value (Lo);
7406 
7407                if Lo_Bound = No_Uint or else Lo_Bound < Loval then
7408                   Lo_Bound := Loval;
7409                end if;
7410             end if;
7411 
7412             if Compile_Time_Known_Value (Hi) then
7413                Hival := Expr_Value (Hi);
7414 
7415                if Hi_Bound = No_Uint or else Hi_Bound > Hival then
7416                   Hi_Bound := Hival;
7417                end if;
7418             end if;
7419 
7420             ST2 := Ancestor_Subtype (ST1);
7421 
7422             if No (ST2) then
7423                ST2 := Etype (ST1);
7424             end if;
7425 
7426             exit when ST1 = ST2;
7427             ST1 := ST2;
7428          end loop;
7429       end Check_Subtype_Bounds;
7430 
7431    --  Start of processing for Get_Simple_Init_Val
7432 
7433    begin
7434       --  For a private type, we should always have an underlying type (because
7435       --  this was already checked in Needs_Simple_Initialization). What we do
7436       --  is to get the value for the underlying type and then do an unchecked
7437       --  conversion to the private type.
7438 
7439       if Is_Private_Type (T) then
7440          Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
7441 
7442          --  A special case, if the underlying value is null, then qualify it
7443          --  with the underlying type, so that the null is properly typed.
7444          --  Similarly, if it is an aggregate it must be qualified, because an
7445          --  unchecked conversion does not provide a context for it.
7446 
7447          if Nkind_In (Val, N_Null, N_Aggregate) then
7448             Val :=
7449               Make_Qualified_Expression (Loc,
7450                 Subtype_Mark =>
7451                   New_Occurrence_Of (Underlying_Type (T), Loc),
7452                 Expression => Val);
7453          end if;
7454 
7455          Result := Unchecked_Convert_To (T, Val);
7456 
7457          --  Don't truncate result (important for Initialize/Normalize_Scalars)
7458 
7459          if Nkind (Result) = N_Unchecked_Type_Conversion
7460            and then Is_Scalar_Type (Underlying_Type (T))
7461          then
7462             Set_No_Truncation (Result);
7463          end if;
7464 
7465          return Result;
7466 
7467       --  Scalars with Default_Value aspect. The first subtype may now be
7468       --  private, so retrieve value from underlying type.
7469 
7470       elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
7471          if Is_Private_Type (First_Subtype (T)) then
7472             return Unchecked_Convert_To (T,
7473               Default_Aspect_Value (Full_View (First_Subtype (T))));
7474          else
7475             return
7476               Convert_To (T, Default_Aspect_Value (First_Subtype (T)));
7477          end if;
7478 
7479       --  Otherwise, for scalars, we must have normalize/initialize scalars
7480       --  case, or if the node N is an 'Invalid_Value attribute node.
7481 
7482       elsif Is_Scalar_Type (T) then
7483          pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
7484 
7485          --  Compute size of object. If it is given by the caller, we can use
7486          --  it directly, otherwise we use Esize (T) as an estimate. As far as
7487          --  we know this covers all cases correctly.
7488 
7489          if Size = No_Uint or else Size <= Uint_0 then
7490             Size_To_Use := UI_Max (Uint_1, Esize (T));
7491          else
7492             Size_To_Use := Size;
7493          end if;
7494 
7495          --  Maximum size to use is 64 bits, since we will create values of
7496          --  type Unsigned_64 and the range must fit this type.
7497 
7498          if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
7499             Size_To_Use := Uint_64;
7500          end if;
7501 
7502          --  Check known bounds of subtype
7503 
7504          Check_Subtype_Bounds;
7505 
7506          --  Processing for Normalize_Scalars case
7507 
7508          if Normalize_Scalars and then not IV_Attribute then
7509 
7510             --  If zero is invalid, it is a convenient value to use that is
7511             --  for sure an appropriate invalid value in all situations.
7512 
7513             if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
7514                Val := Make_Integer_Literal (Loc, 0);
7515 
7516             --  Cases where all one bits is the appropriate invalid value
7517 
7518             --  For modular types, all 1 bits is either invalid or valid. If
7519             --  it is valid, then there is nothing that can be done since there
7520             --  are no invalid values (we ruled out zero already).
7521 
7522             --  For signed integer types that have no negative values, either
7523             --  there is room for negative values, or there is not. If there
7524             --  is, then all 1-bits may be interpreted as minus one, which is
7525             --  certainly invalid. Alternatively it is treated as the largest
7526             --  positive value, in which case the observation for modular types
7527             --  still applies.
7528 
7529             --  For float types, all 1-bits is a NaN (not a number), which is
7530             --  certainly an appropriately invalid value.
7531 
7532             elsif Is_Unsigned_Type (T)
7533               or else Is_Floating_Point_Type (T)
7534               or else Is_Enumeration_Type (T)
7535             then
7536                Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
7537 
7538                --  Resolve as Unsigned_64, because the largest number we can
7539                --  generate is out of range of universal integer.
7540 
7541                Analyze_And_Resolve (Val, RTE (RE_Unsigned_64));
7542 
7543             --  Case of signed types
7544 
7545             else
7546                declare
7547                   Signed_Size : constant Uint :=
7548                                   UI_Min (Uint_63, Size_To_Use - 1);
7549 
7550                begin
7551                   --  Normally we like to use the most negative number. The one
7552                   --  exception is when this number is in the known subtype
7553                   --  range and the largest positive number is not in the known
7554                   --  subtype range.
7555 
7556                   --  For this exceptional case, use largest positive value
7557 
7558                   if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint
7559                     and then Lo_Bound <= (-(2 ** Signed_Size))
7560                     and then Hi_Bound < 2 ** Signed_Size
7561                   then
7562                      Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
7563 
7564                   --  Normal case of largest negative value
7565 
7566                   else
7567                      Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
7568                   end if;
7569                end;
7570             end if;
7571 
7572          --  Here for Initialize_Scalars case (or Invalid_Value attribute used)
7573 
7574          else
7575             --  For float types, use float values from System.Scalar_Values
7576 
7577             if Is_Floating_Point_Type (T) then
7578                if Root_Type (T) = Standard_Short_Float then
7579                   Val_RE := RE_IS_Isf;
7580                elsif Root_Type (T) = Standard_Float then
7581                   Val_RE := RE_IS_Ifl;
7582                elsif Root_Type (T) = Standard_Long_Float then
7583                   Val_RE := RE_IS_Ilf;
7584                else pragma Assert (Root_Type (T) = Standard_Long_Long_Float);
7585                   Val_RE := RE_IS_Ill;
7586                end if;
7587 
7588             --  If zero is invalid, use zero values from System.Scalar_Values
7589 
7590             elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
7591                if Size_To_Use <= 8 then
7592                   Val_RE := RE_IS_Iz1;
7593                elsif Size_To_Use <= 16 then
7594                   Val_RE := RE_IS_Iz2;
7595                elsif Size_To_Use <= 32 then
7596                   Val_RE := RE_IS_Iz4;
7597                else
7598                   Val_RE := RE_IS_Iz8;
7599                end if;
7600 
7601             --  For unsigned, use unsigned values from System.Scalar_Values
7602 
7603             elsif Is_Unsigned_Type (T) then
7604                if Size_To_Use <= 8 then
7605                   Val_RE := RE_IS_Iu1;
7606                elsif Size_To_Use <= 16 then
7607                   Val_RE := RE_IS_Iu2;
7608                elsif Size_To_Use <= 32 then
7609                   Val_RE := RE_IS_Iu4;
7610                else
7611                   Val_RE := RE_IS_Iu8;
7612                end if;
7613 
7614             --  For signed, use signed values from System.Scalar_Values
7615 
7616             else
7617                if Size_To_Use <= 8 then
7618                   Val_RE := RE_IS_Is1;
7619                elsif Size_To_Use <= 16 then
7620                   Val_RE := RE_IS_Is2;
7621                elsif Size_To_Use <= 32 then
7622                   Val_RE := RE_IS_Is4;
7623                else
7624                   Val_RE := RE_IS_Is8;
7625                end if;
7626             end if;
7627 
7628             Val := New_Occurrence_Of (RTE (Val_RE), Loc);
7629          end if;
7630 
7631          --  The final expression is obtained by doing an unchecked conversion
7632          --  of this result to the base type of the required subtype. Use the
7633          --  base type to prevent the unchecked conversion from chopping bits,
7634          --  and then we set Kill_Range_Check to preserve the "bad" value.
7635 
7636          Result := Unchecked_Convert_To (Base_Type (T), Val);
7637 
7638          --  Ensure result is not truncated, since we want the "bad" bits, and
7639          --  also kill range check on result.
7640 
7641          if Nkind (Result) = N_Unchecked_Type_Conversion then
7642             Set_No_Truncation (Result);
7643             Set_Kill_Range_Check (Result, True);
7644          end if;
7645 
7646          return Result;
7647 
7648       --  String or Wide_[Wide]_String (must have Initialize_Scalars set)
7649 
7650       elsif Is_Standard_String_Type (T) then
7651          pragma Assert (Init_Or_Norm_Scalars);
7652 
7653          return
7654            Make_Aggregate (Loc,
7655              Component_Associations => New_List (
7656                Make_Component_Association (Loc,
7657                  Choices    => New_List (
7658                    Make_Others_Choice (Loc)),
7659                  Expression =>
7660                    Get_Simple_Init_Val
7661                      (Component_Type (T), N, Esize (Root_Type (T))))));
7662 
7663       --  Access type is initialized to null
7664 
7665       elsif Is_Access_Type (T) then
7666          return Make_Null (Loc);
7667 
7668       --  No other possibilities should arise, since we should only be calling
7669       --  Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
7670       --  indicating one of the above cases held.
7671 
7672       else
7673          raise Program_Error;
7674       end if;
7675 
7676    exception
7677       when RE_Not_Available =>
7678          return Empty;
7679    end Get_Simple_Init_Val;
7680 
7681    ------------------------------
7682    -- Has_New_Non_Standard_Rep --
7683    ------------------------------
7684 
7685    function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
7686    begin
7687       if not Is_Derived_Type (T) then
7688          return Has_Non_Standard_Rep (T)
7689            or else Has_Non_Standard_Rep (Root_Type (T));
7690 
7691       --  If Has_Non_Standard_Rep is not set on the derived type, the
7692       --  representation is fully inherited.
7693 
7694       elsif not Has_Non_Standard_Rep (T) then
7695          return False;
7696 
7697       else
7698          return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
7699 
7700          --  May need a more precise check here: the First_Rep_Item may be a
7701          --  stream attribute, which does not affect the representation of the
7702          --  type ???
7703 
7704       end if;
7705    end Has_New_Non_Standard_Rep;
7706 
7707    ----------------------
7708    -- Inline_Init_Proc --
7709    ----------------------
7710 
7711    function Inline_Init_Proc (Typ : Entity_Id) return Boolean is
7712    begin
7713       --  The initialization proc of protected records is not worth inlining.
7714       --  In addition, when compiled for another unit for inlining purposes,
7715       --  it may make reference to entities that have not been elaborated yet.
7716       --  The initialization proc of records that need finalization contains
7717       --  a nested clean-up procedure that makes it impractical to inline as
7718       --  well, except for simple controlled types themselves. And similar
7719       --  considerations apply to task types.
7720 
7721       if Is_Concurrent_Type (Typ) then
7722          return False;
7723 
7724       elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then
7725          return False;
7726 
7727       elsif Has_Task (Typ) then
7728          return False;
7729 
7730       else
7731          return True;
7732       end if;
7733    end Inline_Init_Proc;
7734 
7735    ----------------
7736    -- In_Runtime --
7737    ----------------
7738 
7739    function In_Runtime (E : Entity_Id) return Boolean is
7740       S1 : Entity_Id;
7741 
7742    begin
7743       S1 := Scope (E);
7744       while Scope (S1) /= Standard_Standard loop
7745          S1 := Scope (S1);
7746       end loop;
7747 
7748       return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
7749    end In_Runtime;
7750 
7751    ----------------------------
7752    -- Initialization_Warning --
7753    ----------------------------
7754 
7755    procedure Initialization_Warning (E : Entity_Id) is
7756       Warning_Needed : Boolean;
7757 
7758    begin
7759       Warning_Needed := False;
7760 
7761       if Ekind (Current_Scope) = E_Package
7762         and then Static_Elaboration_Desired (Current_Scope)
7763       then
7764          if Is_Type (E) then
7765             if Is_Record_Type (E) then
7766                if Has_Discriminants (E)
7767                  or else Is_Limited_Type (E)
7768                  or else Has_Non_Standard_Rep (E)
7769                then
7770                   Warning_Needed := True;
7771 
7772                else
7773                   --  Verify that at least one component has an initialization
7774                   --  expression. No need for a warning on a type if all its
7775                   --  components have no initialization.
7776 
7777                   declare
7778                      Comp : Entity_Id;
7779 
7780                   begin
7781                      Comp := First_Component (E);
7782                      while Present (Comp) loop
7783                         if Ekind (Comp) = E_Discriminant
7784                           or else
7785                             (Nkind (Parent (Comp)) = N_Component_Declaration
7786                               and then Present (Expression (Parent (Comp))))
7787                         then
7788                            Warning_Needed := True;
7789                            exit;
7790                         end if;
7791 
7792                         Next_Component (Comp);
7793                      end loop;
7794                   end;
7795                end if;
7796 
7797                if Warning_Needed then
7798                   Error_Msg_N
7799                     ("Objects of the type cannot be initialized statically "
7800                      & "by default??", Parent (E));
7801                end if;
7802             end if;
7803 
7804          else
7805             Error_Msg_N ("Object cannot be initialized statically??", E);
7806          end if;
7807       end if;
7808    end Initialization_Warning;
7809 
7810    ------------------
7811    -- Init_Formals --
7812    ------------------
7813 
7814    function Init_Formals (Typ : Entity_Id) return List_Id is
7815       Loc     : constant Source_Ptr := Sloc (Typ);
7816       Formals : List_Id;
7817 
7818    begin
7819       --  First parameter is always _Init : in out typ. Note that we need this
7820       --  to be in/out because in the case of the task record value, there
7821       --  are default record fields (_Priority, _Size, -Task_Info) that may
7822       --  be referenced in the generated initialization routine.
7823 
7824       Formals := New_List (
7825         Make_Parameter_Specification (Loc,
7826           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit),
7827           In_Present          => True,
7828           Out_Present         => True,
7829           Parameter_Type      => New_Occurrence_Of (Typ, Loc)));
7830 
7831       --  For task record value, or type that contains tasks, add two more
7832       --  formals, _Master : Master_Id and _Chain : in out Activation_Chain
7833       --  We also add these parameters for the task record type case.
7834 
7835       if Has_Task (Typ)
7836         or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ))
7837       then
7838          Append_To (Formals,
7839            Make_Parameter_Specification (Loc,
7840              Defining_Identifier =>
7841                Make_Defining_Identifier (Loc, Name_uMaster),
7842              Parameter_Type      =>
7843                New_Occurrence_Of (RTE (RE_Master_Id), Loc)));
7844 
7845          --  Add _Chain (not done for sequential elaboration policy, see
7846          --  comment for Create_Restricted_Task_Sequential in s-tarest.ads).
7847 
7848          if Partition_Elaboration_Policy /= 'S' then
7849             Append_To (Formals,
7850               Make_Parameter_Specification (Loc,
7851                 Defining_Identifier =>
7852                   Make_Defining_Identifier (Loc, Name_uChain),
7853                 In_Present          => True,
7854                 Out_Present         => True,
7855                 Parameter_Type      =>
7856                   New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)));
7857          end if;
7858 
7859          Append_To (Formals,
7860            Make_Parameter_Specification (Loc,
7861              Defining_Identifier =>
7862                Make_Defining_Identifier (Loc, Name_uTask_Name),
7863              In_Present          => True,
7864              Parameter_Type      => New_Occurrence_Of (Standard_String, Loc)));
7865       end if;
7866 
7867       return Formals;
7868 
7869    exception
7870       when RE_Not_Available =>
7871          return Empty_List;
7872    end Init_Formals;
7873 
7874    -------------------------
7875    -- Init_Secondary_Tags --
7876    -------------------------
7877 
7878    procedure Init_Secondary_Tags
7879      (Typ            : Entity_Id;
7880       Target         : Node_Id;
7881       Stmts_List     : List_Id;
7882       Fixed_Comps    : Boolean := True;
7883       Variable_Comps : Boolean := True)
7884    is
7885       Loc : constant Source_Ptr := Sloc (Target);
7886 
7887       --  Inherit the C++ tag of the secondary dispatch table of Typ associated
7888       --  with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
7889 
7890       procedure Initialize_Tag
7891         (Typ       : Entity_Id;
7892          Iface     : Entity_Id;
7893          Tag_Comp  : Entity_Id;
7894          Iface_Tag : Node_Id);
7895       --  Initialize the tag of the secondary dispatch table of Typ associated
7896       --  with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
7897       --  Compiling under the CPP full ABI compatibility mode, if the ancestor
7898       --  of Typ CPP tagged type we generate code to inherit the contents of
7899       --  the dispatch table directly from the ancestor.
7900 
7901       --------------------
7902       -- Initialize_Tag --
7903       --------------------
7904 
7905       procedure Initialize_Tag
7906         (Typ       : Entity_Id;
7907          Iface     : Entity_Id;
7908          Tag_Comp  : Entity_Id;
7909          Iface_Tag : Node_Id)
7910       is
7911          Comp_Typ           : Entity_Id;
7912          Offset_To_Top_Comp : Entity_Id := Empty;
7913 
7914       begin
7915          --  Initialize pointer to secondary DT associated with the interface
7916 
7917          if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
7918             Append_To (Stmts_List,
7919               Make_Assignment_Statement (Loc,
7920                 Name       =>
7921                   Make_Selected_Component (Loc,
7922                     Prefix        => New_Copy_Tree (Target),
7923                     Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
7924                 Expression =>
7925                   New_Occurrence_Of (Iface_Tag, Loc)));
7926          end if;
7927 
7928          Comp_Typ := Scope (Tag_Comp);
7929 
7930          --  Initialize the entries of the table of interfaces. We generate a
7931          --  different call when the parent of the type has variable size
7932          --  components.
7933 
7934          if Comp_Typ /= Etype (Comp_Typ)
7935            and then Is_Variable_Size_Record (Etype (Comp_Typ))
7936            and then Chars (Tag_Comp) /= Name_uTag
7937          then
7938             pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
7939 
7940             --  Issue error if Set_Dynamic_Offset_To_Top is not available in a
7941             --  configurable run-time environment.
7942 
7943             if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
7944                Error_Msg_CRT
7945                  ("variable size record with interface types", Typ);
7946                return;
7947             end if;
7948 
7949             --  Generate:
7950             --    Set_Dynamic_Offset_To_Top
7951             --      (This         => Init,
7952             --       Interface_T  => Iface'Tag,
7953             --       Offset_Value => n,
7954             --       Offset_Func  => Fn'Address)
7955 
7956             Append_To (Stmts_List,
7957               Make_Procedure_Call_Statement (Loc,
7958                 Name                   =>
7959                   New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
7960                 Parameter_Associations => New_List (
7961                   Make_Attribute_Reference (Loc,
7962                     Prefix         => New_Copy_Tree (Target),
7963                     Attribute_Name => Name_Address),
7964 
7965                   Unchecked_Convert_To (RTE (RE_Tag),
7966                     New_Occurrence_Of
7967                       (Node (First_Elmt (Access_Disp_Table (Iface))),
7968                        Loc)),
7969 
7970                   Unchecked_Convert_To
7971                     (RTE (RE_Storage_Offset),
7972                      Make_Attribute_Reference (Loc,
7973                        Prefix         =>
7974                          Make_Selected_Component (Loc,
7975                            Prefix        => New_Copy_Tree (Target),
7976                            Selector_Name =>
7977                              New_Occurrence_Of (Tag_Comp, Loc)),
7978                        Attribute_Name => Name_Position)),
7979 
7980                   Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
7981                     Make_Attribute_Reference (Loc,
7982                       Prefix => New_Occurrence_Of
7983                                   (DT_Offset_To_Top_Func (Tag_Comp), Loc),
7984                       Attribute_Name => Name_Address)))));
7985 
7986             --  In this case the next component stores the value of the offset
7987             --  to the top.
7988 
7989             Offset_To_Top_Comp := Next_Entity (Tag_Comp);
7990             pragma Assert (Present (Offset_To_Top_Comp));
7991 
7992             Append_To (Stmts_List,
7993               Make_Assignment_Statement (Loc,
7994                 Name       =>
7995                   Make_Selected_Component (Loc,
7996                     Prefix        => New_Copy_Tree (Target),
7997                     Selector_Name =>
7998                       New_Occurrence_Of (Offset_To_Top_Comp, Loc)),
7999 
8000                 Expression =>
8001                   Make_Attribute_Reference (Loc,
8002                     Prefix       =>
8003                       Make_Selected_Component (Loc,
8004                         Prefix        => New_Copy_Tree (Target),
8005                         Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
8006                   Attribute_Name => Name_Position)));
8007 
8008          --  Normal case: No discriminants in the parent type
8009 
8010          else
8011             --  Don't need to set any value if this interface shares the
8012             --  primary dispatch table.
8013 
8014             if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
8015                Append_To (Stmts_List,
8016                  Build_Set_Static_Offset_To_Top (Loc,
8017                    Iface_Tag    => New_Occurrence_Of (Iface_Tag, Loc),
8018                    Offset_Value =>
8019                      Unchecked_Convert_To (RTE (RE_Storage_Offset),
8020                        Make_Attribute_Reference (Loc,
8021                          Prefix         =>
8022                            Make_Selected_Component (Loc,
8023                              Prefix        => New_Copy_Tree (Target),
8024                              Selector_Name =>
8025                                New_Occurrence_Of (Tag_Comp, Loc)),
8026                          Attribute_Name => Name_Position))));
8027             end if;
8028 
8029             --  Generate:
8030             --    Register_Interface_Offset
8031             --      (This         => Init,
8032             --       Interface_T  => Iface'Tag,
8033             --       Is_Constant  => True,
8034             --       Offset_Value => n,
8035             --       Offset_Func  => null);
8036 
8037             if RTE_Available (RE_Register_Interface_Offset) then
8038                Append_To (Stmts_List,
8039                  Make_Procedure_Call_Statement (Loc,
8040                    Name                   =>
8041                      New_Occurrence_Of
8042                        (RTE (RE_Register_Interface_Offset), Loc),
8043                    Parameter_Associations => New_List (
8044                      Make_Attribute_Reference (Loc,
8045                        Prefix         => New_Copy_Tree (Target),
8046                        Attribute_Name => Name_Address),
8047 
8048                      Unchecked_Convert_To (RTE (RE_Tag),
8049                        New_Occurrence_Of
8050                          (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
8051 
8052                      New_Occurrence_Of (Standard_True, Loc),
8053 
8054                      Unchecked_Convert_To (RTE (RE_Storage_Offset),
8055                        Make_Attribute_Reference (Loc,
8056                          Prefix         =>
8057                            Make_Selected_Component (Loc,
8058                              Prefix         => New_Copy_Tree (Target),
8059                              Selector_Name  =>
8060                                New_Occurrence_Of (Tag_Comp, Loc)),
8061                          Attribute_Name => Name_Position)),
8062 
8063                      Make_Null (Loc))));
8064             end if;
8065          end if;
8066       end Initialize_Tag;
8067 
8068       --  Local variables
8069 
8070       Full_Typ         : Entity_Id;
8071       Ifaces_List      : Elist_Id;
8072       Ifaces_Comp_List : Elist_Id;
8073       Ifaces_Tag_List  : Elist_Id;
8074       Iface_Elmt       : Elmt_Id;
8075       Iface_Comp_Elmt  : Elmt_Id;
8076       Iface_Tag_Elmt   : Elmt_Id;
8077       Tag_Comp         : Node_Id;
8078       In_Variable_Pos  : Boolean;
8079 
8080    --  Start of processing for Init_Secondary_Tags
8081 
8082    begin
8083       --  Handle private types
8084 
8085       if Present (Full_View (Typ)) then
8086          Full_Typ := Full_View (Typ);
8087       else
8088          Full_Typ := Typ;
8089       end if;
8090 
8091       Collect_Interfaces_Info
8092         (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
8093 
8094       Iface_Elmt      := First_Elmt (Ifaces_List);
8095       Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
8096       Iface_Tag_Elmt  := First_Elmt (Ifaces_Tag_List);
8097       while Present (Iface_Elmt) loop
8098          Tag_Comp := Node (Iface_Comp_Elmt);
8099 
8100          --  Check if parent of record type has variable size components
8101 
8102          In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
8103            and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
8104 
8105          --  If we are compiling under the CPP full ABI compatibility mode and
8106          --  the ancestor is a CPP_Pragma tagged type then we generate code to
8107          --  initialize the secondary tag components from tags that reference
8108          --  secondary tables filled with copy of parent slots.
8109 
8110          if Is_CPP_Class (Root_Type (Full_Typ)) then
8111 
8112             --  Reject interface components located at variable offset in
8113             --  C++ derivations. This is currently unsupported.
8114 
8115             if not Fixed_Comps and then In_Variable_Pos then
8116 
8117                --  Locate the first dynamic component of the record. Done to
8118                --  improve the text of the warning.
8119 
8120                declare
8121                   Comp     : Entity_Id;
8122                   Comp_Typ : Entity_Id;
8123 
8124                begin
8125                   Comp := First_Entity (Typ);
8126                   while Present (Comp) loop
8127                      Comp_Typ := Etype (Comp);
8128 
8129                      if Ekind (Comp) /= E_Discriminant
8130                        and then not Is_Tag (Comp)
8131                      then
8132                         exit when
8133                           (Is_Record_Type (Comp_Typ)
8134                             and then
8135                               Is_Variable_Size_Record (Base_Type (Comp_Typ)))
8136                          or else
8137                            (Is_Array_Type (Comp_Typ)
8138                              and then Is_Variable_Size_Array (Comp_Typ));
8139                      end if;
8140 
8141                      Next_Entity (Comp);
8142                   end loop;
8143 
8144                   pragma Assert (Present (Comp));
8145                   Error_Msg_Node_2 := Comp;
8146                   Error_Msg_NE
8147                     ("parent type & with dynamic component & cannot be parent"
8148                      & " of 'C'P'P derivation if new interfaces are present",
8149                      Typ, Scope (Original_Record_Component (Comp)));
8150 
8151                   Error_Msg_Sloc :=
8152                     Sloc (Scope (Original_Record_Component (Comp)));
8153                   Error_Msg_NE
8154                     ("type derived from 'C'P'P type & defined #",
8155                      Typ, Scope (Original_Record_Component (Comp)));
8156 
8157                   --  Avoid duplicated warnings
8158 
8159                   exit;
8160                end;
8161 
8162             --  Initialize secondary tags
8163 
8164             else
8165                Append_To (Stmts_List,
8166                  Make_Assignment_Statement (Loc,
8167                    Name =>
8168                      Make_Selected_Component (Loc,
8169                        Prefix => New_Copy_Tree (Target),
8170                        Selector_Name =>
8171                          New_Occurrence_Of (Node (Iface_Comp_Elmt), Loc)),
8172                    Expression =>
8173                      New_Occurrence_Of (Node (Iface_Tag_Elmt), Loc)));
8174             end if;
8175 
8176          --  Otherwise generate code to initialize the tag
8177 
8178          else
8179             if (In_Variable_Pos and then Variable_Comps)
8180               or else (not In_Variable_Pos and then Fixed_Comps)
8181             then
8182                Initialize_Tag (Full_Typ,
8183                  Iface     => Node (Iface_Elmt),
8184                  Tag_Comp  => Tag_Comp,
8185                  Iface_Tag => Node (Iface_Tag_Elmt));
8186             end if;
8187          end if;
8188 
8189          Next_Elmt (Iface_Elmt);
8190          Next_Elmt (Iface_Comp_Elmt);
8191          Next_Elmt (Iface_Tag_Elmt);
8192       end loop;
8193    end Init_Secondary_Tags;
8194 
8195    ------------------------
8196    -- Is_User_Defined_Eq --
8197    ------------------------
8198 
8199    function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
8200    begin
8201       return Chars (Prim) = Name_Op_Eq
8202         and then Etype (First_Formal (Prim)) =
8203                  Etype (Next_Formal (First_Formal (Prim)))
8204         and then Base_Type (Etype (Prim)) = Standard_Boolean;
8205    end Is_User_Defined_Equality;
8206 
8207    ----------------------------------------
8208    -- Make_Controlling_Function_Wrappers --
8209    ----------------------------------------
8210 
8211    procedure Make_Controlling_Function_Wrappers
8212      (Tag_Typ   : Entity_Id;
8213       Decl_List : out List_Id;
8214       Body_List : out List_Id)
8215    is
8216       Loc         : constant Source_Ptr := Sloc (Tag_Typ);
8217       Prim_Elmt   : Elmt_Id;
8218       Subp        : Entity_Id;
8219       Actual_List : List_Id;
8220       Formal_List : List_Id;
8221       Formal      : Entity_Id;
8222       Par_Formal  : Entity_Id;
8223       Formal_Node : Node_Id;
8224       Func_Body   : Node_Id;
8225       Func_Decl   : Node_Id;
8226       Func_Spec   : Node_Id;
8227       Return_Stmt : Node_Id;
8228 
8229    begin
8230       Decl_List := New_List;
8231       Body_List := New_List;
8232 
8233       Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8234       while Present (Prim_Elmt) loop
8235          Subp := Node (Prim_Elmt);
8236 
8237          --  If a primitive function with a controlling result of the type has
8238          --  not been overridden by the user, then we must create a wrapper
8239          --  function here that effectively overrides it and invokes the
8240          --  (non-abstract) parent function. This can only occur for a null
8241          --  extension. Note that functions with anonymous controlling access
8242          --  results don't qualify and must be overridden. We also exclude
8243          --  Input attributes, since each type will have its own version of
8244          --  Input constructed by the expander. The test for Comes_From_Source
8245          --  is needed to distinguish inherited operations from renamings
8246          --  (which also have Alias set). We exclude internal entities with
8247          --  Interface_Alias to avoid generating duplicated wrappers since
8248          --  the primitive which covers the interface is also available in
8249          --  the list of primitive operations.
8250 
8251          --  The function may be abstract, or require_Overriding may be set
8252          --  for it, because tests for null extensions may already have reset
8253          --  the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
8254          --  set, functions that need wrappers are recognized by having an
8255          --  alias that returns the parent type.
8256 
8257          if Comes_From_Source (Subp)
8258            or else No (Alias (Subp))
8259            or else Present (Interface_Alias (Subp))
8260            or else Ekind (Subp) /= E_Function
8261            or else not Has_Controlling_Result (Subp)
8262            or else Is_Access_Type (Etype (Subp))
8263            or else Is_Abstract_Subprogram (Alias (Subp))
8264            or else Is_TSS (Subp, TSS_Stream_Input)
8265          then
8266             goto Next_Prim;
8267 
8268          elsif Is_Abstract_Subprogram (Subp)
8269            or else Requires_Overriding (Subp)
8270            or else
8271              (Is_Null_Extension (Etype (Subp))
8272                and then Etype (Alias (Subp)) /= Etype (Subp))
8273          then
8274             Formal_List := No_List;
8275             Formal := First_Formal (Subp);
8276 
8277             if Present (Formal) then
8278                Formal_List := New_List;
8279 
8280                while Present (Formal) loop
8281                   Append
8282                     (Make_Parameter_Specification
8283                        (Loc,
8284                         Defining_Identifier =>
8285                           Make_Defining_Identifier (Sloc (Formal),
8286                             Chars => Chars (Formal)),
8287                         In_Present  => In_Present (Parent (Formal)),
8288                         Out_Present => Out_Present (Parent (Formal)),
8289                         Null_Exclusion_Present =>
8290                           Null_Exclusion_Present (Parent (Formal)),
8291                         Parameter_Type =>
8292                           New_Occurrence_Of (Etype (Formal), Loc),
8293                         Expression =>
8294                           New_Copy_Tree (Expression (Parent (Formal)))),
8295                      Formal_List);
8296 
8297                   Next_Formal (Formal);
8298                end loop;
8299             end if;
8300 
8301             Func_Spec :=
8302               Make_Function_Specification (Loc,
8303                 Defining_Unit_Name       =>
8304                   Make_Defining_Identifier (Loc,
8305                     Chars => Chars (Subp)),
8306                 Parameter_Specifications => Formal_List,
8307                 Result_Definition        =>
8308                   New_Occurrence_Of (Etype (Subp), Loc));
8309 
8310             Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
8311             Append_To (Decl_List, Func_Decl);
8312 
8313             --  Build a wrapper body that calls the parent function. The body
8314             --  contains a single return statement that returns an extension
8315             --  aggregate whose ancestor part is a call to the parent function,
8316             --  passing the formals as actuals (with any controlling arguments
8317             --  converted to the types of the corresponding formals of the
8318             --  parent function, which might be anonymous access types), and
8319             --  having a null extension.
8320 
8321             Formal      := First_Formal (Subp);
8322             Par_Formal  := First_Formal (Alias (Subp));
8323             Formal_Node := First (Formal_List);
8324 
8325             if Present (Formal) then
8326                Actual_List := New_List;
8327             else
8328                Actual_List := No_List;
8329             end if;
8330 
8331             while Present (Formal) loop
8332                if Is_Controlling_Formal (Formal) then
8333                   Append_To (Actual_List,
8334                     Make_Type_Conversion (Loc,
8335                       Subtype_Mark =>
8336                         New_Occurrence_Of (Etype (Par_Formal), Loc),
8337                       Expression   =>
8338                         New_Occurrence_Of
8339                           (Defining_Identifier (Formal_Node), Loc)));
8340                else
8341                   Append_To
8342                     (Actual_List,
8343                      New_Occurrence_Of
8344                        (Defining_Identifier (Formal_Node), Loc));
8345                end if;
8346 
8347                Next_Formal (Formal);
8348                Next_Formal (Par_Formal);
8349                Next (Formal_Node);
8350             end loop;
8351 
8352             Return_Stmt :=
8353               Make_Simple_Return_Statement (Loc,
8354                 Expression =>
8355                   Make_Extension_Aggregate (Loc,
8356                     Ancestor_Part       =>
8357                       Make_Function_Call (Loc,
8358                         Name                   =>
8359                           New_Occurrence_Of (Alias (Subp), Loc),
8360                         Parameter_Associations => Actual_List),
8361                     Null_Record_Present => True));
8362 
8363             Func_Body :=
8364               Make_Subprogram_Body (Loc,
8365                 Specification              => New_Copy_Tree (Func_Spec),
8366                 Declarations               => Empty_List,
8367                 Handled_Statement_Sequence =>
8368                   Make_Handled_Sequence_Of_Statements (Loc,
8369                     Statements => New_List (Return_Stmt)));
8370 
8371             Set_Defining_Unit_Name
8372               (Specification (Func_Body),
8373                 Make_Defining_Identifier (Loc, Chars (Subp)));
8374 
8375             Append_To (Body_List, Func_Body);
8376 
8377             --  Replace the inherited function with the wrapper function in the
8378             --  primitive operations list. We add the minimum decoration needed
8379             --  to override interface primitives.
8380 
8381             Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
8382 
8383             Override_Dispatching_Operation
8384               (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
8385                Is_Wrapper => True);
8386          end if;
8387 
8388       <<Next_Prim>>
8389          Next_Elmt (Prim_Elmt);
8390       end loop;
8391    end Make_Controlling_Function_Wrappers;
8392 
8393    -------------------
8394    --  Make_Eq_Body --
8395    -------------------
8396 
8397    function Make_Eq_Body
8398      (Typ     : Entity_Id;
8399       Eq_Name : Name_Id) return Node_Id
8400    is
8401       Loc          : constant Source_Ptr := Sloc (Parent (Typ));
8402       Decl         : Node_Id;
8403       Def          : constant Node_Id := Parent (Typ);
8404       Stmts        : constant List_Id := New_List;
8405       Variant_Case : Boolean := Has_Discriminants (Typ);
8406       Comps        : Node_Id := Empty;
8407       Typ_Def      : Node_Id := Type_Definition (Def);
8408 
8409    begin
8410       Decl :=
8411         Predef_Spec_Or_Body (Loc,
8412           Tag_Typ => Typ,
8413           Name    => Eq_Name,
8414           Profile => New_List (
8415             Make_Parameter_Specification (Loc,
8416               Defining_Identifier =>
8417                 Make_Defining_Identifier (Loc, Name_X),
8418               Parameter_Type      => New_Occurrence_Of (Typ, Loc)),
8419 
8420             Make_Parameter_Specification (Loc,
8421               Defining_Identifier =>
8422                 Make_Defining_Identifier (Loc, Name_Y),
8423               Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
8424 
8425           Ret_Type => Standard_Boolean,
8426           For_Body => True);
8427 
8428       if Variant_Case then
8429          if Nkind (Typ_Def) = N_Derived_Type_Definition then
8430             Typ_Def := Record_Extension_Part (Typ_Def);
8431          end if;
8432 
8433          if Present (Typ_Def) then
8434             Comps := Component_List (Typ_Def);
8435          end if;
8436 
8437          Variant_Case :=
8438            Present (Comps) and then Present (Variant_Part (Comps));
8439       end if;
8440 
8441       if Variant_Case then
8442          Append_To (Stmts,
8443            Make_Eq_If (Typ, Discriminant_Specifications (Def)));
8444          Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
8445          Append_To (Stmts,
8446            Make_Simple_Return_Statement (Loc,
8447              Expression => New_Occurrence_Of (Standard_True, Loc)));
8448 
8449       else
8450          Append_To (Stmts,
8451            Make_Simple_Return_Statement (Loc,
8452              Expression =>
8453                Expand_Record_Equality
8454                  (Typ,
8455                   Typ    => Typ,
8456                   Lhs    => Make_Identifier (Loc, Name_X),
8457                   Rhs    => Make_Identifier (Loc, Name_Y),
8458                   Bodies => Declarations (Decl))));
8459       end if;
8460 
8461       Set_Handled_Statement_Sequence
8462         (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8463       return Decl;
8464    end Make_Eq_Body;
8465 
8466    ------------------
8467    -- Make_Eq_Case --
8468    ------------------
8469 
8470    --  <Make_Eq_If shared components>
8471 
8472    --  case X.D1 is
8473    --     when V1 => <Make_Eq_Case> on subcomponents
8474    --     ...
8475    --     when Vn => <Make_Eq_Case> on subcomponents
8476    --  end case;
8477 
8478    function Make_Eq_Case
8479      (E      : Entity_Id;
8480       CL     : Node_Id;
8481       Discrs : Elist_Id := New_Elmt_List) return List_Id
8482    is
8483       Loc      : constant Source_Ptr := Sloc (E);
8484       Result   : constant List_Id    := New_List;
8485       Variant  : Node_Id;
8486       Alt_List : List_Id;
8487 
8488       function Corresponding_Formal (C : Node_Id) return Entity_Id;
8489       --  Given the discriminant that controls a given variant of an unchecked
8490       --  union, find the formal of the equality function that carries the
8491       --  inferred value of the discriminant.
8492 
8493       function External_Name (E : Entity_Id) return Name_Id;
8494       --  The value of a given discriminant is conveyed in the corresponding
8495       --  formal parameter of the equality routine. The name of this formal
8496       --  parameter carries a one-character suffix which is removed here.
8497 
8498       --------------------------
8499       -- Corresponding_Formal --
8500       --------------------------
8501 
8502       function Corresponding_Formal (C : Node_Id) return Entity_Id is
8503          Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
8504          Elm   : Elmt_Id;
8505 
8506       begin
8507          Elm := First_Elmt (Discrs);
8508          while Present (Elm) loop
8509             if Chars (Discr) = External_Name (Node (Elm)) then
8510                return Node (Elm);
8511             end if;
8512 
8513             Next_Elmt (Elm);
8514          end loop;
8515 
8516          --  A formal of the proper name must be found
8517 
8518          raise Program_Error;
8519       end Corresponding_Formal;
8520 
8521       -------------------
8522       -- External_Name --
8523       -------------------
8524 
8525       function External_Name (E : Entity_Id) return Name_Id is
8526       begin
8527          Get_Name_String (Chars (E));
8528          Name_Len := Name_Len - 1;
8529          return Name_Find;
8530       end External_Name;
8531 
8532    --  Start of processing for Make_Eq_Case
8533 
8534    begin
8535       Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
8536 
8537       if No (Variant_Part (CL)) then
8538          return Result;
8539       end if;
8540 
8541       Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
8542 
8543       if No (Variant) then
8544          return Result;
8545       end if;
8546 
8547       Alt_List := New_List;
8548       while Present (Variant) loop
8549          Append_To (Alt_List,
8550            Make_Case_Statement_Alternative (Loc,
8551              Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
8552              Statements =>
8553                Make_Eq_Case (E, Component_List (Variant), Discrs)));
8554          Next_Non_Pragma (Variant);
8555       end loop;
8556 
8557       --  If we have an Unchecked_Union, use one of the parameters of the
8558       --  enclosing equality routine that captures the discriminant, to use
8559       --  as the expression in the generated case statement.
8560 
8561       if Is_Unchecked_Union (E) then
8562          Append_To (Result,
8563            Make_Case_Statement (Loc,
8564              Expression =>
8565                New_Occurrence_Of (Corresponding_Formal (CL), Loc),
8566              Alternatives => Alt_List));
8567 
8568       else
8569          Append_To (Result,
8570            Make_Case_Statement (Loc,
8571              Expression =>
8572                Make_Selected_Component (Loc,
8573                  Prefix        => Make_Identifier (Loc, Name_X),
8574                  Selector_Name => New_Copy (Name (Variant_Part (CL)))),
8575              Alternatives => Alt_List));
8576       end if;
8577 
8578       return Result;
8579    end Make_Eq_Case;
8580 
8581    ----------------
8582    -- Make_Eq_If --
8583    ----------------
8584 
8585    --  Generates:
8586 
8587    --    if
8588    --      X.C1 /= Y.C1
8589    --        or else
8590    --      X.C2 /= Y.C2
8591    --        ...
8592    --    then
8593    --       return False;
8594    --    end if;
8595 
8596    --  or a null statement if the list L is empty
8597 
8598    function Make_Eq_If
8599      (E : Entity_Id;
8600       L : List_Id) return Node_Id
8601    is
8602       Loc        : constant Source_Ptr := Sloc (E);
8603       C          : Node_Id;
8604       Field_Name : Name_Id;
8605       Cond       : Node_Id;
8606 
8607    begin
8608       if No (L) then
8609          return Make_Null_Statement (Loc);
8610 
8611       else
8612          Cond := Empty;
8613 
8614          C := First_Non_Pragma (L);
8615          while Present (C) loop
8616             Field_Name := Chars (Defining_Identifier (C));
8617 
8618             --  The tags must not be compared: they are not part of the value.
8619             --  Ditto for parent interfaces because their equality operator is
8620             --  abstract.
8621 
8622             --  Note also that in the following, we use Make_Identifier for
8623             --  the component names. Use of New_Occurrence_Of to identify the
8624             --  components would be incorrect because the wrong entities for
8625             --  discriminants could be picked up in the private type case.
8626 
8627             if Field_Name = Name_uParent
8628               and then Is_Interface (Etype (Defining_Identifier (C)))
8629             then
8630                null;
8631 
8632             elsif Field_Name /= Name_uTag then
8633                Evolve_Or_Else (Cond,
8634                  Make_Op_Ne (Loc,
8635                    Left_Opnd =>
8636                      Make_Selected_Component (Loc,
8637                        Prefix        => Make_Identifier (Loc, Name_X),
8638                        Selector_Name => Make_Identifier (Loc, Field_Name)),
8639 
8640                    Right_Opnd =>
8641                      Make_Selected_Component (Loc,
8642                        Prefix        => Make_Identifier (Loc, Name_Y),
8643                        Selector_Name => Make_Identifier (Loc, Field_Name))));
8644             end if;
8645 
8646             Next_Non_Pragma (C);
8647          end loop;
8648 
8649          if No (Cond) then
8650             return Make_Null_Statement (Loc);
8651 
8652          else
8653             return
8654               Make_Implicit_If_Statement (E,
8655                 Condition       => Cond,
8656                 Then_Statements => New_List (
8657                   Make_Simple_Return_Statement (Loc,
8658                     Expression => New_Occurrence_Of (Standard_False, Loc))));
8659          end if;
8660       end if;
8661    end Make_Eq_If;
8662 
8663    -------------------
8664    -- Make_Neq_Body --
8665    -------------------
8666 
8667    function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
8668 
8669       function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
8670       --  Returns true if Prim is a renaming of an unresolved predefined
8671       --  inequality operation.
8672 
8673       --------------------------------
8674       -- Is_Predefined_Neq_Renaming --
8675       --------------------------------
8676 
8677       function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
8678       begin
8679          return Chars (Prim) /= Name_Op_Ne
8680            and then Present (Alias (Prim))
8681            and then Comes_From_Source (Prim)
8682            and then Is_Intrinsic_Subprogram (Alias (Prim))
8683            and then Chars (Alias (Prim)) = Name_Op_Ne;
8684       end Is_Predefined_Neq_Renaming;
8685 
8686       --  Local variables
8687 
8688       Loc           : constant Source_Ptr := Sloc (Parent (Tag_Typ));
8689       Stmts         : constant List_Id    := New_List;
8690       Decl          : Node_Id;
8691       Eq_Prim       : Entity_Id;
8692       Left_Op       : Entity_Id;
8693       Renaming_Prim : Entity_Id;
8694       Right_Op      : Entity_Id;
8695       Target        : Entity_Id;
8696 
8697    --  Start of processing for Make_Neq_Body
8698 
8699    begin
8700       --  For a call on a renaming of a dispatching subprogram that is
8701       --  overridden, if the overriding occurred before the renaming, then
8702       --  the body executed is that of the overriding declaration, even if the
8703       --  overriding declaration is not visible at the place of the renaming;
8704       --  otherwise, the inherited or predefined subprogram is called, see
8705       --  (RM 8.5.4(8))
8706 
8707       --  Stage 1: Search for a renaming of the inequality primitive and also
8708       --  search for an overriding of the equality primitive located before the
8709       --  renaming declaration.
8710 
8711       declare
8712          Elmt : Elmt_Id;
8713          Prim : Node_Id;
8714 
8715       begin
8716          Eq_Prim       := Empty;
8717          Renaming_Prim := Empty;
8718 
8719          Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8720          while Present (Elmt) loop
8721             Prim := Node (Elmt);
8722 
8723             if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then
8724                if No (Renaming_Prim) then
8725                   pragma Assert (No (Eq_Prim));
8726                   Eq_Prim := Prim;
8727                end if;
8728 
8729             elsif Is_Predefined_Neq_Renaming (Prim) then
8730                Renaming_Prim := Prim;
8731             end if;
8732 
8733             Next_Elmt (Elmt);
8734          end loop;
8735       end;
8736 
8737       --  No further action needed if no renaming was found
8738 
8739       if No (Renaming_Prim) then
8740          return Empty;
8741       end if;
8742 
8743       --  Stage 2: Replace the renaming declaration by a subprogram declaration
8744       --  (required to add its body)
8745 
8746       Decl := Parent (Parent (Renaming_Prim));
8747       Rewrite (Decl,
8748         Make_Subprogram_Declaration (Loc,
8749           Specification => Specification (Decl)));
8750       Set_Analyzed (Decl);
8751 
8752       --  Remove the decoration of intrinsic renaming subprogram
8753 
8754       Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
8755       Set_Convention (Renaming_Prim, Convention_Ada);
8756       Set_Alias (Renaming_Prim, Empty);
8757       Set_Has_Completion (Renaming_Prim, False);
8758 
8759       --  Stage 3: Build the corresponding body
8760 
8761       Left_Op  := First_Formal (Renaming_Prim);
8762       Right_Op := Next_Formal (Left_Op);
8763 
8764       Decl :=
8765         Predef_Spec_Or_Body (Loc,
8766           Tag_Typ => Tag_Typ,
8767           Name    => Chars (Renaming_Prim),
8768           Profile => New_List (
8769             Make_Parameter_Specification (Loc,
8770               Defining_Identifier =>
8771                 Make_Defining_Identifier (Loc, Chars (Left_Op)),
8772               Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)),
8773 
8774             Make_Parameter_Specification (Loc,
8775               Defining_Identifier =>
8776                 Make_Defining_Identifier (Loc, Chars (Right_Op)),
8777               Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc))),
8778 
8779           Ret_Type => Standard_Boolean,
8780           For_Body => True);
8781 
8782       --  If the overriding of the equality primitive occurred before the
8783       --  renaming, then generate:
8784 
8785       --    function <Neq_Name> (X : Y : Typ) return Boolean is
8786       --    begin
8787       --       return not Oeq (X, Y);
8788       --    end;
8789 
8790       if Present (Eq_Prim) then
8791          Target := Eq_Prim;
8792 
8793       --  Otherwise build a nested subprogram which performs the predefined
8794       --  evaluation of the equality operator. That is, generate:
8795 
8796       --    function <Neq_Name> (X : Y : Typ) return Boolean is
8797       --       function Oeq (X : Y) return Boolean is
8798       --       begin
8799       --          <<body of default implementation>>
8800       --       end;
8801       --    begin
8802       --       return not Oeq (X, Y);
8803       --    end;
8804 
8805       else
8806          declare
8807             Local_Subp : Node_Id;
8808          begin
8809             Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
8810             Set_Declarations (Decl, New_List (Local_Subp));
8811             Target := Defining_Entity (Local_Subp);
8812          end;
8813       end if;
8814 
8815       Append_To (Stmts,
8816         Make_Simple_Return_Statement (Loc,
8817           Expression =>
8818             Make_Op_Not (Loc,
8819               Make_Function_Call (Loc,
8820                 Name                   => New_Occurrence_Of (Target, Loc),
8821                 Parameter_Associations => New_List (
8822                   Make_Identifier (Loc, Chars (Left_Op)),
8823                   Make_Identifier (Loc, Chars (Right_Op)))))));
8824 
8825       Set_Handled_Statement_Sequence
8826         (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8827       return Decl;
8828    end Make_Neq_Body;
8829 
8830    -------------------------------
8831    -- Make_Null_Procedure_Specs --
8832    -------------------------------
8833 
8834    function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
8835       Decl_List      : constant List_Id    := New_List;
8836       Loc            : constant Source_Ptr := Sloc (Tag_Typ);
8837       Formal         : Entity_Id;
8838       Formal_List    : List_Id;
8839       New_Param_Spec : Node_Id;
8840       Parent_Subp    : Entity_Id;
8841       Prim_Elmt      : Elmt_Id;
8842       Subp           : Entity_Id;
8843 
8844    begin
8845       Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8846       while Present (Prim_Elmt) loop
8847          Subp := Node (Prim_Elmt);
8848 
8849          --  If a null procedure inherited from an interface has not been
8850          --  overridden, then we build a null procedure declaration to
8851          --  override the inherited procedure.
8852 
8853          Parent_Subp := Alias (Subp);
8854 
8855          if Present (Parent_Subp)
8856            and then Is_Null_Interface_Primitive (Parent_Subp)
8857          then
8858             Formal_List := No_List;
8859             Formal := First_Formal (Subp);
8860 
8861             if Present (Formal) then
8862                Formal_List := New_List;
8863 
8864                while Present (Formal) loop
8865 
8866                   --  Copy the parameter spec including default expressions
8867 
8868                   New_Param_Spec :=
8869                     New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
8870 
8871                   --  Generate a new defining identifier for the new formal.
8872                   --  required because New_Copy_Tree does not duplicate
8873                   --  semantic fields (except itypes).
8874 
8875                   Set_Defining_Identifier (New_Param_Spec,
8876                     Make_Defining_Identifier (Sloc (Formal),
8877                       Chars => Chars (Formal)));
8878 
8879                   --  For controlling arguments we must change their
8880                   --  parameter type to reference the tagged type (instead
8881                   --  of the interface type)
8882 
8883                   if Is_Controlling_Formal (Formal) then
8884                      if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
8885                      then
8886                         Set_Parameter_Type (New_Param_Spec,
8887                           New_Occurrence_Of (Tag_Typ, Loc));
8888 
8889                      else pragma Assert
8890                             (Nkind (Parameter_Type (Parent (Formal))) =
8891                                                         N_Access_Definition);
8892                         Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
8893                           New_Occurrence_Of (Tag_Typ, Loc));
8894                      end if;
8895                   end if;
8896 
8897                   Append (New_Param_Spec, Formal_List);
8898 
8899                   Next_Formal (Formal);
8900                end loop;
8901             end if;
8902 
8903             Append_To (Decl_List,
8904               Make_Subprogram_Declaration (Loc,
8905                 Make_Procedure_Specification (Loc,
8906                   Defining_Unit_Name       =>
8907                     Make_Defining_Identifier (Loc, Chars (Subp)),
8908                   Parameter_Specifications => Formal_List,
8909                   Null_Present             => True)));
8910          end if;
8911 
8912          Next_Elmt (Prim_Elmt);
8913       end loop;
8914 
8915       return Decl_List;
8916    end Make_Null_Procedure_Specs;
8917 
8918    -------------------------------------
8919    -- Make_Predefined_Primitive_Specs --
8920    -------------------------------------
8921 
8922    procedure Make_Predefined_Primitive_Specs
8923      (Tag_Typ     : Entity_Id;
8924       Predef_List : out List_Id;
8925       Renamed_Eq  : out Entity_Id)
8926    is
8927       function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
8928       --  Returns true if Prim is a renaming of an unresolved predefined
8929       --  equality operation.
8930 
8931       -------------------------------
8932       -- Is_Predefined_Eq_Renaming --
8933       -------------------------------
8934 
8935       function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
8936       begin
8937          return Chars (Prim) /= Name_Op_Eq
8938            and then Present (Alias (Prim))
8939            and then Comes_From_Source (Prim)
8940            and then Is_Intrinsic_Subprogram (Alias (Prim))
8941            and then Chars (Alias (Prim)) = Name_Op_Eq;
8942       end Is_Predefined_Eq_Renaming;
8943 
8944       --  Local variables
8945 
8946       Loc       : constant Source_Ptr := Sloc (Tag_Typ);
8947       Res       : constant List_Id    := New_List;
8948       Eq_Name   : Name_Id             := Name_Op_Eq;
8949       Eq_Needed : Boolean;
8950       Eq_Spec   : Node_Id;
8951       Prim      : Elmt_Id;
8952 
8953       Has_Predef_Eq_Renaming : Boolean := False;
8954       --  Set to True if Tag_Typ has a primitive that renames the predefined
8955       --  equality operator. Used to implement (RM 8-5-4(8)).
8956 
8957    --  Start of processing for Make_Predefined_Primitive_Specs
8958 
8959    begin
8960       Renamed_Eq := Empty;
8961 
8962       --  Spec of _Size
8963 
8964       Append_To (Res, Predef_Spec_Or_Body (Loc,
8965         Tag_Typ => Tag_Typ,
8966         Name    => Name_uSize,
8967         Profile => New_List (
8968           Make_Parameter_Specification (Loc,
8969             Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
8970             Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc))),
8971 
8972         Ret_Type => Standard_Long_Long_Integer));
8973 
8974       --  Specs for dispatching stream attributes
8975 
8976       declare
8977          Stream_Op_TSS_Names :
8978            constant array (Integer range <>) of TSS_Name_Type :=
8979              (TSS_Stream_Read,
8980               TSS_Stream_Write,
8981               TSS_Stream_Input,
8982               TSS_Stream_Output);
8983 
8984       begin
8985          for Op in Stream_Op_TSS_Names'Range loop
8986             if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
8987                Append_To (Res,
8988                  Predef_Stream_Attr_Spec (Loc, Tag_Typ,
8989                   Stream_Op_TSS_Names (Op)));
8990             end if;
8991          end loop;
8992       end;
8993 
8994       --  Spec of "=" is expanded if the type is not limited and if a user
8995       --  defined "=" was not already declared for the non-full view of a
8996       --  private extension
8997 
8998       if not Is_Limited_Type (Tag_Typ) then
8999          Eq_Needed := True;
9000          Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9001          while Present (Prim) loop
9002 
9003             --  If a primitive is encountered that renames the predefined
9004             --  equality operator before reaching any explicit equality
9005             --  primitive, then we still need to create a predefined equality
9006             --  function, because calls to it can occur via the renaming. A
9007             --  new name is created for the equality to avoid conflicting with
9008             --  any user-defined equality. (Note that this doesn't account for
9009             --  renamings of equality nested within subpackages???)
9010 
9011             if Is_Predefined_Eq_Renaming (Node (Prim)) then
9012                Has_Predef_Eq_Renaming := True;
9013                Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
9014 
9015             --  User-defined equality
9016 
9017             elsif Is_User_Defined_Equality (Node (Prim)) then
9018                if No (Alias (Node (Prim)))
9019                  or else Nkind (Unit_Declaration_Node (Node (Prim))) =
9020                            N_Subprogram_Renaming_Declaration
9021                then
9022                   Eq_Needed := False;
9023                   exit;
9024 
9025                --  If the parent is not an interface type and has an abstract
9026                --  equality function explicitly defined in the sources, then
9027                --  the inherited equality is abstract as well, and no body can
9028                --  be created for it.
9029 
9030                elsif not Is_Interface (Etype (Tag_Typ))
9031                  and then Present (Alias (Node (Prim)))
9032                  and then Comes_From_Source (Alias (Node (Prim)))
9033                  and then Is_Abstract_Subprogram (Alias (Node (Prim)))
9034                then
9035                   Eq_Needed := False;
9036                   exit;
9037 
9038                --  If the type has an equality function corresponding with
9039                --  a primitive defined in an interface type, the inherited
9040                --  equality is abstract as well, and no body can be created
9041                --  for it.
9042 
9043                elsif Present (Alias (Node (Prim)))
9044                  and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
9045                  and then
9046                    Is_Interface
9047                      (Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
9048                then
9049                   Eq_Needed := False;
9050                   exit;
9051                end if;
9052             end if;
9053 
9054             Next_Elmt (Prim);
9055          end loop;
9056 
9057          --  If a renaming of predefined equality was found but there was no
9058          --  user-defined equality (so Eq_Needed is still true), then set the
9059          --  name back to Name_Op_Eq. But in the case where a user-defined
9060          --  equality was located after such a renaming, then the predefined
9061          --  equality function is still needed, so Eq_Needed must be set back
9062          --  to True.
9063 
9064          if Eq_Name /= Name_Op_Eq then
9065             if Eq_Needed then
9066                Eq_Name := Name_Op_Eq;
9067             else
9068                Eq_Needed := True;
9069             end if;
9070          end if;
9071 
9072          if Eq_Needed then
9073             Eq_Spec := Predef_Spec_Or_Body (Loc,
9074               Tag_Typ => Tag_Typ,
9075               Name    => Eq_Name,
9076               Profile => New_List (
9077                 Make_Parameter_Specification (Loc,
9078                   Defining_Identifier =>
9079                     Make_Defining_Identifier (Loc, Name_X),
9080                   Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)),
9081 
9082                 Make_Parameter_Specification (Loc,
9083                   Defining_Identifier =>
9084                     Make_Defining_Identifier (Loc, Name_Y),
9085                   Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc))),
9086                 Ret_Type => Standard_Boolean);
9087             Append_To (Res, Eq_Spec);
9088 
9089             if Has_Predef_Eq_Renaming then
9090                Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
9091 
9092                Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9093                while Present (Prim) loop
9094 
9095                   --  Any renamings of equality that appeared before an
9096                   --  overriding equality must be updated to refer to the
9097                   --  entity for the predefined equality, otherwise calls via
9098                   --  the renaming would get incorrectly resolved to call the
9099                   --  user-defined equality function.
9100 
9101                   if Is_Predefined_Eq_Renaming (Node (Prim)) then
9102                      Set_Alias (Node (Prim), Renamed_Eq);
9103 
9104                   --  Exit upon encountering a user-defined equality
9105 
9106                   elsif Chars (Node (Prim)) = Name_Op_Eq
9107                     and then No (Alias (Node (Prim)))
9108                   then
9109                      exit;
9110                   end if;
9111 
9112                   Next_Elmt (Prim);
9113                end loop;
9114             end if;
9115          end if;
9116 
9117          --  Spec for dispatching assignment
9118 
9119          Append_To (Res, Predef_Spec_Or_Body (Loc,
9120            Tag_Typ => Tag_Typ,
9121            Name    => Name_uAssign,
9122            Profile => New_List (
9123              Make_Parameter_Specification (Loc,
9124                Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9125                Out_Present         => True,
9126                Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)),
9127 
9128              Make_Parameter_Specification (Loc,
9129                Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
9130                Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)))));
9131       end if;
9132 
9133       --  Ada 2005: Generate declarations for the following primitive
9134       --  operations for limited interfaces and synchronized types that
9135       --  implement a limited interface.
9136 
9137       --    Disp_Asynchronous_Select
9138       --    Disp_Conditional_Select
9139       --    Disp_Get_Prim_Op_Kind
9140       --    Disp_Get_Task_Id
9141       --    Disp_Requeue
9142       --    Disp_Timed_Select
9143 
9144       --  Disable the generation of these bodies if No_Dispatching_Calls,
9145       --  Ravenscar or ZFP is active.
9146 
9147       if Ada_Version >= Ada_2005
9148         and then not Restriction_Active (No_Dispatching_Calls)
9149         and then not Restriction_Active (No_Select_Statements)
9150         and then RTE_Available (RE_Select_Specific_Data)
9151       then
9152          --  These primitives are defined abstract in interface types
9153 
9154          if Is_Interface (Tag_Typ)
9155            and then Is_Limited_Record (Tag_Typ)
9156          then
9157             Append_To (Res,
9158               Make_Abstract_Subprogram_Declaration (Loc,
9159                 Specification =>
9160                   Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
9161 
9162             Append_To (Res,
9163               Make_Abstract_Subprogram_Declaration (Loc,
9164                 Specification =>
9165                   Make_Disp_Conditional_Select_Spec (Tag_Typ)));
9166 
9167             Append_To (Res,
9168               Make_Abstract_Subprogram_Declaration (Loc,
9169                 Specification =>
9170                   Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
9171 
9172             Append_To (Res,
9173               Make_Abstract_Subprogram_Declaration (Loc,
9174                 Specification =>
9175                   Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
9176 
9177             Append_To (Res,
9178               Make_Abstract_Subprogram_Declaration (Loc,
9179                 Specification =>
9180                   Make_Disp_Requeue_Spec (Tag_Typ)));
9181 
9182             Append_To (Res,
9183               Make_Abstract_Subprogram_Declaration (Loc,
9184                 Specification =>
9185                   Make_Disp_Timed_Select_Spec (Tag_Typ)));
9186 
9187          --  If ancestor is an interface type, declare non-abstract primitives
9188          --  to override the abstract primitives of the interface type.
9189 
9190          --  In VM targets we define these primitives in all root tagged types
9191          --  that are not interface types. Done because in VM targets we don't
9192          --  have secondary dispatch tables and any derivation of Tag_Typ may
9193          --  cover limited interfaces (which always have these primitives since
9194          --  they may be ancestors of synchronized interface types).
9195 
9196          elsif (not Is_Interface (Tag_Typ)
9197                  and then Is_Interface (Etype (Tag_Typ))
9198                  and then Is_Limited_Record (Etype (Tag_Typ)))
9199              or else
9200                (Is_Concurrent_Record_Type (Tag_Typ)
9201                  and then Has_Interfaces (Tag_Typ))
9202              or else
9203                (not Tagged_Type_Expansion
9204                  and then not Is_Interface (Tag_Typ)
9205                  and then Tag_Typ = Root_Type (Tag_Typ))
9206          then
9207             Append_To (Res,
9208               Make_Subprogram_Declaration (Loc,
9209                 Specification =>
9210                   Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
9211 
9212             Append_To (Res,
9213               Make_Subprogram_Declaration (Loc,
9214                 Specification =>
9215                   Make_Disp_Conditional_Select_Spec (Tag_Typ)));
9216 
9217             Append_To (Res,
9218               Make_Subprogram_Declaration (Loc,
9219                 Specification =>
9220                   Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
9221 
9222             Append_To (Res,
9223               Make_Subprogram_Declaration (Loc,
9224                 Specification =>
9225                   Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
9226 
9227             Append_To (Res,
9228               Make_Subprogram_Declaration (Loc,
9229                 Specification =>
9230                   Make_Disp_Requeue_Spec (Tag_Typ)));
9231 
9232             Append_To (Res,
9233               Make_Subprogram_Declaration (Loc,
9234                 Specification =>
9235                   Make_Disp_Timed_Select_Spec (Tag_Typ)));
9236          end if;
9237       end if;
9238 
9239       --  All tagged types receive their own Deep_Adjust and Deep_Finalize
9240       --  regardless of whether they are controlled or may contain controlled
9241       --  components.
9242 
9243       --  Do not generate the routines if finalization is disabled
9244 
9245       if Restriction_Active (No_Finalization) then
9246          null;
9247 
9248       else
9249          if not Is_Limited_Type (Tag_Typ) then
9250             Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
9251          end if;
9252 
9253          Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
9254       end if;
9255 
9256       Predef_List := Res;
9257    end Make_Predefined_Primitive_Specs;
9258 
9259    -------------------------
9260    -- Make_Tag_Assignment --
9261    -------------------------
9262 
9263    function Make_Tag_Assignment (N : Node_Id) return Node_Id is
9264       Loc      : constant Source_Ptr := Sloc (N);
9265       Def_If   : constant Entity_Id := Defining_Identifier (N);
9266       Expr     : constant Node_Id := Expression (N);
9267       Typ      : constant Entity_Id := Etype (Def_If);
9268       Full_Typ : constant Entity_Id := Underlying_Type (Typ);
9269       New_Ref  : Node_Id;
9270 
9271    begin
9272       --  This expansion activity is called during analysis, but cannot
9273       --  be applied in ASIS mode when other expansion is disabled.
9274 
9275       if Is_Tagged_Type (Typ)
9276        and then not Is_Class_Wide_Type (Typ)
9277        and then not Is_CPP_Class (Typ)
9278        and then Tagged_Type_Expansion
9279        and then Nkind (Expr) /= N_Aggregate
9280        and then not ASIS_Mode
9281        and then (Nkind (Expr) /= N_Qualified_Expression
9282                   or else Nkind (Expression (Expr)) /= N_Aggregate)
9283       then
9284          New_Ref :=
9285            Make_Selected_Component (Loc,
9286               Prefix        => New_Occurrence_Of (Def_If, Loc),
9287               Selector_Name =>
9288                 New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
9289          Set_Assignment_OK (New_Ref);
9290 
9291          return
9292            Make_Assignment_Statement (Loc,
9293               Name       => New_Ref,
9294               Expression =>
9295                 Unchecked_Convert_To (RTE (RE_Tag),
9296                   New_Occurrence_Of (Node
9297                       (First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
9298       else
9299          return Empty;
9300       end if;
9301    end Make_Tag_Assignment;
9302 
9303    ---------------------------------
9304    -- Needs_Simple_Initialization --
9305    ---------------------------------
9306 
9307    function Needs_Simple_Initialization
9308      (T           : Entity_Id;
9309       Consider_IS : Boolean := True) return Boolean
9310    is
9311       Consider_IS_NS : constant Boolean :=
9312         Normalize_Scalars or (Initialize_Scalars and Consider_IS);
9313 
9314    begin
9315       --  Never need initialization if it is suppressed
9316 
9317       if Initialization_Suppressed (T) then
9318          return False;
9319       end if;
9320 
9321       --  Check for private type, in which case test applies to the underlying
9322       --  type of the private type.
9323 
9324       if Is_Private_Type (T) then
9325          declare
9326             RT : constant Entity_Id := Underlying_Type (T);
9327          begin
9328             if Present (RT) then
9329                return Needs_Simple_Initialization (RT);
9330             else
9331                return False;
9332             end if;
9333          end;
9334 
9335       --  Scalar type with Default_Value aspect requires initialization
9336 
9337       elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
9338          return True;
9339 
9340       --  Cases needing simple initialization are access types, and, if pragma
9341       --  Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
9342       --  types.
9343 
9344       elsif Is_Access_Type (T)
9345         or else (Consider_IS_NS and then (Is_Scalar_Type (T)))
9346       then
9347          return True;
9348 
9349       --  If Initialize/Normalize_Scalars is in effect, string objects also
9350       --  need initialization, unless they are created in the course of
9351       --  expanding an aggregate (since in the latter case they will be
9352       --  filled with appropriate initializing values before they are used).
9353 
9354       elsif Consider_IS_NS
9355         and then Is_Standard_String_Type (T)
9356         and then
9357           (not Is_Itype (T)
9358             or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
9359       then
9360          return True;
9361 
9362       else
9363          return False;
9364       end if;
9365    end Needs_Simple_Initialization;
9366 
9367    ----------------------
9368    -- Predef_Deep_Spec --
9369    ----------------------
9370 
9371    function Predef_Deep_Spec
9372      (Loc      : Source_Ptr;
9373       Tag_Typ  : Entity_Id;
9374       Name     : TSS_Name_Type;
9375       For_Body : Boolean := False) return Node_Id
9376    is
9377       Formals : List_Id;
9378 
9379    begin
9380       --  V : in out Tag_Typ
9381 
9382       Formals := New_List (
9383         Make_Parameter_Specification (Loc,
9384           Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
9385           In_Present          => True,
9386           Out_Present         => True,
9387           Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)));
9388 
9389       --  F : Boolean := True
9390 
9391       if Name = TSS_Deep_Adjust
9392         or else Name = TSS_Deep_Finalize
9393       then
9394          Append_To (Formals,
9395            Make_Parameter_Specification (Loc,
9396              Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
9397              Parameter_Type      => New_Occurrence_Of (Standard_Boolean, Loc),
9398              Expression          => New_Occurrence_Of (Standard_True, Loc)));
9399       end if;
9400 
9401       return
9402         Predef_Spec_Or_Body (Loc,
9403           Name     => Make_TSS_Name (Tag_Typ, Name),
9404           Tag_Typ  => Tag_Typ,
9405           Profile  => Formals,
9406           For_Body => For_Body);
9407 
9408    exception
9409       when RE_Not_Available =>
9410          return Empty;
9411    end Predef_Deep_Spec;
9412 
9413    -------------------------
9414    -- Predef_Spec_Or_Body --
9415    -------------------------
9416 
9417    function Predef_Spec_Or_Body
9418      (Loc      : Source_Ptr;
9419       Tag_Typ  : Entity_Id;
9420       Name     : Name_Id;
9421       Profile  : List_Id;
9422       Ret_Type : Entity_Id := Empty;
9423       For_Body : Boolean := False) return Node_Id
9424    is
9425       Id   : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
9426       Spec : Node_Id;
9427 
9428    begin
9429       Set_Is_Public (Id, Is_Public (Tag_Typ));
9430 
9431       --  The internal flag is set to mark these declarations because they have
9432       --  specific properties. First, they are primitives even if they are not
9433       --  defined in the type scope (the freezing point is not necessarily in
9434       --  the same scope). Second, the predefined equality can be overridden by
9435       --  a user-defined equality, no body will be generated in this case.
9436 
9437       Set_Is_Internal (Id);
9438 
9439       if not Debug_Generated_Code then
9440          Set_Debug_Info_Off (Id);
9441       end if;
9442 
9443       if No (Ret_Type) then
9444          Spec :=
9445            Make_Procedure_Specification (Loc,
9446              Defining_Unit_Name       => Id,
9447              Parameter_Specifications => Profile);
9448       else
9449          Spec :=
9450            Make_Function_Specification (Loc,
9451              Defining_Unit_Name       => Id,
9452              Parameter_Specifications => Profile,
9453              Result_Definition        => New_Occurrence_Of (Ret_Type, Loc));
9454       end if;
9455 
9456       if Is_Interface (Tag_Typ) then
9457          return Make_Abstract_Subprogram_Declaration (Loc, Spec);
9458 
9459       --  If body case, return empty subprogram body. Note that this is ill-
9460       --  formed, because there is not even a null statement, and certainly not
9461       --  a return in the function case. The caller is expected to do surgery
9462       --  on the body to add the appropriate stuff.
9463 
9464       elsif For_Body then
9465          return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
9466 
9467       --  For the case of an Input attribute predefined for an abstract type,
9468       --  generate an abstract specification. This will never be called, but we
9469       --  need the slot allocated in the dispatching table so that attributes
9470       --  typ'Class'Input and typ'Class'Output will work properly.
9471 
9472       elsif Is_TSS (Name, TSS_Stream_Input)
9473         and then Is_Abstract_Type (Tag_Typ)
9474       then
9475          return Make_Abstract_Subprogram_Declaration (Loc, Spec);
9476 
9477       --  Normal spec case, where we return a subprogram declaration
9478 
9479       else
9480          return Make_Subprogram_Declaration (Loc, Spec);
9481       end if;
9482    end Predef_Spec_Or_Body;
9483 
9484    -----------------------------
9485    -- Predef_Stream_Attr_Spec --
9486    -----------------------------
9487 
9488    function Predef_Stream_Attr_Spec
9489      (Loc      : Source_Ptr;
9490       Tag_Typ  : Entity_Id;
9491       Name     : TSS_Name_Type;
9492       For_Body : Boolean := False) return Node_Id
9493    is
9494       Ret_Type : Entity_Id;
9495 
9496    begin
9497       if Name = TSS_Stream_Input then
9498          Ret_Type := Tag_Typ;
9499       else
9500          Ret_Type := Empty;
9501       end if;
9502 
9503       return
9504         Predef_Spec_Or_Body
9505           (Loc,
9506            Name     => Make_TSS_Name (Tag_Typ, Name),
9507            Tag_Typ  => Tag_Typ,
9508            Profile  => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
9509            Ret_Type => Ret_Type,
9510            For_Body => For_Body);
9511    end Predef_Stream_Attr_Spec;
9512 
9513    ---------------------------------
9514    -- Predefined_Primitive_Bodies --
9515    ---------------------------------
9516 
9517    function Predefined_Primitive_Bodies
9518      (Tag_Typ    : Entity_Id;
9519       Renamed_Eq : Entity_Id) return List_Id
9520    is
9521       Loc       : constant Source_Ptr := Sloc (Tag_Typ);
9522       Res       : constant List_Id    := New_List;
9523       Decl      : Node_Id;
9524       Prim      : Elmt_Id;
9525       Eq_Needed : Boolean;
9526       Eq_Name   : Name_Id;
9527       Ent       : Entity_Id;
9528 
9529       pragma Warnings (Off, Ent);
9530 
9531    begin
9532       pragma Assert (not Is_Interface (Tag_Typ));
9533 
9534       --  See if we have a predefined "=" operator
9535 
9536       if Present (Renamed_Eq) then
9537          Eq_Needed := True;
9538          Eq_Name   := Chars (Renamed_Eq);
9539 
9540       --  If the parent is an interface type then it has defined all the
9541       --  predefined primitives abstract and we need to check if the type
9542       --  has some user defined "=" function which matches the profile of
9543       --  the Ada predefined equality operator to avoid generating it.
9544 
9545       elsif Is_Interface (Etype (Tag_Typ)) then
9546          Eq_Needed := True;
9547          Eq_Name := Name_Op_Eq;
9548 
9549          Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9550          while Present (Prim) loop
9551             if Chars (Node (Prim)) = Name_Op_Eq
9552               and then not Is_Internal (Node (Prim))
9553               and then Present (First_Entity (Node (Prim)))
9554 
9555               --  The predefined equality primitive must have exactly two
9556               --  formals whose type is this tagged type
9557 
9558               and then Present (Last_Entity (Node (Prim)))
9559               and then Next_Entity (First_Entity (Node (Prim)))
9560                          = Last_Entity (Node (Prim))
9561               and then Etype (First_Entity (Node (Prim))) = Tag_Typ
9562               and then Etype (Last_Entity (Node (Prim))) = Tag_Typ
9563             then
9564                Eq_Needed := False;
9565                Eq_Name := No_Name;
9566                exit;
9567             end if;
9568 
9569             Next_Elmt (Prim);
9570          end loop;
9571 
9572       else
9573          Eq_Needed := False;
9574          Eq_Name   := No_Name;
9575 
9576          Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9577          while Present (Prim) loop
9578             if Chars (Node (Prim)) = Name_Op_Eq
9579               and then Is_Internal (Node (Prim))
9580             then
9581                Eq_Needed := True;
9582                Eq_Name := Name_Op_Eq;
9583                exit;
9584             end if;
9585 
9586             Next_Elmt (Prim);
9587          end loop;
9588       end if;
9589 
9590       --  Body of _Size
9591 
9592       Decl := Predef_Spec_Or_Body (Loc,
9593         Tag_Typ => Tag_Typ,
9594         Name    => Name_uSize,
9595         Profile => New_List (
9596           Make_Parameter_Specification (Loc,
9597             Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9598             Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc))),
9599 
9600         Ret_Type => Standard_Long_Long_Integer,
9601         For_Body => True);
9602 
9603       Set_Handled_Statement_Sequence (Decl,
9604         Make_Handled_Sequence_Of_Statements (Loc, New_List (
9605           Make_Simple_Return_Statement (Loc,
9606             Expression =>
9607               Make_Attribute_Reference (Loc,
9608                 Prefix          => Make_Identifier (Loc, Name_X),
9609                 Attribute_Name  => Name_Size)))));
9610 
9611       Append_To (Res, Decl);
9612 
9613       --  Bodies for Dispatching stream IO routines. We need these only for
9614       --  non-limited types (in the limited case there is no dispatching).
9615       --  We also skip them if dispatching or finalization are not available
9616       --  or if stream operations are prohibited by restriction No_Streams or
9617       --  from use of pragma/aspect No_Tagged_Streams.
9618 
9619       if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
9620         and then No (TSS (Tag_Typ, TSS_Stream_Read))
9621       then
9622          Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
9623          Append_To (Res, Decl);
9624       end if;
9625 
9626       if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
9627         and then No (TSS (Tag_Typ, TSS_Stream_Write))
9628       then
9629          Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
9630          Append_To (Res, Decl);
9631       end if;
9632 
9633       --  Skip body of _Input for the abstract case, since the corresponding
9634       --  spec is abstract (see Predef_Spec_Or_Body).
9635 
9636       if not Is_Abstract_Type (Tag_Typ)
9637         and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
9638         and then No (TSS (Tag_Typ, TSS_Stream_Input))
9639       then
9640          Build_Record_Or_Elementary_Input_Function
9641            (Loc, Tag_Typ, Decl, Ent);
9642          Append_To (Res, Decl);
9643       end if;
9644 
9645       if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
9646         and then No (TSS (Tag_Typ, TSS_Stream_Output))
9647       then
9648          Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
9649          Append_To (Res, Decl);
9650       end if;
9651 
9652       --  Ada 2005: Generate bodies for the following primitive operations for
9653       --  limited interfaces and synchronized types that implement a limited
9654       --  interface.
9655 
9656       --    disp_asynchronous_select
9657       --    disp_conditional_select
9658       --    disp_get_prim_op_kind
9659       --    disp_get_task_id
9660       --    disp_timed_select
9661 
9662       --  The interface versions will have null bodies
9663 
9664       --  Disable the generation of these bodies if No_Dispatching_Calls,
9665       --  Ravenscar or ZFP is active.
9666 
9667       --  In VM targets we define these primitives in all root tagged types
9668       --  that are not interface types. Done because in VM targets we don't
9669       --  have secondary dispatch tables and any derivation of Tag_Typ may
9670       --  cover limited interfaces (which always have these primitives since
9671       --  they may be ancestors of synchronized interface types).
9672 
9673       if Ada_Version >= Ada_2005
9674         and then not Is_Interface (Tag_Typ)
9675         and then
9676           ((Is_Interface (Etype (Tag_Typ))
9677              and then Is_Limited_Record (Etype (Tag_Typ)))
9678            or else
9679              (Is_Concurrent_Record_Type (Tag_Typ)
9680                and then Has_Interfaces (Tag_Typ))
9681            or else
9682              (not Tagged_Type_Expansion
9683                and then Tag_Typ = Root_Type (Tag_Typ)))
9684         and then not Restriction_Active (No_Dispatching_Calls)
9685         and then not Restriction_Active (No_Select_Statements)
9686         and then RTE_Available (RE_Select_Specific_Data)
9687       then
9688          Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
9689          Append_To (Res, Make_Disp_Conditional_Select_Body  (Tag_Typ));
9690          Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body    (Tag_Typ));
9691          Append_To (Res, Make_Disp_Get_Task_Id_Body         (Tag_Typ));
9692          Append_To (Res, Make_Disp_Requeue_Body             (Tag_Typ));
9693          Append_To (Res, Make_Disp_Timed_Select_Body        (Tag_Typ));
9694       end if;
9695 
9696       if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then
9697 
9698          --  Body for equality
9699 
9700          if Eq_Needed then
9701             Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
9702             Append_To (Res, Decl);
9703          end if;
9704 
9705          --  Body for inequality (if required)
9706 
9707          Decl := Make_Neq_Body (Tag_Typ);
9708 
9709          if Present (Decl) then
9710             Append_To (Res, Decl);
9711          end if;
9712 
9713          --  Body for dispatching assignment
9714 
9715          Decl :=
9716            Predef_Spec_Or_Body (Loc,
9717              Tag_Typ => Tag_Typ,
9718              Name    => Name_uAssign,
9719              Profile => New_List (
9720                Make_Parameter_Specification (Loc,
9721                  Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9722                  Out_Present         => True,
9723                  Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc)),
9724 
9725                Make_Parameter_Specification (Loc,
9726                  Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
9727                  Parameter_Type      => New_Occurrence_Of (Tag_Typ, Loc))),
9728              For_Body => True);
9729 
9730          Set_Handled_Statement_Sequence (Decl,
9731            Make_Handled_Sequence_Of_Statements (Loc, New_List (
9732              Make_Assignment_Statement (Loc,
9733                Name       => Make_Identifier (Loc, Name_X),
9734                Expression => Make_Identifier (Loc, Name_Y)))));
9735 
9736          Append_To (Res, Decl);
9737       end if;
9738 
9739       --  Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
9740       --  tagged types which do not contain controlled components.
9741 
9742       --  Do not generate the routines if finalization is disabled
9743 
9744       if Restriction_Active (No_Finalization) then
9745          null;
9746 
9747       elsif not Has_Controlled_Component (Tag_Typ) then
9748          if not Is_Limited_Type (Tag_Typ) then
9749             Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
9750 
9751             if Is_Controlled (Tag_Typ) then
9752                Set_Handled_Statement_Sequence (Decl,
9753                  Make_Handled_Sequence_Of_Statements (Loc,
9754                    Statements => New_List (
9755                      Make_Adjust_Call (
9756                        Obj_Ref => Make_Identifier (Loc, Name_V),
9757                        Typ     => Tag_Typ))));
9758 
9759             else
9760                Set_Handled_Statement_Sequence (Decl,
9761                  Make_Handled_Sequence_Of_Statements (Loc,
9762                    Statements => New_List (
9763                      Make_Null_Statement (Loc))));
9764             end if;
9765 
9766             Append_To (Res, Decl);
9767          end if;
9768 
9769          Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
9770 
9771          if Is_Controlled (Tag_Typ) then
9772             Set_Handled_Statement_Sequence (Decl,
9773               Make_Handled_Sequence_Of_Statements (Loc,
9774                 Statements => New_List (
9775                   Make_Final_Call
9776                     (Obj_Ref => Make_Identifier (Loc, Name_V),
9777                      Typ     => Tag_Typ))));
9778 
9779          else
9780             Set_Handled_Statement_Sequence (Decl,
9781               Make_Handled_Sequence_Of_Statements (Loc,
9782                 Statements => New_List (Make_Null_Statement (Loc))));
9783          end if;
9784 
9785          Append_To (Res, Decl);
9786       end if;
9787 
9788       return Res;
9789    end Predefined_Primitive_Bodies;
9790 
9791    ---------------------------------
9792    -- Predefined_Primitive_Freeze --
9793    ---------------------------------
9794 
9795    function Predefined_Primitive_Freeze
9796      (Tag_Typ : Entity_Id) return List_Id
9797    is
9798       Res     : constant List_Id := New_List;
9799       Prim    : Elmt_Id;
9800       Frnodes : List_Id;
9801 
9802    begin
9803       Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9804       while Present (Prim) loop
9805          if Is_Predefined_Dispatching_Operation (Node (Prim)) then
9806             Frnodes := Freeze_Entity (Node (Prim), Tag_Typ);
9807 
9808             if Present (Frnodes) then
9809                Append_List_To (Res, Frnodes);
9810             end if;
9811          end if;
9812 
9813          Next_Elmt (Prim);
9814       end loop;
9815 
9816       return Res;
9817    end Predefined_Primitive_Freeze;
9818 
9819    -------------------------
9820    -- Stream_Operation_OK --
9821    -------------------------
9822 
9823    function Stream_Operation_OK
9824      (Typ       : Entity_Id;
9825       Operation : TSS_Name_Type) return Boolean
9826    is
9827       Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
9828 
9829    begin
9830       --  Special case of a limited type extension: a default implementation
9831       --  of the stream attributes Read or Write exists if that attribute
9832       --  has been specified or is available for an ancestor type; a default
9833       --  implementation of the attribute Output (resp. Input) exists if the
9834       --  attribute has been specified or Write (resp. Read) is available for
9835       --  an ancestor type. The last condition only applies under Ada 2005.
9836 
9837       if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then
9838          if Operation = TSS_Stream_Read then
9839             Has_Predefined_Or_Specified_Stream_Attribute :=
9840               Has_Specified_Stream_Read (Typ);
9841 
9842          elsif Operation = TSS_Stream_Write then
9843             Has_Predefined_Or_Specified_Stream_Attribute :=
9844               Has_Specified_Stream_Write (Typ);
9845 
9846          elsif Operation = TSS_Stream_Input then
9847             Has_Predefined_Or_Specified_Stream_Attribute :=
9848               Has_Specified_Stream_Input (Typ)
9849                 or else
9850                   (Ada_Version >= Ada_2005
9851                     and then Stream_Operation_OK (Typ, TSS_Stream_Read));
9852 
9853          elsif Operation = TSS_Stream_Output then
9854             Has_Predefined_Or_Specified_Stream_Attribute :=
9855               Has_Specified_Stream_Output (Typ)
9856                 or else
9857                   (Ada_Version >= Ada_2005
9858                     and then Stream_Operation_OK (Typ, TSS_Stream_Write));
9859          end if;
9860 
9861          --  Case of inherited TSS_Stream_Read or TSS_Stream_Write
9862 
9863          if not Has_Predefined_Or_Specified_Stream_Attribute
9864            and then Is_Derived_Type (Typ)
9865            and then (Operation = TSS_Stream_Read
9866                       or else Operation = TSS_Stream_Write)
9867          then
9868             Has_Predefined_Or_Specified_Stream_Attribute :=
9869               Present
9870                 (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
9871          end if;
9872       end if;
9873 
9874       --  If the type is not limited, or else is limited but the attribute is
9875       --  explicitly specified or is predefined for the type, then return True,
9876       --  unless other conditions prevail, such as restrictions prohibiting
9877       --  streams or dispatching operations. We also return True for limited
9878       --  interfaces, because they may be extended by nonlimited types and
9879       --  permit inheritance in this case (addresses cases where an abstract
9880       --  extension doesn't get 'Input declared, as per comments below, but
9881       --  'Class'Input must still be allowed). Note that attempts to apply
9882       --  stream attributes to a limited interface or its class-wide type
9883       --  (or limited extensions thereof) will still get properly rejected
9884       --  by Check_Stream_Attribute.
9885 
9886       --  We exclude the Input operation from being a predefined subprogram in
9887       --  the case where the associated type is an abstract extension, because
9888       --  the attribute is not callable in that case, per 13.13.2(49/2). Also,
9889       --  we don't want an abstract version created because types derived from
9890       --  the abstract type may not even have Input available (for example if
9891       --  derived from a private view of the abstract type that doesn't have
9892       --  a visible Input).
9893 
9894       --  Do not generate stream routines for type Finalization_Master because
9895       --  a master may never appear in types and therefore cannot be read or
9896       --  written.
9897 
9898       return
9899           (not Is_Limited_Type (Typ)
9900             or else Is_Interface (Typ)
9901             or else Has_Predefined_Or_Specified_Stream_Attribute)
9902         and then
9903           (Operation /= TSS_Stream_Input
9904             or else not Is_Abstract_Type (Typ)
9905             or else not Is_Derived_Type (Typ))
9906         and then not Has_Unknown_Discriminants (Typ)
9907         and then not
9908           (Is_Interface (Typ)
9909             and then
9910               (Is_Task_Interface (Typ)
9911                 or else Is_Protected_Interface (Typ)
9912                 or else Is_Synchronized_Interface (Typ)))
9913         and then not Restriction_Active (No_Streams)
9914         and then not Restriction_Active (No_Dispatch)
9915         and then No (No_Tagged_Streams_Pragma (Typ))
9916         and then not No_Run_Time_Mode
9917         and then RTE_Available (RE_Tag)
9918         and then No (Type_Without_Stream_Operation (Typ))
9919         and then RTE_Available (RE_Root_Stream_Type)
9920         and then not Is_RTE (Typ, RE_Finalization_Master);
9921    end Stream_Operation_OK;
9922 
9923 end Exp_Ch3;