gcc/ada/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-2005 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Exp_Aggr; use Exp_Aggr;
  33 with Exp_Ch4;  use Exp_Ch4;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Exp_Ch9;  use Exp_Ch9;
  36 with Exp_Ch11; use Exp_Ch11;
  37 with Exp_Disp; use Exp_Disp;
  38 with Exp_Dist; use Exp_Dist;
  39 with Exp_Smem; use Exp_Smem;
  40 with Exp_Strm; use Exp_Strm;
  41 with Exp_Tss;  use Exp_Tss;
  42 with Exp_Util; use Exp_Util;
  43 with Freeze;   use Freeze;
  44 with Hostparm; use Hostparm;
  45 with Nlists;   use Nlists;
  46 with Nmake;    use Nmake;
  47 with Opt;      use Opt;
  48 with Restrict; use Restrict;
  49 with Rident;   use Rident;
  50 with Rtsfind;  use Rtsfind;
  51 with Sem;      use Sem;
  52 with Sem_Attr; use Sem_Attr;
  53 with Sem_Ch3;  use Sem_Ch3;
  54 with Sem_Ch8;  use Sem_Ch8;
  55 with Sem_Eval; use Sem_Eval;
  56 with Sem_Mech; use Sem_Mech;
  57 with Sem_Res;  use Sem_Res;
  58 with Sem_Util; use Sem_Util;
  59 with Sinfo;    use Sinfo;
  60 with Stand;    use Stand;
  61 with Snames;   use Snames;
  62 with Tbuild;   use Tbuild;
  63 with Ttypes;   use Ttypes;
  64 with Validsw;  use Validsw;
  65
  66 package body Exp_Ch3 is
  67
  68    -----------------------
  69    -- Local Subprograms --
  70    -----------------------
  71
  72    procedure Adjust_Discriminants (Rtype : Entity_Id);
  73    --  This is used when freezing a record type. It attempts to construct
  74    --  more restrictive subtypes for discriminants so that the max size of
  75    --  the record can be calculated more accurately. See the body of this
  76    --  procedure for details.
  77
  78    procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
  79    --  Build initialization procedure for given array type. Nod is a node
  80    --  used for attachment of any actions required in its construction.
  81    --  It also supplies the source location used for the procedure.
  82
  83    procedure Build_Class_Wide_Master (T : Entity_Id);
  84    --  for access to class-wide limited types we must build a task master
  85    --  because some subsequent extension may add a task component. To avoid
  86    --  bringing in the tasking run-time whenever an access-to-class-wide
  87    --  limited type is used, we use the soft-link mechanism and add a level
  88    --  of indirection to calls to routines that manipulate Master_Ids.
  89
  90    function Build_Discriminant_Formals
  91      (Rec_Id : Entity_Id;
  92       Use_Dl : Boolean) return List_Id;
  93    --  This function uses the discriminants of a type to build a list of
  94    --  formal parameters, used in the following function. If the flag Use_Dl
  95    --  is set, the list is built using the already defined discriminals
  96    --  of the type. Otherwise new identifiers are created, with the source
  97    --  names of the discriminants.
  98
  99    procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id);
 100    --  If the designated type of an access type is a task type or contains
 101    --  tasks, we make sure that a _Master variable is declared in the current
 102    --  scope, and then declare a renaming for it:
 103    --
 104    --    atypeM : Master_Id renames _Master;
 105    --
 106    --  where atyp is the name of the access type. This declaration is
 107    --  used when an allocator for the access type is expanded. The node N
 108    --  is the full declaration of the designated type that contains tasks.
 109    --  The renaming declaration is inserted before N, and after the Master
 110    --  declaration.
 111
 112    procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id);
 113    --  Build record initialization procedure. N is the type declaration
 114    --  node, and Pe is the corresponding entity for the record type.
 115
 116    procedure Build_Slice_Assignment (Typ : Entity_Id);
 117    --  Build assignment procedure for one-dimensional arrays of controlled
 118    --  types. Other array and slice assignments are expanded in-line, but
 119    --  the code expansion for controlled components (when control actions
 120    --  are active) can lead to very large blocks that GCC3 handles poorly.
 121
 122    procedure Build_Variant_Record_Equality (Typ  : Entity_Id);
 123    --  Create An Equality function for the non-tagged variant record 'Typ'
 124    --  and attach it to the TSS list
 125
 126    procedure Check_Stream_Attributes (Typ : Entity_Id);
 127    --  Check that if a limited extension has a parent with user-defined
 128    --  stream attributes, and does not itself have user-definer
 129    --  stream-attributes, then any limited component of the extension also
 130    --  has the corresponding user-defined stream attributes.
 131
 132    procedure Expand_Tagged_Root (T : Entity_Id);
 133    --  Add a field _Tag at the beginning of the record. This field carries
 134    --  the value of the access to the Dispatch table. This procedure is only
 135    --  called on root (non CPP_Class) types, the _Tag field being inherited
 136    --  by the descendants.
 137
 138    procedure Expand_Record_Controller (T : Entity_Id);
 139    --  T must be a record type that Has_Controlled_Component. Add a field
 140    --  _controller of type Record_Controller or Limited_Record_Controller
 141    --  in the record T.
 142
 143    procedure Freeze_Array_Type (N : Node_Id);
 144    --  Freeze an array type. Deals with building the initialization procedure,
 145    --  creating the packed array type for a packed array and also with the
 146    --  creation of the controlling procedures for the controlled case. The
 147    --  argument N is the N_Freeze_Entity node for the type.
 148
 149    procedure Freeze_Enumeration_Type (N : Node_Id);
 150    --  Freeze enumeration type with non-standard representation. Builds the
 151    --  array and function needed to convert between enumeration pos and
 152    --  enumeration representation values. N is the N_Freeze_Entity node
 153    --  for the type.
 154
 155    procedure Freeze_Record_Type (N : Node_Id);
 156    --  Freeze record type. Builds all necessary discriminant checking
 157    --  and other ancillary functions, and builds dispatch tables where
 158    --  needed. The argument N is the N_Freeze_Entity node. This processing
 159    --  applies only to E_Record_Type entities, not to class wide types,
 160    --  record subtypes, or private types.
 161
 162    procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
 163    --  Treat user-defined stream operations as renaming_as_body if the
 164    --  subprogram they rename is not frozen when the type is frozen.
 165
 166    function Init_Formals (Typ : Entity_Id) return List_Id;
 167    --  This function builds the list of formals for an initialization routine.
 168    --  The first formal is always _Init with the given type. For task value
 169    --  record types and types containing tasks, three additional formals are
 170    --  added:
 171    --
 172    --    _Master    : Master_Id
 173    --    _Chain     : in out Activation_Chain
 174    --    _Task_Name : String
 175    --
 176    --  The caller must append additional entries for discriminants if required.
 177
 178    function In_Runtime (E : Entity_Id) return Boolean;
 179    --  Check if E is defined in the RTL (in a child of Ada or System). Used
 180    --  to avoid to bring in the overhead of _Input, _Output for tagged types.
 181
 182    function Make_Eq_Case
 183      (E     : Entity_Id;
 184       CL    : Node_Id;
 185       Discr : Entity_Id := Empty) return List_Id;
 186    --  Building block for variant record equality. Defined to share the
 187    --  code between the tagged and non-tagged case. Given a Component_List
 188    --  node CL, it generates an 'if' followed by a 'case' statement that
 189    --  compares all components of local temporaries named X and Y (that
 190    --  are declared as formals at some upper level). E provides the Sloc to be
 191    --  used for the generated code. Discr is used as the case statement switch
 192    --  in the case of Unchecked_Union equality.
 193
 194    function Make_Eq_If
 195      (E : Entity_Id;
 196       L : List_Id) return Node_Id;
 197    --  Building block for variant record equality. Defined to share the
 198    --  code between the tagged and non-tagged case. Given the list of
 199    --  components (or discriminants) L, it generates a return statement
 200    --  that compares all components of local temporaries named X and Y
 201    --  (that are declared as formals at some upper level). E provides the Sloc
 202    --  to be used for the generated code.
 203
 204    procedure Make_Predefined_Primitive_Specs
 205      (Tag_Typ     : Entity_Id;
 206       Predef_List : out List_Id;
 207       Renamed_Eq  : out Node_Id);
 208    --  Create a list with the specs of the predefined primitive operations.
 209    --  The following entries are present for all tagged types, and provide
 210    --  the results of the corresponding attribute applied to the object.
 211    --  Dispatching is required in general, since the result of the attribute
 212    --  will vary with the actual object subtype.
 213    --
 214    --     _alignment     provides result of 'Alignment attribute
 215    --     _size          provides result of 'Size attribute
 216    --     typSR          provides result of 'Read attribute
 217    --     typSW          provides result of 'Write attribute
 218    --     typSI          provides result of 'Input attribute
 219    --     typSO          provides result of 'Output attribute
 220    --
 221    --  The following entries are additionally present for non-limited
 222    --  tagged types, and implement additional dispatching operations
 223    --  for predefined operations:
 224    --
 225    --     _equality      implements "=" operator
 226    --     _assign        implements assignment operation
 227    --     typDF          implements deep finalization
 228    --     typDA          implements deep adust
 229    --
 230    --  The latter two are empty procedures unless the type contains some
 231    --  controlled components that require finalization actions (the deep
 232    --  in the name refers to the fact that the action applies to components).
 233    --
 234    --  The list is returned in Predef_List. The Parameter Renamed_Eq
 235    --  either returns the value Empty, or else the defining unit name
 236    --  for the predefined equality function in the case where the type
 237    --  has a primitive operation that is a renaming of predefined equality
 238    --  (but only if there is also an overriding user-defined equality
 239    --  function). The returned Renamed_Eq will be passed to the
 240    --  corresponding parameter of Predefined_Primitive_Bodies.
 241
 242    function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
 243    --  returns True if there are representation clauses for type T that
 244    --  are not inherited. If the result is false, the init_proc and the
 245    --  discriminant_checking functions of the parent can be reused by
 246    --  a derived type.
 247
 248    function Predef_Spec_Or_Body
 249      (Loc      : Source_Ptr;
 250       Tag_Typ  : Entity_Id;
 251       Name     : Name_Id;
 252       Profile  : List_Id;
 253       Ret_Type : Entity_Id := Empty;
 254       For_Body : Boolean   := False) return Node_Id;
 255    --  This function generates the appropriate expansion for a predefined
 256    --  primitive operation specified by its name, parameter profile and
 257    --  return type (Empty means this is a procedure). If For_Body is false,
 258    --  then the returned node is a subprogram declaration. If For_Body is
 259    --  true, then the returned node is a empty subprogram body containing
 260    --  no declarations and no statements.
 261
 262    function Predef_Stream_Attr_Spec
 263      (Loc      : Source_Ptr;
 264       Tag_Typ  : Entity_Id;
 265       Name     : TSS_Name_Type;
 266       For_Body : Boolean := False) return Node_Id;
 267    --  Specialized version of Predef_Spec_Or_Body that apply to read, write,
 268    --  input and output attribute whose specs are constructed in Exp_Strm.
 269
 270    function Predef_Deep_Spec
 271      (Loc      : Source_Ptr;
 272       Tag_Typ  : Entity_Id;
 273       Name     : TSS_Name_Type;
 274       For_Body : Boolean := False) return Node_Id;
 275    --  Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
 276    --  and _deep_finalize
 277
 278    function Predefined_Primitive_Bodies
 279      (Tag_Typ    : Entity_Id;
 280       Renamed_Eq : Node_Id) return List_Id;
 281    --  Create the bodies of the predefined primitives that are described in
 282    --  Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
 283    --  the defining unit name of the type's predefined equality as returned
 284    --  by Make_Predefined_Primitive_Specs.
 285
 286    function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
 287    --  Freeze entities of all predefined primitive operations. This is needed
 288    --  because the bodies of these operations do not normally do any freezeing.
 289
 290    function Stream_Operation_OK
 291      (Typ       : Entity_Id;
 292       Operation : TSS_Name_Type) return Boolean;
 293    --  Check whether the named stream operation must be emitted for a given
 294    --  type. The rules for inheritance of stream attributes by type extensions
 295    --  are enforced by this function. Furthermore, various restrictions prevent
 296    --  the generation of these operations, as a useful optimization or for
 297    --  certification purposes.
 298
 299    --------------------------
 300    -- Adjust_Discriminants --
 301    --------------------------
 302
 303    --  This procedure attempts to define subtypes for discriminants that
 304    --  are more restrictive than those declared. Such a replacement is
 305    --  possible if we can demonstrate that values outside the restricted
 306    --  range would cause constraint errors in any case. The advantage of
 307    --  restricting the discriminant types in this way is tha the maximum
 308    --  size of the variant record can be calculated more conservatively.
 309
 310    --  An example of a situation in which we can perform this type of
 311    --  restriction is the following:
 312
 313    --    subtype B is range 1 .. 10;
 314    --    type Q is array (B range <>) of Integer;
 315
 316    --    type V (N : Natural) is record
 317    --       C : Q (1 .. N);
 318    --    end record;
 319
 320    --  In this situation, we can restrict the upper bound of N to 10, since
 321    --  any larger value would cause a constraint error in any case.
 322
 323    --  There are many situations in which such restriction is possible, but
 324    --  for now, we just look for cases like the above, where the component
 325    --  in question is a one dimensional array whose upper bound is one of
 326    --  the record discriminants. Also the component must not be part of
 327    --  any variant part, since then the component does not always exist.
 328
 329    procedure Adjust_Discriminants (Rtype : Entity_Id) is
 330       Loc   : constant Source_Ptr := Sloc (Rtype);
 331       Comp  : Entity_Id;
 332       Ctyp  : Entity_Id;
 333       Ityp  : Entity_Id;
 334       Lo    : Node_Id;
 335       Hi    : Node_Id;
 336       P     : Node_Id;
 337       Loval : Uint;
 338       Discr : Entity_Id;
 339       Dtyp  : Entity_Id;
 340       Dhi   : Node_Id;
 341       Dhiv  : Uint;
 342       Ahi   : Node_Id;
 343       Ahiv  : Uint;
 344       Tnn   : Entity_Id;
 345
 346    begin
 347       Comp := First_Component (Rtype);
 348       while Present (Comp) loop
 349
 350          --  If our parent is a variant, quit, we do not look at components
 351          --  that are in variant parts, because they may not always exist.
 352
 353          P := Parent (Comp);   -- component declaration
 354          P := Parent (P);      -- component list
 355
 356          exit when Nkind (Parent (P)) = N_Variant;
 357
 358          --  We are looking for a one dimensional array type
 359
 360          Ctyp := Etype (Comp);
 361
 362          if not Is_Array_Type (Ctyp)
 363            or else Number_Dimensions (Ctyp) > 1
 364          then
 365             goto Continue;
 366          end if;
 367
 368          --  The lower bound must be constant, and the upper bound is a
 369          --  discriminant (which is a discriminant of the current record).
 370
 371          Ityp := Etype (First_Index (Ctyp));
 372          Lo := Type_Low_Bound (Ityp);
 373          Hi := Type_High_Bound (Ityp);
 374
 375          if not Compile_Time_Known_Value (Lo)
 376            or else Nkind (Hi) /= N_Identifier
 377            or else No (Entity (Hi))
 378            or else Ekind (Entity (Hi)) /= E_Discriminant
 379          then
 380             goto Continue;
 381          end if;
 382
 383          --  We have an array with appropriate bounds
 384
 385          Loval := Expr_Value (Lo);
 386          Discr := Entity (Hi);
 387          Dtyp  := Etype (Discr);
 388
 389          --  See if the discriminant has a known upper bound
 390
 391          Dhi := Type_High_Bound (Dtyp);
 392
 393          if not Compile_Time_Known_Value (Dhi) then
 394             goto Continue;
 395          end if;
 396
 397          Dhiv := Expr_Value (Dhi);
 398
 399          --  See if base type of component array has known upper bound
 400
 401          Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
 402
 403          if not Compile_Time_Known_Value (Ahi) then
 404             goto Continue;
 405          end if;
 406
 407          Ahiv := Expr_Value (Ahi);
 408
 409          --  The condition for doing the restriction is that the high bound
 410          --  of the discriminant is greater than the low bound of the array,
 411          --  and is also greater than the high bound of the base type index.
 412
 413          if Dhiv > Loval and then Dhiv > Ahiv then
 414
 415             --  We can reset the upper bound of the discriminant type to
 416             --  whichever is larger, the low bound of the component, or
 417             --  the high bound of the base type array index.
 418
 419             --  We build a subtype that is declared as
 420
 421             --     subtype Tnn is discr_type range discr_type'First .. max;
 422
 423             --  And insert this declaration into the tree. The type of the
 424             --  discriminant is then reset to this more restricted subtype.
 425
 426             Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
 427
 428             Insert_Action (Declaration_Node (Rtype),
 429               Make_Subtype_Declaration (Loc,
 430                 Defining_Identifier => Tnn,
 431                 Subtype_Indication =>
 432                   Make_Subtype_Indication (Loc,
 433                     Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
 434                     Constraint   =>
 435                       Make_Range_Constraint (Loc,
 436                         Range_Expression =>
 437                           Make_Range (Loc,
 438                             Low_Bound =>
 439                               Make_Attribute_Reference (Loc,
 440                                 Attribute_Name => Name_First,
 441                                 Prefix => New_Occurrence_Of (Dtyp, Loc)),
 442                             High_Bound =>
 443                               Make_Integer_Literal (Loc,
 444                                 Intval => UI_Max (Loval, Ahiv)))))));
 445
 446             Set_Etype (Discr, Tnn);
 447          end if;
 448
 449       <<Continue>>
 450          Next_Component (Comp);
 451       end loop;
 452    end Adjust_Discriminants;
 453
 454    ---------------------------
 455    -- Build_Array_Init_Proc --
 456    ---------------------------
 457
 458    procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
 459       Loc        : constant Source_Ptr := Sloc (Nod);
 460       Comp_Type  : constant Entity_Id  := Component_Type (A_Type);
 461       Index_List : List_Id;
 462       Proc_Id    : Entity_Id;
 463       Body_Stmts : List_Id;
 464
 465       function Init_Component return List_Id;
 466       --  Create one statement to initialize one array component, designated
 467       --  by a full set of indices.
 468
 469       function Init_One_Dimension (N : Int) return List_Id;
 470       --  Create loop to initialize one dimension of the array. The single
 471       --  statement in the loop body initializes the inner dimensions if any,
 472       --  or else the single component. Note that this procedure is called
 473       --  recursively, with N being the dimension to be initialized. A call
 474       --  with N greater than the number of dimensions simply generates the
 475       --  component initialization, terminating the recursion.
 476
 477       --------------------
 478       -- Init_Component --
 479       --------------------
 480
 481       function Init_Component return List_Id is
 482          Comp : Node_Id;
 483
 484       begin
 485          Comp :=
 486            Make_Indexed_Component (Loc,
 487              Prefix => Make_Identifier (Loc, Name_uInit),
 488              Expressions => Index_List);
 489
 490          if Needs_Simple_Initialization (Comp_Type) then
 491             Set_Assignment_OK (Comp);
 492             return New_List (
 493               Make_Assignment_Statement (Loc,
 494                 Name => Comp,
 495                 Expression =>
 496                   Get_Simple_Init_Val
 497                     (Comp_Type, Loc, Component_Size (A_Type))));
 498
 499          else
 500             return
 501               Build_Initialization_Call (Loc, Comp, Comp_Type, True, A_Type);
 502          end if;
 503       end Init_Component;
 504
 505       ------------------------
 506       -- Init_One_Dimension --
 507       ------------------------
 508
 509       function Init_One_Dimension (N : Int) return List_Id is
 510          Index      : Entity_Id;
 511
 512       begin
 513          --  If the component does not need initializing, then there is nothing
 514          --  to do here, so we return a null body. This occurs when generating
 515          --  the dummy Init_Proc needed for Initialize_Scalars processing.
 516
 517          if not Has_Non_Null_Base_Init_Proc (Comp_Type)
 518            and then not Needs_Simple_Initialization (Comp_Type)
 519            and then not Has_Task (Comp_Type)
 520          then
 521             return New_List (Make_Null_Statement (Loc));
 522
 523          --  If all dimensions dealt with, we simply initialize the component
 524
 525          elsif N > Number_Dimensions (A_Type) then
 526             return Init_Component;
 527
 528          --  Here we generate the required loop
 529
 530          else
 531             Index :=
 532               Make_Defining_Identifier (Loc, New_External_Name ('J', N));
 533
 534             Append (New_Reference_To (Index, Loc), Index_List);
 535
 536             return New_List (
 537               Make_Implicit_Loop_Statement (Nod,
 538                 Identifier => Empty,
 539                 Iteration_Scheme =>
 540                   Make_Iteration_Scheme (Loc,
 541                     Loop_Parameter_Specification =>
 542                       Make_Loop_Parameter_Specification (Loc,
 543                         Defining_Identifier => Index,
 544                         Discrete_Subtype_Definition =>
 545                           Make_Attribute_Reference (Loc,
 546                             Prefix => Make_Identifier (Loc, Name_uInit),
 547                             Attribute_Name  => Name_Range,
 548                             Expressions => New_List (
 549                               Make_Integer_Literal (Loc, N))))),
 550                 Statements =>  Init_One_Dimension (N + 1)));
 551          end if;
 552       end Init_One_Dimension;
 553
 554    --  Start of processing for Build_Array_Init_Proc
 555
 556    begin
 557       if Suppress_Init_Proc (A_Type) then
 558          return;
 559       end if;
 560
 561       Index_List := New_List;
 562
 563       --  We need an initialization procedure if any of the following is true:
 564
 565       --    1. The component type has an initialization procedure
 566       --    2. The component type needs simple initialization
 567       --    3. Tasks are present
 568       --    4. The type is marked as a publc entity
 569
 570       --  The reason for the public entity test is to deal properly with the
 571       --  Initialize_Scalars pragma. This pragma can be set in the client and
 572       --  not in the declaring package, this means the client will make a call
 573       --  to the initialization procedure (because one of conditions 1-3 must
 574       --  apply in this case), and we must generate a procedure (even if it is
 575       --  null) to satisfy the call in this case.
 576
 577       --  Exception: do not build an array init_proc for a type whose root
 578       --  type is Standard.String or Standard.Wide_[Wide_]String, since there
 579       --  is no place to put the code, and in any case we handle initialization
 580       --  of such types (in the Initialize_Scalars case, that's the only time
 581       --  the issue arises) in a special manner anyway which does not need an
 582       --  init_proc.
 583
 584       if Has_Non_Null_Base_Init_Proc (Comp_Type)
 585         or else Needs_Simple_Initialization (Comp_Type)
 586         or else Has_Task (Comp_Type)
 587         or else (not Restriction_Active (No_Initialize_Scalars)
 588                    and then Is_Public (A_Type)
 589                    and then Root_Type (A_Type) /= Standard_String
 590                    and then Root_Type (A_Type) /= Standard_Wide_String
 591                    and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
 592       then
 593          Proc_Id :=
 594            Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type));
 595
 596          Body_Stmts := Init_One_Dimension (1);
 597
 598          Discard_Node (
 599            Make_Subprogram_Body (Loc,
 600              Specification =>
 601                Make_Procedure_Specification (Loc,
 602                  Defining_Unit_Name => Proc_Id,
 603                  Parameter_Specifications => Init_Formals (A_Type)),
 604              Declarations => New_List,
 605              Handled_Statement_Sequence =>
 606                Make_Handled_Sequence_Of_Statements (Loc,
 607                  Statements => Body_Stmts)));
 608
 609          Set_Ekind          (Proc_Id, E_Procedure);
 610          Set_Is_Public      (Proc_Id, Is_Public (A_Type));
 611          Set_Is_Internal    (Proc_Id);
 612          Set_Has_Completion (Proc_Id);
 613
 614          if not Debug_Generated_Code then
 615             Set_Debug_Info_Off (Proc_Id);
 616          end if;
 617
 618          --  Set inlined unless controlled stuff or tasks around, in which
 619          --  case we do not want to inline, because nested stuff may cause
 620          --  difficulties in interunit inlining, and furthermore there is
 621          --  in any case no point in inlining such complex init procs.
 622
 623          if not Has_Task (Proc_Id)
 624            and then not Controlled_Type (Proc_Id)
 625          then
 626             Set_Is_Inlined (Proc_Id);
 627          end if;
 628
 629          --  Associate Init_Proc with type, and determine if the procedure
 630          --  is null (happens because of the Initialize_Scalars pragma case,
 631          --  where we have to generate a null procedure in case it is called
 632          --  by a client with Initialize_Scalars set). Such procedures have
 633          --  to be generated, but do not have to be called, so we mark them
 634          --  as null to suppress the call.
 635
 636          Set_Init_Proc (A_Type, Proc_Id);
 637
 638          if List_Length (Body_Stmts) = 1
 639            and then Nkind (First (Body_Stmts)) = N_Null_Statement
 640          then
 641             Set_Is_Null_Init_Proc (Proc_Id);
 642          end if;
 643       end if;
 644    end Build_Array_Init_Proc;
 645
 646    -----------------------------
 647    -- Build_Class_Wide_Master --
 648    -----------------------------
 649
 650    procedure Build_Class_Wide_Master (T : Entity_Id) is
 651       Loc  : constant Source_Ptr := Sloc (T);
 652       M_Id : Entity_Id;
 653       Decl : Node_Id;
 654       P    : Node_Id;
 655
 656    begin
 657       --  Nothing to do if there is no task hierarchy
 658
 659       if Restriction_Active (No_Task_Hierarchy) then
 660          return;
 661       end if;
 662
 663       --  Nothing to do if we already built a master entity for this scope
 664
 665       if not Has_Master_Entity (Scope (T)) then
 666
 667          --  first build the master entity
 668          --    _Master : constant Master_Id := Current_Master.all;
 669          --  and insert it just before the current declaration
 670
 671          Decl :=
 672            Make_Object_Declaration (Loc,
 673              Defining_Identifier =>
 674                Make_Defining_Identifier (Loc, Name_uMaster),
 675              Constant_Present => True,
 676              Object_Definition => New_Reference_To (Standard_Integer, Loc),
 677              Expression =>
 678                Make_Explicit_Dereference (Loc,
 679                  New_Reference_To (RTE (RE_Current_Master), Loc)));
 680
 681          P := Parent (T);
 682          Insert_Before (P, Decl);
 683          Analyze (Decl);
 684          Set_Has_Master_Entity (Scope (T));
 685
 686          --  Now mark the containing scope as a task master
 687
 688          while Nkind (P) /= N_Compilation_Unit loop
 689             P := Parent (P);
 690
 691             --  If we fall off the top, we are at the outer level, and the
 692             --  environment task is our effective master, so nothing to mark.
 693
 694             if Nkind (P) = N_Task_Body
 695               or else Nkind (P) = N_Block_Statement
 696               or else Nkind (P) = N_Subprogram_Body
 697             then
 698                Set_Is_Task_Master (P, True);
 699                exit;
 700             end if;
 701          end loop;
 702       end if;
 703
 704       --  Now define the renaming of the master_id
 705
 706       M_Id :=
 707         Make_Defining_Identifier (Loc,
 708           New_External_Name (Chars (T), 'M'));
 709
 710       Decl :=
 711         Make_Object_Renaming_Declaration (Loc,
 712           Defining_Identifier => M_Id,
 713           Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
 714           Name => Make_Identifier (Loc, Name_uMaster));
 715       Insert_Before (Parent (T), Decl);
 716       Analyze (Decl);
 717
 718       Set_Master_Id (T, M_Id);
 719
 720    exception
 721       when RE_Not_Available =>
 722          return;
 723    end Build_Class_Wide_Master;
 724
 725    --------------------------------
 726    -- Build_Discr_Checking_Funcs --
 727    --------------------------------
 728
 729    procedure Build_Discr_Checking_Funcs (N : Node_Id) is
 730       Rec_Id            : Entity_Id;
 731       Loc               : Source_Ptr;
 732       Enclosing_Func_Id : Entity_Id;
 733       Sequence          : Nat     := 1;
 734       Type_Def          : Node_Id;
 735       V                 : Node_Id;
 736
 737       function Build_Case_Statement
 738         (Case_Id : Entity_Id;
 739          Variant : Node_Id) return Node_Id;
 740       --  Build a case statement containing only two alternatives. The
 741       --  first alternative corresponds exactly to the discrete choices
 742       --  given on the variant with contains the components that we are
 743       --  generating the checks for. If the discriminant is one of these
 744       --  return False. The second alternative is an OTHERS choice that
 745       --  will return True indicating the discriminant did not match.
 746
 747       function Build_Dcheck_Function
 748         (Case_Id : Entity_Id;
 749          Variant : Node_Id) return Entity_Id;
 750       --  Build the discriminant checking function for a given variant
 751
 752       procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
 753       --  Builds the discriminant checking function for each variant of the
 754       --  given variant part of the record type.
 755
 756       --------------------------
 757       -- Build_Case_Statement --
 758       --------------------------
 759
 760       function Build_Case_Statement
 761         (Case_Id : Entity_Id;
 762          Variant : Node_Id) return Node_Id
 763       is
 764          Alt_List       : constant List_Id := New_List;
 765          Actuals_List   : List_Id;
 766          Case_Node      : Node_Id;
 767          Case_Alt_Node  : Node_Id;
 768          Choice         : Node_Id;
 769          Choice_List    : List_Id;
 770          D              : Entity_Id;
 771          Return_Node    : Node_Id;
 772
 773       begin
 774          Case_Node := New_Node (N_Case_Statement, Loc);
 775
 776          --  Replace the discriminant which controls the variant, with the
 777          --  name of the formal of the checking function.
 778
 779          Set_Expression (Case_Node,
 780            Make_Identifier (Loc, Chars (Case_Id)));
 781
 782          Choice := First (Discrete_Choices (Variant));
 783
 784          if Nkind (Choice) = N_Others_Choice then
 785             Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
 786          else
 787             Choice_List := New_Copy_List (Discrete_Choices (Variant));
 788          end if;
 789
 790          if not Is_Empty_List (Choice_List) then
 791             Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
 792             Set_Discrete_Choices (Case_Alt_Node, Choice_List);
 793
 794             --  In case this is a nested variant, we need to return the result
 795             --  of the discriminant checking function for the immediately
 796             --  enclosing variant.
 797
 798             if Present (Enclosing_Func_Id) then
 799                Actuals_List := New_List;
 800
 801                D := First_Discriminant (Rec_Id);
 802                while Present (D) loop
 803                   Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
 804                   Next_Discriminant (D);
 805                end loop;
 806
 807                Return_Node :=
 808                  Make_Return_Statement (Loc,
 809                    Expression =>
 810                      Make_Function_Call (Loc,
 811                        Name =>
 812                          New_Reference_To (Enclosing_Func_Id,  Loc),
 813                        Parameter_Associations =>
 814                          Actuals_List));
 815
 816             else
 817                Return_Node :=
 818                  Make_Return_Statement (Loc,
 819                    Expression =>
 820                      New_Reference_To (Standard_False, Loc));
 821             end if;
 822
 823             Set_Statements (Case_Alt_Node, New_List (Return_Node));
 824             Append (Case_Alt_Node, Alt_List);
 825          end if;
 826
 827          Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
 828          Choice_List := New_List (New_Node (N_Others_Choice, Loc));
 829          Set_Discrete_Choices (Case_Alt_Node, Choice_List);
 830
 831          Return_Node :=
 832            Make_Return_Statement (Loc,
 833              Expression =>
 834                New_Reference_To (Standard_True, Loc));
 835
 836          Set_Statements (Case_Alt_Node, New_List (Return_Node));
 837          Append (Case_Alt_Node, Alt_List);
 838
 839          Set_Alternatives (Case_Node, Alt_List);
 840          return Case_Node;
 841       end Build_Case_Statement;
 842
 843       ---------------------------
 844       -- Build_Dcheck_Function --
 845       ---------------------------
 846
 847       function Build_Dcheck_Function
 848         (Case_Id : Entity_Id;
 849          Variant : Node_Id) return Entity_Id
 850       is
 851          Body_Node           : Node_Id;
 852          Func_Id             : Entity_Id;
 853          Parameter_List      : List_Id;
 854          Spec_Node           : Node_Id;
 855
 856       begin
 857          Body_Node := New_Node (N_Subprogram_Body, Loc);
 858          Sequence := Sequence + 1;
 859
 860          Func_Id :=
 861            Make_Defining_Identifier (Loc,
 862              Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
 863
 864          Spec_Node := New_Node (N_Function_Specification, Loc);
 865          Set_Defining_Unit_Name (Spec_Node, Func_Id);
 866
 867          Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
 868
 869          Set_Parameter_Specifications (Spec_Node, Parameter_List);
 870          Set_Subtype_Mark (Spec_Node,
 871                            New_Reference_To (Standard_Boolean,  Loc));
 872          Set_Specification (Body_Node, Spec_Node);
 873          Set_Declarations (Body_Node, New_List);
 874
 875          Set_Handled_Statement_Sequence (Body_Node,
 876            Make_Handled_Sequence_Of_Statements (Loc,
 877              Statements => New_List (
 878                Build_Case_Statement (Case_Id, Variant))));
 879
 880          Set_Ekind       (Func_Id, E_Function);
 881          Set_Mechanism   (Func_Id, Default_Mechanism);
 882          Set_Is_Inlined  (Func_Id, True);
 883          Set_Is_Pure     (Func_Id, True);
 884          Set_Is_Public   (Func_Id, Is_Public (Rec_Id));
 885          Set_Is_Internal (Func_Id, True);
 886
 887          if not Debug_Generated_Code then
 888             Set_Debug_Info_Off (Func_Id);
 889          end if;
 890
 891          Analyze (Body_Node);
 892
 893          Append_Freeze_Action (Rec_Id, Body_Node);
 894          Set_Dcheck_Function (Variant, Func_Id);
 895          return Func_Id;
 896       end Build_Dcheck_Function;
 897
 898       ----------------------------
 899       -- Build_Dcheck_Functions --
 900       ----------------------------
 901
 902       procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
 903          Component_List_Node : Node_Id;
 904          Decl                : Entity_Id;
 905          Discr_Name          : Entity_Id;
 906          Func_Id             : Entity_Id;
 907          Variant             : Node_Id;
 908          Saved_Enclosing_Func_Id : Entity_Id;
 909
 910       begin
 911          --  Build the discriminant checking function for each variant, label
 912          --  all components of that variant with the function's name.
 913
 914          Discr_Name := Entity (Name (Variant_Part_Node));
 915          Variant := First_Non_Pragma (Variants (Variant_Part_Node));
 916
 917          while Present (Variant) loop
 918             Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
 919             Component_List_Node := Component_List (Variant);
 920
 921             if not Null_Present (Component_List_Node) then
 922                Decl :=
 923                  First_Non_Pragma (Component_Items (Component_List_Node));
 924
 925                while Present (Decl) loop
 926                   Set_Discriminant_Checking_Func
 927                     (Defining_Identifier (Decl), Func_Id);
 928
 929                   Next_Non_Pragma (Decl);
 930                end loop;
 931
 932                if Present (Variant_Part (Component_List_Node)) then
 933                   Saved_Enclosing_Func_Id := Enclosing_Func_Id;
 934                   Enclosing_Func_Id := Func_Id;
 935                   Build_Dcheck_Functions (Variant_Part (Component_List_Node));
 936                   Enclosing_Func_Id := Saved_Enclosing_Func_Id;
 937                end if;
 938             end if;
 939
 940             Next_Non_Pragma (Variant);
 941          end loop;
 942       end Build_Dcheck_Functions;
 943
 944    --  Start of processing for Build_Discr_Checking_Funcs
 945
 946    begin
 947       --  Only build if not done already
 948
 949       if not Discr_Check_Funcs_Built (N) then
 950          Type_Def := Type_Definition (N);
 951
 952          if Nkind (Type_Def) = N_Record_Definition then
 953             if No (Component_List (Type_Def)) then   -- null record.
 954                return;
 955             else
 956                V := Variant_Part (Component_List (Type_Def));
 957             end if;
 958
 959          else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
 960             if No (Component_List (Record_Extension_Part (Type_Def))) then
 961                return;
 962             else
 963                V := Variant_Part
 964                       (Component_List (Record_Extension_Part (Type_Def)));
 965             end if;
 966          end if;
 967
 968          Rec_Id := Defining_Identifier (N);
 969
 970          if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
 971             Loc := Sloc (N);
 972             Enclosing_Func_Id := Empty;
 973             Build_Dcheck_Functions (V);
 974          end if;
 975
 976          Set_Discr_Check_Funcs_Built (N);
 977       end if;
 978    end Build_Discr_Checking_Funcs;
 979
 980    --------------------------------
 981    -- Build_Discriminant_Formals --
 982    --------------------------------
 983
 984    function Build_Discriminant_Formals
 985      (Rec_Id : Entity_Id;
 986       Use_Dl : Boolean) return List_Id
 987    is
 988       Loc             : Source_Ptr       := Sloc (Rec_Id);
 989       Parameter_List  : constant List_Id := New_List;
 990       D               : Entity_Id;
 991       Formal          : Entity_Id;
 992       Param_Spec_Node : Node_Id;
 993
 994    begin
 995       if Has_Discriminants (Rec_Id) then
 996          D := First_Discriminant (Rec_Id);
 997          while Present (D) loop
 998             Loc := Sloc (D);
 999
1000             if Use_Dl then
1001                Formal := Discriminal (D);
1002             else
1003                Formal := Make_Defining_Identifier (Loc, Chars (D));
1004             end if;
1005
1006             Param_Spec_Node :=
1007               Make_Parameter_Specification (Loc,
1008                   Defining_Identifier => Formal,
1009                 Parameter_Type =>
1010                   New_Reference_To (Etype (D), Loc));
1011             Append (Param_Spec_Node, Parameter_List);
1012             Next_Discriminant (D);
1013          end loop;
1014       end if;
1015
1016       return Parameter_List;
1017    end Build_Discriminant_Formals;
1018
1019    -------------------------------
1020    -- Build_Initialization_Call --
1021    -------------------------------
1022
1023    --  References to a discriminant inside the record type declaration
1024    --  can appear either in the subtype_indication to constrain a
1025    --  record or an array, or as part of a larger expression given for
1026    --  the initial value of a component. In both of these cases N appears
1027    --  in the record initialization procedure and needs to be replaced by
1028    --  the formal parameter of the initialization procedure which
1029    --  corresponds to that discriminant.
1030
1031    --  In the example below, references to discriminants D1 and D2 in proc_1
1032    --  are replaced by references to formals with the same name
1033    --  (discriminals)
1034
1035    --  A similar replacement is done for calls to any record
1036    --  initialization procedure for any components that are themselves
1037    --  of a record type.
1038
1039    --  type R (D1, D2 : Integer) is record
1040    --     X : Integer := F * D1;
1041    --     Y : Integer := F * D2;
1042    --  end record;
1043
1044    --  procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1045    --  begin
1046    --     Out_2.D1 := D1;
1047    --     Out_2.D2 := D2;
1048    --     Out_2.X := F * D1;
1049    --     Out_2.Y := F * D2;
1050    --  end;
1051
1052    function Build_Initialization_Call
1053      (Loc               : Source_Ptr;
1054       Id_Ref            : Node_Id;
1055       Typ               : Entity_Id;
1056       In_Init_Proc      : Boolean := False;
1057       Enclos_Type       : Entity_Id := Empty;
1058       Discr_Map         : Elist_Id := New_Elmt_List;
1059       With_Default_Init : Boolean := False) return List_Id
1060    is
1061       First_Arg      : Node_Id;
1062       Args           : List_Id;
1063       Decls          : List_Id;
1064       Decl           : Node_Id;
1065       Discr          : Entity_Id;
1066       Arg            : Node_Id;
1067       Proc           : constant Entity_Id := Base_Init_Proc (Typ);
1068       Init_Type      : constant Entity_Id := Etype (First_Formal (Proc));
1069       Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type);
1070       Res            : constant List_Id   := New_List;
1071       Full_Type      : Entity_Id := Typ;
1072       Controller_Typ : Entity_Id;
1073
1074    begin
1075       --  Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1076       --  is active (in which case we make the call anyway, since in the
1077       --  actual compiled client it may be non null).
1078
1079       if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
1080          return Empty_List;
1081       end if;
1082
1083       --  Go to full view if private type. In the case of successive
1084       --  private derivations, this can require more than one step.
1085
1086       while Is_Private_Type (Full_Type)
1087         and then Present (Full_View (Full_Type))
1088       loop
1089          Full_Type := Full_View (Full_Type);
1090       end loop;
1091
1092       --  If Typ is derived, the procedure is the initialization procedure for
1093       --  the root type. Wrap the argument in an conversion to make it type
1094       --  honest. Actually it isn't quite type honest, because there can be
1095       --  conflicts of views in the private type case. That is why we set
1096       --  Conversion_OK in the conversion node.
1097       if (Is_Record_Type (Typ)
1098            or else Is_Array_Type (Typ)
1099            or else Is_Private_Type (Typ))
1100         and then Init_Type /= Base_Type (Typ)
1101       then
1102          First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
1103          Set_Etype (First_Arg, Init_Type);
1104
1105       else
1106          First_Arg := Id_Ref;
1107       end if;
1108
1109       Args := New_List (Convert_Concurrent (First_Arg, Typ));
1110
1111       --  In the tasks case, add _Master as the value of the _Master parameter
1112       --  and _Chain as the value of the _Chain parameter. At the outer level,
1113       --  these will be variables holding the corresponding values obtained
1114       --  from GNARL. At inner levels, they will be the parameters passed down
1115       --  through the outer routines.
1116
1117       if Has_Task (Full_Type) then
1118          if Restriction_Active (No_Task_Hierarchy) then
1119
1120             --  See comments in System.Tasking.Initialization.Init_RTS
1121             --  for the value 3 (should be rtsfindable constant ???)
1122
1123             Append_To (Args, Make_Integer_Literal (Loc, 3));
1124          else
1125             Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1126          end if;
1127
1128          Append_To (Args, Make_Identifier (Loc, Name_uChain));
1129
1130          --  Ada 2005 (AI-287): In case of default initialized components
1131          --  with tasks, we generate a null string actual parameter.
1132          --  This is just a workaround that must be improved later???
1133
1134          if With_Default_Init then
1135             Append_To (Args,
1136               Make_String_Literal (Loc,
1137                 Strval => ""));
1138
1139          else
1140             Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
1141             Decl  := Last (Decls);
1142
1143             Append_To (Args,
1144               New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1145             Append_List (Decls, Res);
1146          end if;
1147
1148       else
1149          Decls := No_List;
1150          Decl  := Empty;
1151       end if;
1152
1153       --  Add discriminant values if discriminants are present
1154
1155       if Has_Discriminants (Full_Init_Type) then
1156          Discr := First_Discriminant (Full_Init_Type);
1157
1158          while Present (Discr) loop
1159
1160             --  If this is a discriminated concurrent type, the init_proc
1161             --  for the corresponding record is being called. Use that
1162             --  type directly to find the discriminant value, to handle
1163             --  properly intervening renamed discriminants.
1164
1165             declare
1166                T : Entity_Id := Full_Type;
1167
1168             begin
1169                if Is_Protected_Type (T) then
1170                   T := Corresponding_Record_Type (T);
1171
1172                elsif Is_Private_Type (T)
1173                  and then Present (Underlying_Full_View (T))
1174                  and then Is_Protected_Type (Underlying_Full_View (T))
1175                then
1176                   T := Corresponding_Record_Type (Underlying_Full_View (T));
1177                end if;
1178
1179                Arg :=
1180                  Get_Discriminant_Value (
1181                    Discr,
1182                    T,
1183                    Discriminant_Constraint (Full_Type));
1184             end;
1185
1186             if In_Init_Proc then
1187
1188                --  Replace any possible references to the discriminant in the
1189                --  call to the record initialization procedure with references
1190                --  to the appropriate formal parameter.
1191
1192                if Nkind (Arg) = N_Identifier
1193                   and then Ekind (Entity (Arg)) = E_Discriminant
1194                then
1195                   Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc);
1196
1197                --  Case of access discriminants. We replace the reference
1198                --  to the type by a reference to the actual object
1199
1200                elsif Nkind (Arg) = N_Attribute_Reference
1201                  and then Is_Access_Type (Etype (Arg))
1202                  and then Is_Entity_Name (Prefix (Arg))
1203                  and then Is_Type (Entity (Prefix (Arg)))
1204                then
1205                   Arg :=
1206                     Make_Attribute_Reference (Loc,
1207                       Prefix         => New_Copy (Prefix (Id_Ref)),
1208                       Attribute_Name => Name_Unrestricted_Access);
1209
1210                --  Otherwise make a copy of the default expression. Note
1211                --  that we use the current Sloc for this, because we do not
1212                --  want the call to appear to be at the declaration point.
1213                --  Within the expression, replace discriminants with their
1214                --  discriminals.
1215
1216                else
1217                   Arg :=
1218                     New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
1219                end if;
1220
1221             else
1222                if Is_Constrained (Full_Type) then
1223                   Arg := Duplicate_Subexpr_No_Checks (Arg);
1224                else
1225                   --  The constraints come from the discriminant default
1226                   --  exps, they must be reevaluated, so we use New_Copy_Tree
1227                   --  but we ensure the proper Sloc (for any embedded calls).
1228
1229                   Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
1230                end if;
1231             end if;
1232
1233             --  Ada 2005 (AI-287) In case of default initialized components,
1234             --  we need to generate the corresponding selected component node
1235             --  to access the discriminant value. In other cases this is not
1236             --  required because we are inside the init proc and we use the
1237             --  corresponding formal.
1238
1239             if With_Default_Init
1240               and then Nkind (Id_Ref) = N_Selected_Component
1241             then
1242                Append_To (Args,
1243                  Make_Selected_Component (Loc,
1244                    Prefix => New_Copy_Tree (Prefix (Id_Ref)),
1245                    Selector_Name => Arg));
1246             else
1247                Append_To (Args, Arg);
1248             end if;
1249
1250             Next_Discriminant (Discr);
1251          end loop;
1252       end if;
1253
1254       --  If this is a call to initialize the parent component of a derived
1255       --  tagged type, indicate that the tag should not be set in the parent.
1256
1257       if Is_Tagged_Type (Full_Init_Type)
1258         and then not Is_CPP_Class (Full_Init_Type)
1259         and then Nkind (Id_Ref) = N_Selected_Component
1260         and then Chars (Selector_Name (Id_Ref)) = Name_uParent
1261       then
1262          Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
1263       end if;
1264
1265       Append_To (Res,
1266         Make_Procedure_Call_Statement (Loc,
1267           Name => New_Occurrence_Of (Proc, Loc),
1268           Parameter_Associations => Args));
1269
1270       if Controlled_Type (Typ)
1271         and then Nkind (Id_Ref) = N_Selected_Component
1272       then
1273          if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
1274             Append_List_To (Res,
1275               Make_Init_Call (
1276                 Ref         => New_Copy_Tree (First_Arg),
1277                 Typ         => Typ,
1278                 Flist_Ref   =>
1279                   Find_Final_List (Typ, New_Copy_Tree (First_Arg)),
1280                 With_Attach => Make_Integer_Literal (Loc, 1)));
1281
1282          --  If the enclosing type is an extension with new controlled
1283          --  components, it has his own record controller. If the parent
1284          --  also had a record controller, attach it to the new one.
1285          --  Build_Init_Statements relies on the fact that in this specific
1286          --  case the last statement of the result is the attach call to
1287          --  the controller. If this is changed, it must be synchronized.
1288
1289          elsif Present (Enclos_Type)
1290            and then Has_New_Controlled_Component (Enclos_Type)
1291            and then Has_Controlled_Component (Typ)
1292          then
1293             if Is_Return_By_Reference_Type (Typ) then
1294                Controller_Typ := RTE (RE_Limited_Record_Controller);
1295             else
1296                Controller_Typ := RTE (RE_Record_Controller);
1297             end if;
1298
1299             Append_List_To (Res,
1300               Make_Init_Call (
1301                 Ref       =>
1302                   Make_Selected_Component (Loc,
1303                     Prefix        => New_Copy_Tree (First_Arg),
1304                     Selector_Name => Make_Identifier (Loc, Name_uController)),
1305                 Typ       => Controller_Typ,
1306                 Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)),
1307                 With_Attach => Make_Integer_Literal (Loc, 1)));
1308          end if;
1309       end if;
1310
1311       return Res;
1312
1313    exception
1314       when RE_Not_Available =>
1315          return Empty_List;
1316    end Build_Initialization_Call;
1317
1318    ---------------------------
1319    -- Build_Master_Renaming --
1320    ---------------------------
1321
1322    procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is
1323       Loc  : constant Source_Ptr := Sloc (N);
1324       M_Id : Entity_Id;
1325       Decl : Node_Id;
1326
1327    begin
1328       --  Nothing to do if there is no task hierarchy
1329
1330       if Restriction_Active (No_Task_Hierarchy) then
1331          return;
1332       end if;
1333
1334       M_Id :=
1335         Make_Defining_Identifier (Loc,
1336           New_External_Name (Chars (T), 'M'));
1337
1338       Decl :=
1339         Make_Object_Renaming_Declaration (Loc,
1340           Defining_Identifier => M_Id,
1341           Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc),
1342           Name => Make_Identifier (Loc, Name_uMaster));
1343       Insert_Before (N, Decl);
1344       Analyze (Decl);
1345
1346       Set_Master_Id (T, M_Id);
1347
1348    exception
1349       when RE_Not_Available =>
1350          return;
1351    end Build_Master_Renaming;
1352
1353    ----------------------------
1354    -- Build_Record_Init_Proc --
1355    ----------------------------
1356
1357    procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is
1358       Loc         : Source_Ptr := Sloc (N);
1359       Discr_Map   : constant Elist_Id := New_Elmt_List;
1360       Proc_Id     : Entity_Id;
1361       Rec_Type    : Entity_Id;
1362       Set_Tag     : Entity_Id := Empty;
1363
1364       ADT      : Elmt_Id;
1365       Aux_N    : Node_Id;
1366       Aux_Comp : Node_Id;
1367
1368       function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
1369       --  Build a assignment statement node which assigns to record
1370       --  component its default expression if defined. The left hand side
1371       --  of the assignment is marked Assignment_OK so that initialization
1372       --  of limited private records works correctly, Return also the
1373       --  adjustment call for controlled objects
1374
1375       procedure Build_Discriminant_Assignments (Statement_List : List_Id);
1376       --  If the record has discriminants, adds assignment statements to
1377       --  statement list to initialize the discriminant values from the
1378       --  arguments of the initialization procedure.
1379
1380       function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
1381       --  Build a list representing a sequence of statements which initialize
1382       --  components of the given component list. This may involve building
1383       --  case statements for the variant parts.
1384
1385       function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
1386       --  Given a non-tagged type-derivation that declares discriminants,
1387       --  such as
1388       --
1389       --  type R (R1, R2 : Integer) is record ... end record;
1390       --
1391       --  type D (D1 : Integer) is new R (1, D1);
1392       --
1393       --  we make the _init_proc of D be
1394       --
1395       --       procedure _init_proc(X : D; D1 : Integer) is
1396       --       begin
1397       --          _init_proc( R(X), 1, D1);
1398       --       end _init_proc;
1399       --
1400       --  This function builds the call statement in this _init_proc.
1401
1402       procedure Build_Init_Procedure;
1403       --  Build the tree corresponding to the procedure specification and body
1404       --  of the initialization procedure (by calling all the preceding
1405       --  auxiliary routines), and install it as the _init TSS.
1406
1407       procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
1408       --  Add range checks to components of disciminated records. S is a
1409       --  subtype indication of a record component. Check_List is a list
1410       --  to which the check actions are appended.
1411
1412       function Component_Needs_Simple_Initialization
1413         (T : Entity_Id) return Boolean;
1414       --  Determines if a component needs simple initialization, given its type
1415       --  T. This is the same as Needs_Simple_Initialization except for the
1416       --  following difference: the types Tag, Interface_Tag, and Vtable_Ptr
1417       --  which are access types which would normally require simple
1418       --  initialization to null, do not require initialization as components,
1419       --  since they are explicitly initialized by other means.
1420
1421       procedure Constrain_Array
1422         (SI         : Node_Id;
1423          Check_List : List_Id);
1424       --  Called from Build_Record_Checks.
1425       --  Apply a list of index constraints to an unconstrained array type.
1426       --  The first parameter is the entity for the resulting subtype.
1427       --  Check_List is a list to which the check actions are appended.
1428
1429       procedure Constrain_Index
1430         (Index      : Node_Id;
1431          S          : Node_Id;
1432          Check_List : List_Id);
1433       --  Called from Build_Record_Checks.
1434       --  Process an index constraint in a constrained array declaration.
1435       --  The constraint can be a subtype name, or a range with or without
1436       --  an explicit subtype mark. The index is the corresponding index of the
1437       --  unconstrained array. S is the range expression. Check_List is a list
1438       --  to which the check actions are appended.
1439
1440       function Parent_Subtype_Renaming_Discrims return Boolean;
1441       --  Returns True for base types N that rename discriminants, else False
1442
1443       function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
1444       --  Determines whether a record initialization procedure needs to be
1445       --  generated for the given record type.
1446
1447       ----------------------
1448       -- Build_Assignment --
1449       ----------------------
1450
1451       function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
1452          Exp  : Node_Id := N;
1453          Lhs  : Node_Id;
1454          Typ  : constant Entity_Id := Underlying_Type (Etype (Id));
1455          Kind : Node_Kind := Nkind (N);
1456          Res  : List_Id;
1457
1458       begin
1459          Loc := Sloc (N);
1460          Lhs :=
1461            Make_Selected_Component (Loc,
1462              Prefix => Make_Identifier (Loc, Name_uInit),
1463              Selector_Name => New_Occurrence_Of (Id, Loc));
1464          Set_Assignment_OK (Lhs);
1465
1466          --  Case of an access attribute applied to the current instance.
1467          --  Replace the reference to the type by a reference to the actual
1468          --  object. (Note that this handles the case of the top level of
1469          --  the expression being given by such an attribute, but does not
1470          --  cover uses nested within an initial value expression. Nested
1471          --  uses are unlikely to occur in practice, but are theoretically
1472          --  possible. It is not clear how to handle them without fully
1473          --  traversing the expression. ???
1474
1475          if Kind = N_Attribute_Reference
1476            and then (Attribute_Name (N) = Name_Unchecked_Access
1477                        or else
1478                      Attribute_Name (N) = Name_Unrestricted_Access)
1479            and then Is_Entity_Name (Prefix (N))
1480            and then Is_Type (Entity (Prefix (N)))
1481            and then Entity (Prefix (N)) = Rec_Type
1482          then
1483             Exp :=
1484               Make_Attribute_Reference (Loc,
1485                 Prefix         => Make_Identifier (Loc, Name_uInit),
1486                 Attribute_Name => Name_Unrestricted_Access);
1487          end if;
1488
1489          --  Ada 2005 (AI-231): Generate conversion to the null-excluding
1490          --  type to force the corresponding run-time check.
1491
1492          if Ada_Version >= Ada_05
1493            and then Can_Never_Be_Null (Etype (Id))  -- Lhs
1494            and then Present (Etype (Exp))
1495            and then not Can_Never_Be_Null (Etype (Exp))
1496          then
1497             Rewrite (Exp, Convert_To (Etype (Id), Relocate_Node (Exp)));
1498             Analyze_And_Resolve (Exp, Etype (Id));
1499          end if;
1500
1501          --  Take a copy of Exp to ensure that later copies of this
1502          --  component_declaration in derived types see the original tree,
1503          --  not a node rewritten during expansion of the init_proc.
1504
1505          Exp := New_Copy_Tree (Exp);
1506
1507          Res := New_List (
1508            Make_Assignment_Statement (Loc,
1509              Name       => Lhs,
1510              Expression => Exp));
1511
1512          Set_No_Ctrl_Actions (First (Res));
1513
1514          --  Adjust the tag if tagged (because of possible view conversions).
1515          --  Suppress the tag adjustment when Java_VM because JVM tags are
1516          --  represented implicitly in objects.
1517
1518          if Is_Tagged_Type (Typ) and then not Java_VM then
1519             Append_To (Res,
1520               Make_Assignment_Statement (Loc,
1521                 Name =>
1522                   Make_Selected_Component (Loc,
1523                     Prefix =>  New_Copy_Tree (Lhs),
1524                     Selector_Name =>
1525                       New_Reference_To (First_Tag_Component (Typ), Loc)),
1526
1527                 Expression =>
1528                   Unchecked_Convert_To (RTE (RE_Tag),
1529                     New_Reference_To
1530                       (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))));
1531          end if;
1532
1533          --  Adjust the component if controlled except if it is an
1534          --  aggregate that will be expanded inline
1535
1536          if Kind = N_Qualified_Expression then
1537             Kind := Nkind (Expression (N));
1538          end if;
1539
1540          if Controlled_Type (Typ)
1541          and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate)
1542          then
1543             Append_List_To (Res,
1544               Make_Adjust_Call (
1545                Ref          => New_Copy_Tree (Lhs),
1546                Typ          => Etype (Id),
1547                Flist_Ref    =>
1548                  Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)),
1549                With_Attach  => Make_Integer_Literal (Loc, 1)));
1550          end if;
1551
1552          return Res;
1553
1554       exception
1555          when RE_Not_Available =>
1556             return Empty_List;
1557       end Build_Assignment;
1558
1559       ------------------------------------
1560       -- Build_Discriminant_Assignments --
1561       ------------------------------------
1562
1563       procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
1564          D         : Entity_Id;
1565          Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
1566
1567       begin
1568          if Has_Discriminants (Rec_Type)
1569            and then not Is_Unchecked_Union (Rec_Type)
1570          then
1571             D := First_Discriminant (Rec_Type);
1572
1573             while Present (D) loop
1574                --  Don't generate the assignment for discriminants in derived
1575                --  tagged types if the discriminant is a renaming of some
1576                --  ancestor discriminant.  This initialization will be done
1577                --  when initializing the _parent field of the derived record.
1578
1579                if Is_Tagged and then
1580                  Present (Corresponding_Discriminant (D))
1581                then
1582                   null;
1583
1584                else
1585                   Loc := Sloc (D);
1586                   Append_List_To (Statement_List,
1587                     Build_Assignment (D,
1588                       New_Reference_To (Discriminal (D), Loc)));
1589                end if;
1590
1591                Next_Discriminant (D);
1592             end loop;
1593          end if;
1594       end Build_Discriminant_Assignments;
1595
1596       --------------------------
1597       -- Build_Init_Call_Thru --
1598       --------------------------
1599
1600       function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
1601          Parent_Proc : constant Entity_Id :=
1602                          Base_Init_Proc (Etype (Rec_Type));
1603
1604          Parent_Type : constant Entity_Id :=
1605                          Etype (First_Formal (Parent_Proc));
1606
1607          Uparent_Type : constant Entity_Id :=
1608                           Underlying_Type (Parent_Type);
1609
1610          First_Discr_Param : Node_Id;
1611
1612          Parent_Discr : Entity_Id;
1613          First_Arg    : Node_Id;
1614          Args         : List_Id;
1615          Arg          : Node_Id;
1616          Res          : List_Id;
1617
1618       begin
1619          --  First argument (_Init) is the object to be initialized.
1620          --  ??? not sure where to get a reasonable Loc for First_Arg
1621
1622          First_Arg :=
1623            OK_Convert_To (Parent_Type,
1624              New_Reference_To (Defining_Identifier (First (Parameters)), Loc));
1625
1626          Set_Etype (First_Arg, Parent_Type);
1627
1628          Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
1629
1630          --  In the tasks case,
1631          --    add _Master as the value of the _Master parameter
1632          --    add _Chain as the value of the _Chain parameter.
1633          --    add _Task_Name as the value of the _Task_Name parameter.
1634          --  At the outer level, these will be variables holding the
1635          --  corresponding values obtained from GNARL or the expander.
1636          --
1637          --  At inner levels, they will be the parameters passed down through
1638          --  the outer routines.
1639
1640          First_Discr_Param := Next (First (Parameters));
1641
1642          if Has_Task (Rec_Type) then
1643             if Restriction_Active (No_Task_Hierarchy) then
1644
1645                --  See comments in System.Tasking.Initialization.Init_RTS
1646                --  for the value 3.
1647
1648                Append_To (Args, Make_Integer_Literal (Loc, 3));
1649             else
1650                Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1651             end if;
1652
1653             Append_To (Args, Make_Identifier (Loc, Name_uChain));
1654             Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
1655             First_Discr_Param := Next (Next (Next (First_Discr_Param)));
1656          end if;
1657
1658          --  Append discriminant values
1659
1660          if Has_Discriminants (Uparent_Type) then
1661             pragma Assert (not Is_Tagged_Type (Uparent_Type));
1662
1663             Parent_Discr := First_Discriminant (Uparent_Type);
1664             while Present (Parent_Discr) loop
1665
1666                --  Get the initial value for this discriminant
1667                --  ??? needs to be cleaned up to use parent_Discr_Constr
1668                --  directly.
1669
1670                declare
1671                   Discr_Value : Elmt_Id :=
1672                                   First_Elmt
1673                                     (Stored_Constraint (Rec_Type));
1674
1675                   Discr       : Entity_Id :=
1676                                   First_Stored_Discriminant (Uparent_Type);
1677                begin
1678                   while Original_Record_Component (Parent_Discr) /= Discr loop
1679                      Next_Stored_Discriminant (Discr);
1680                      Next_Elmt (Discr_Value);
1681                   end loop;
1682
1683                   Arg := Node (Discr_Value);
1684                end;
1685
1686                --  Append it to the list
1687
1688                if Nkind (Arg) = N_Identifier
1689                   and then Ekind (Entity (Arg)) = E_Discriminant
1690                then
1691                   Append_To (Args,
1692                     New_Reference_To (Discriminal (Entity (Arg)), Loc));
1693
1694                --  Case of access discriminants. We replace the reference
1695                --  to the type by a reference to the actual object
1696
1697 --     ??? why is this code deleted without comment
1698
1699 --               elsif Nkind (Arg) = N_Attribute_Reference
1700 --                 and then Is_Entity_Name (Prefix (Arg))
1701 --                 and then Is_Type (Entity (Prefix (Arg)))
1702 --               then
1703 --                  Append_To (Args,
1704 --                    Make_Attribute_Reference (Loc,
1705 --                      Prefix         => New_Copy (Prefix (Id_Ref)),
1706 --                      Attribute_Name => Name_Unrestricted_Access));
1707
1708                else
1709                   Append_To (Args, New_Copy (Arg));
1710                end if;
1711
1712                Next_Discriminant (Parent_Discr);
1713             end loop;
1714          end if;
1715
1716          Res :=
1717             New_List (
1718               Make_Procedure_Call_Statement (Loc,
1719                 Name => New_Occurrence_Of (Parent_Proc, Loc),
1720                 Parameter_Associations => Args));
1721
1722          return Res;
1723       end Build_Init_Call_Thru;
1724
1725       --------------------------
1726       -- Build_Init_Procedure --
1727       --------------------------
1728
1729       procedure Build_Init_Procedure is
1730          Body_Node             : Node_Id;
1731          Handled_Stmt_Node     : Node_Id;
1732          Parameters            : List_Id;
1733          Proc_Spec_Node        : Node_Id;
1734          Body_Stmts            : List_Id;
1735          Record_Extension_Node : Node_Id;
1736          Init_Tag              : Node_Id;
1737
1738       begin
1739          Body_Stmts := New_List;
1740          Body_Node := New_Node (N_Subprogram_Body, Loc);
1741
1742          Proc_Id :=
1743            Make_Defining_Identifier (Loc,
1744              Chars => Make_Init_Proc_Name (Rec_Type));
1745          Set_Ekind (Proc_Id, E_Procedure);
1746
1747          Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
1748          Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
1749
1750          Parameters := Init_Formals (Rec_Type);
1751          Append_List_To (Parameters,
1752            Build_Discriminant_Formals (Rec_Type, True));
1753
1754          --  For tagged types, we add a flag to indicate whether the routine
1755          --  is called to initialize a parent component in the init_proc of
1756          --  a type extension. If the flag is false, we do not set the tag
1757          --  because it has been set already in the extension.
1758
1759          if Is_Tagged_Type (Rec_Type)
1760            and then not Is_CPP_Class (Rec_Type)
1761          then
1762             Set_Tag :=
1763                   Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1764
1765             Append_To (Parameters,
1766               Make_Parameter_Specification (Loc,
1767                 Defining_Identifier => Set_Tag,
1768                 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
1769                 Expression => New_Occurrence_Of (Standard_True, Loc)));
1770          end if;
1771
1772          Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
1773          Set_Specification (Body_Node, Proc_Spec_Node);
1774          Set_Declarations (Body_Node, New_List);
1775
1776          if Parent_Subtype_Renaming_Discrims then
1777
1778             --  N is a Derived_Type_Definition that renames the parameters
1779             --  of the ancestor type.  We init it by expanding our discrims
1780             --  and call the ancestor _init_proc with a type-converted object
1781
1782             Append_List_To (Body_Stmts,
1783               Build_Init_Call_Thru (Parameters));
1784
1785          elsif Nkind (Type_Definition (N)) = N_Record_Definition then
1786             Build_Discriminant_Assignments (Body_Stmts);
1787
1788             if not Null_Present (Type_Definition (N)) then
1789                Append_List_To (Body_Stmts,
1790                  Build_Init_Statements (
1791                    Component_List (Type_Definition (N))));
1792             end if;
1793
1794          else
1795             --  N is a Derived_Type_Definition with a possible non-empty
1796             --  extension. The initialization of a type extension consists
1797             --  in the initialization of the components in the extension.
1798
1799             Build_Discriminant_Assignments (Body_Stmts);
1800
1801             Record_Extension_Node :=
1802               Record_Extension_Part (Type_Definition (N));
1803
1804             if not Null_Present (Record_Extension_Node) then
1805                declare
1806                   Stmts : constant List_Id :=
1807                             Build_Init_Statements (
1808                               Component_List (Record_Extension_Node));
1809
1810                begin
1811                   --  The parent field must be initialized first because
1812                   --  the offset of the new discriminants may depend on it
1813
1814                   Prepend_To (Body_Stmts, Remove_Head (Stmts));
1815                   Append_List_To (Body_Stmts, Stmts);
1816                end;
1817             end if;
1818          end if;
1819
1820          --  Add here the assignment to instantiate the Tag
1821
1822          --  The assignement corresponds to the code:
1823
1824          --     _Init._Tag := Typ'Tag;
1825
1826          --  Suppress the tag assignment when Java_VM because JVM tags are
1827          --  represented implicitly in objects.
1828
1829          if Is_Tagged_Type (Rec_Type)
1830            and then not Is_CPP_Class (Rec_Type)
1831            and then not Java_VM
1832          then
1833             Init_Tag :=
1834               Make_Assignment_Statement (Loc,
1835                 Name =>
1836                   Make_Selected_Component (Loc,
1837                     Prefix => Make_Identifier (Loc, Name_uInit),
1838                     Selector_Name =>
1839                       New_Reference_To (First_Tag_Component (Rec_Type), Loc)),
1840
1841                 Expression =>
1842                   New_Reference_To
1843                     (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc));
1844
1845             --  The tag must be inserted before the assignments to other
1846             --  components,  because the initial value of the component may
1847             --  depend ot the tag (eg. through a dispatching operation on
1848             --  an access to the current type). The tag assignment is not done
1849             --  when initializing the parent component of a type extension,
1850             --  because in that case the tag is set in the extension.
1851             --  Extensions of imported C++ classes add a final complication,
1852             --  because we cannot inhibit tag setting in the constructor for
1853             --  the parent. In that case we insert the tag initialization
1854             --  after the calls to initialize the parent.
1855
1856             Init_Tag :=
1857               Make_If_Statement (Loc,
1858                 Condition => New_Occurrence_Of (Set_Tag, Loc),
1859                 Then_Statements => New_List (Init_Tag));
1860
1861             if not Is_CPP_Class (Etype (Rec_Type)) then
1862                Prepend_To (Body_Stmts, Init_Tag);
1863
1864                --  Ada 2005 (AI-251): Initialization of all the tags
1865                --  corresponding with abstract interfaces
1866
1867                if Present (First_Tag_Component (Rec_Type)) then
1868
1869                   --  Skip the first _Tag, which is the main tag of the
1870                   --  tagged type. Following tags correspond with abstract
1871                   --  interfaces.
1872
1873                   Aux_Comp :=
1874                     Next_Tag_Component (First_Tag_Component (Rec_Type));
1875
1876                   ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type)));
1877                   while Present (ADT) loop
1878                      Aux_N := Node (ADT);
1879
1880                      --  Initialize the pointer to the secondary DT associated
1881                      --  with the interface
1882
1883                      Append_To (Body_Stmts,
1884                        Make_Assignment_Statement (Loc,
1885                          Name =>
1886                            Make_Selected_Component (Loc,
1887                              Prefix => Make_Identifier (Loc, Name_uInit),
1888                              Selector_Name =>
1889                                New_Reference_To (Aux_Comp, Loc)),
1890                          Expression =>
1891                            New_Reference_To (Aux_N, Loc)));
1892
1893                      --  Generate:
1894                      --    Set_Offset_To_Top (DT_Ptr, n);
1895
1896                      Append_To (Body_Stmts,
1897                        Make_Procedure_Call_Statement (Loc,
1898                          Name => New_Reference_To (RTE (RE_Set_Offset_To_Top),
1899                                                    Loc),
1900                          Parameter_Associations => New_List (
1901                            Unchecked_Convert_To (RTE (RE_Tag),
1902                              New_Reference_To (Aux_N, Loc)),
1903                            Unchecked_Convert_To (RTE (RE_Storage_Offset),
1904                              Make_Attribute_Reference (Loc,
1905                                Prefix         =>
1906                                 Make_Selected_Component (Loc,
1907                                   Prefix         => Make_Identifier (Loc,
1908                                                       Name_uInit),
1909                                   Selector_Name  => New_Reference_To
1910                                                       (Aux_Comp, Loc)),
1911                               Attribute_Name => Name_Position)))));
1912
1913                      Aux_Comp := Next_Tag_Component (Aux_Comp);
1914                      Next_Elmt (ADT);
1915                   end loop;
1916                end if;
1917
1918             else
1919                declare
1920                   Nod : Node_Id := First (Body_Stmts);
1921
1922                begin
1923                   --  We assume the first init_proc call is for the parent
1924
1925                   while Present (Next (Nod))
1926                     and then (Nkind (Nod) /= N_Procedure_Call_Statement
1927                                or else not Is_Init_Proc (Name (Nod)))
1928                   loop
1929                      Nod := Next (Nod);
1930                   end loop;
1931
1932                   Insert_After (Nod, Init_Tag);
1933                end;
1934             end if;
1935          end if;
1936
1937          Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
1938          Set_Statements (Handled_Stmt_Node, Body_Stmts);
1939          Set_Exception_Handlers (Handled_Stmt_Node, No_List);
1940          Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
1941
1942          if not Debug_Generated_Code then
1943             Set_Debug_Info_Off (Proc_Id);
1944          end if;
1945
1946          --  Associate Init_Proc with type, and determine if the procedure
1947          --  is null (happens because of the Initialize_Scalars pragma case,
1948          --  where we have to generate a null procedure in case it is called
1949          --  by a client with Initialize_Scalars set). Such procedures have
1950          --  to be generated, but do not have to be called, so we mark them
1951          --  as null to suppress the call.
1952
1953          Set_Init_Proc (Rec_Type, Proc_Id);
1954
1955          if List_Length (Body_Stmts) = 1
1956            and then Nkind (First (Body_Stmts)) = N_Null_Statement
1957          then
1958             Set_Is_Null_Init_Proc (Proc_Id);
1959          end if;
1960       end Build_Init_Procedure;
1961
1962       ---------------------------
1963       -- Build_Init_Statements --
1964       ---------------------------
1965
1966       function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
1967          Check_List     : constant List_Id := New_List;
1968          Alt_List       : List_Id;
1969          Statement_List : List_Id;
1970          Stmts          : List_Id;
1971
1972          Per_Object_Constraint_Components : Boolean;
1973
1974          Decl     : Node_Id;
1975          Variant  : Node_Id;
1976
1977          Id  : Entity_Id;
1978          Typ : Entity_Id;
1979
1980          function Has_Access_Constraint (E : Entity_Id) return Boolean;
1981          --  Components with access discriminants that depend on the current
1982          --  instance must be initialized after all other components.
1983
1984          ---------------------------
1985          -- Has_Access_Constraint --
1986          ---------------------------
1987
1988          function Has_Access_Constraint (E : Entity_Id) return Boolean is
1989             Disc : Entity_Id;
1990             T    : constant Entity_Id := Etype (E);
1991
1992          begin
1993             if Has_Per_Object_Constraint (E)
1994               and then Has_Discriminants (T)
1995             then
1996                Disc := First_Discriminant (T);
1997                while Present (Disc) loop
1998                   if Is_Access_Type (Etype (Disc)) then
1999                      return True;
2000                   end if;
2001
2002                   Next_Discriminant (Disc);
2003                end loop;
2004
2005                return False;
2006             else
2007                return False;
2008             end if;
2009          end Has_Access_Constraint;
2010
2011       --  Start of processing for Build_Init_Statements
2012
2013       begin
2014          if Null_Present (Comp_List) then
2015             return New_List (Make_Null_Statement (Loc));
2016          end if;
2017
2018          Statement_List := New_List;
2019
2020          --  Loop through components, skipping pragmas, in 2 steps. The first
2021          --  step deals with regular components. The second step deals with
2022          --  components have per object constraints, and no explicit initia-
2023          --  lization.
2024
2025          Per_Object_Constraint_Components := False;
2026
2027          --  First step : regular components
2028
2029          Decl := First_Non_Pragma (Component_Items (Comp_List));
2030          while Present (Decl) loop
2031             Loc := Sloc (Decl);
2032             Build_Record_Checks
2033               (Subtype_Indication (Component_Definition (Decl)), Check_List);
2034
2035             Id := Defining_Identifier (Decl);
2036             Typ := Etype (Id);
2037
2038             if Has_Access_Constraint (Id)
2039               and then No (Expression (Decl))
2040             then
2041                --  Skip processing for now and ask for a second pass
2042
2043                Per_Object_Constraint_Components := True;
2044
2045             else
2046                --  Case of explicit initialization
2047
2048                if Present (Expression (Decl)) then
2049                   Stmts := Build_Assignment (Id, Expression (Decl));
2050
2051                --  Case of composite component with its own Init_Proc
2052
2053                elsif Has_Non_Null_Base_Init_Proc (Typ) then
2054                   Stmts :=
2055                     Build_Initialization_Call
2056                       (Loc,
2057                        Make_Selected_Component (Loc,
2058                          Prefix => Make_Identifier (Loc, Name_uInit),
2059                          Selector_Name => New_Occurrence_Of (Id, Loc)),
2060                        Typ,
2061                        True,
2062                        Rec_Type,
2063                        Discr_Map => Discr_Map);
2064
2065                --  Case of component needing simple initialization
2066
2067                elsif Component_Needs_Simple_Initialization (Typ) then
2068                   Stmts :=
2069                     Build_Assignment
2070                       (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id)));
2071
2072                --  Nothing needed for this case
2073
2074                else
2075                   Stmts := No_List;
2076                end if;
2077
2078                if Present (Check_List) then
2079                   Append_List_To (Statement_List, Check_List);
2080                end if;
2081
2082                if Present (Stmts) then
2083
2084                   --  Add the initialization of the record controller before
2085                   --  the _Parent field is attached to it when the attachment
2086                   --  can occur. It does not work to simply initialize the
2087                   --  controller first: it must be initialized after the parent
2088                   --  if the parent holds discriminants that can be used
2089                   --  to compute the offset of the controller. We assume here
2090                   --  that the last statement of the initialization call is the
2091                   --  attachement of the parent (see Build_Initialization_Call)
2092
2093                   if Chars (Id) = Name_uController
2094                     and then Rec_Type /= Etype (Rec_Type)
2095                     and then Has_Controlled_Component (Etype (Rec_Type))
2096                     and then Has_New_Controlled_Component (Rec_Type)
2097                   then
2098                      Insert_List_Before (Last (Statement_List), Stmts);
2099                   else
2100                      Append_List_To (Statement_List, Stmts);
2101                   end if;
2102                end if;
2103             end if;
2104
2105             Next_Non_Pragma (Decl);
2106          end loop;
2107
2108          if Per_Object_Constraint_Components then
2109
2110             --  Second pass: components with per-object constraints
2111
2112             Decl := First_Non_Pragma (Component_Items (Comp_List));
2113
2114             while Present (Decl) loop
2115                Loc := Sloc (Decl);
2116                Id := Defining_Identifier (Decl);
2117                Typ := Etype (Id);
2118
2119                if Has_Access_Constraint (Id)
2120                  and then No (Expression (Decl))
2121                then
2122                   if Has_Non_Null_Base_Init_Proc (Typ) then
2123                      Append_List_To (Statement_List,
2124                        Build_Initialization_Call (Loc,
2125                          Make_Selected_Component (Loc,
2126                            Prefix => Make_Identifier (Loc, Name_uInit),
2127                            Selector_Name => New_Occurrence_Of (Id, Loc)),
2128                          Typ, True, Rec_Type, Discr_Map => Discr_Map));
2129
2130                   elsif Component_Needs_Simple_Initialization (Typ) then
2131                      Append_List_To (Statement_List,
2132                        Build_Assignment
2133                          (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))));
2134                   end if;
2135                end if;
2136
2137                Next_Non_Pragma (Decl);
2138             end loop;
2139          end if;
2140
2141          --  Process the variant part
2142
2143          if Present (Variant_Part (Comp_List)) then
2144             Alt_List := New_List;
2145             Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
2146
2147             while Present (Variant) loop
2148                Loc := Sloc (Variant);
2149                Append_To (Alt_List,
2150                  Make_Case_Statement_Alternative (Loc,
2151                    Discrete_Choices =>
2152                      New_Copy_List (Discrete_Choices (Variant)),
2153                    Statements =>
2154                      Build_Init_Statements (Component_List (Variant))));
2155
2156                Next_Non_Pragma (Variant);
2157             end loop;
2158
2159             --  The expression of the case statement which is a reference
2160             --  to one of the discriminants is replaced by the appropriate
2161             --  formal parameter of the initialization procedure.
2162
2163             Append_To (Statement_List,
2164               Make_Case_Statement (Loc,
2165                 Expression =>
2166                   New_Reference_To (Discriminal (
2167                     Entity (Name (Variant_Part (Comp_List)))), Loc),
2168                 Alternatives => Alt_List));
2169          end if;
2170
2171          --  For a task record type, add the task create call and calls
2172          --  to bind any interrupt (signal) entries.
2173
2174          if Is_Task_Record_Type (Rec_Type) then
2175
2176             --  In the case of the restricted run time the ATCB has already
2177             --  been preallocated.
2178
2179             if Restricted_Profile then
2180                Append_To (Statement_List,
2181                  Make_Assignment_Statement (Loc,
2182                    Name => Make_Selected_Component (Loc,
2183                      Prefix => Make_Identifier (Loc, Name_uInit),
2184                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2185                    Expression => Make_Attribute_Reference (Loc,
2186                      Prefix =>
2187                        Make_Selected_Component (Loc,
2188                          Prefix => Make_Identifier (Loc, Name_uInit),
2189                          Selector_Name =>
2190                            Make_Identifier (Loc, Name_uATCB)),
2191                      Attribute_Name => Name_Unchecked_Access)));
2192             end if;
2193
2194             Append_To (Statement_List, Make_Task_Create_Call (Rec_Type));
2195
2196             declare
2197                Task_Type : constant Entity_Id :=
2198                              Corresponding_Concurrent_Type (Rec_Type);
2199                Task_Decl : constant Node_Id := Parent (Task_Type);
2200                Task_Def  : constant Node_Id := Task_Definition (Task_Decl);
2201                Vis_Decl  : Node_Id;
2202                Ent       : Entity_Id;
2203
2204             begin
2205                if Present (Task_Def) then
2206                   Vis_Decl := First (Visible_Declarations (Task_Def));
2207                   while Present (Vis_Decl) loop
2208                      Loc := Sloc (Vis_Decl);
2209
2210                      if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
2211                         if Get_Attribute_Id (Chars (Vis_Decl)) =
2212                                                        Attribute_Address
2213                         then
2214                            Ent := Entity (Name (Vis_Decl));
2215
2216                            if Ekind (Ent) = E_Entry then
2217                               Append_To (Statement_List,
2218                                 Make_Procedure_Call_Statement (Loc,
2219                                   Name => New_Reference_To (
2220                                     RTE (RE_Bind_Interrupt_To_Entry), Loc),
2221                                   Parameter_Associations => New_List (
2222                                     Make_Selected_Component (Loc,
2223                                       Prefix =>
2224                                         Make_Identifier (Loc, Name_uInit),
2225                                       Selector_Name =>
2226                                         Make_Identifier (Loc, Name_uTask_Id)),
2227                                     Entry_Index_Expression (
2228                                       Loc, Ent, Empty, Task_Type),
2229                                     Expression (Vis_Decl))));
2230                            end if;
2231                         end if;
2232                      end if;
2233
2234                      Next (Vis_Decl);
2235                   end loop;
2236                end if;
2237             end;
2238          end if;
2239
2240          --  For a protected type, add statements generated by
2241          --  Make_Initialize_Protection.
2242
2243          if Is_Protected_Record_Type (Rec_Type) then
2244             Append_List_To (Statement_List,
2245               Make_Initialize_Protection (Rec_Type));
2246          end if;
2247
2248          --  If no initializations when generated for component declarations
2249          --  corresponding to this Statement_List, append a null statement
2250          --  to the Statement_List to make it a valid Ada tree.
2251
2252          if Is_Empty_List (Statement_List) then
2253             Append (New_Node (N_Null_Statement, Loc), Statement_List);
2254          end if;
2255
2256          return Statement_List;
2257
2258       exception
2259          when RE_Not_Available =>
2260          return Empty_List;
2261       end Build_Init_Statements;
2262
2263       -------------------------
2264       -- Build_Record_Checks --
2265       -------------------------
2266
2267       procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
2268          Subtype_Mark_Id : Entity_Id;
2269
2270       begin
2271          if Nkind (S) = N_Subtype_Indication then
2272             Find_Type (Subtype_Mark (S));
2273             Subtype_Mark_Id := Entity (Subtype_Mark (S));
2274
2275             --  Remaining processing depends on type
2276
2277             case Ekind (Subtype_Mark_Id) is
2278
2279                when Array_Kind =>
2280                   Constrain_Array (S, Check_List);
2281
2282                when others =>
2283                   null;
2284             end case;
2285          end if;
2286       end Build_Record_Checks;
2287
2288       -------------------------------------------
2289       -- Component_Needs_Simple_Initialization --
2290       -------------------------------------------
2291
2292       function Component_Needs_Simple_Initialization
2293         (T : Entity_Id) return Boolean
2294       is
2295       begin
2296          return
2297            Needs_Simple_Initialization (T)
2298              and then not Is_RTE (T, RE_Tag)
2299              and then not Is_RTE (T, RE_Vtable_Ptr)
2300              and then not Is_RTE (T, RE_Interface_Tag); --  Ada 2005 (AI-251)
2301       end Component_Needs_Simple_Initialization;
2302
2303       ---------------------
2304       -- Constrain_Array --
2305       ---------------------
2306
2307       procedure Constrain_Array
2308         (SI          : Node_Id;
2309          Check_List  : List_Id)
2310       is
2311          C                     : constant Node_Id := Constraint (SI);
2312          Number_Of_Constraints : Nat := 0;
2313          Index                 : Node_Id;
2314          S, T                  : Entity_Id;
2315
2316       begin
2317          T := Entity (Subtype_Mark (SI));
2318
2319          if Ekind (T) in Access_Kind then
2320             T := Designated_Type (T);
2321          end if;
2322
2323          S := First (Constraints (C));
2324
2325          while Present (S) loop
2326             Number_Of_Constraints := Number_Of_Constraints + 1;
2327             Next (S);
2328          end loop;
2329
2330          --  In either case, the index constraint must provide a discrete
2331          --  range for each index of the array type and the type of each
2332          --  discrete range must be the same as that of the corresponding
2333          --  index. (RM 3.6.1)
2334
2335          S := First (Constraints (C));
2336          Index := First_Index (T);
2337          Analyze (Index);
2338
2339          --  Apply constraints to each index type
2340
2341          for J in 1 .. Number_Of_Constraints loop
2342             Constrain_Index (Index, S, Check_List);
2343             Next (Index);
2344             Next (S);
2345          end loop;
2346
2347       end Constrain_Array;
2348
2349       ---------------------
2350       -- Constrain_Index --
2351       ---------------------
2352
2353       procedure Constrain_Index
2354         (Index        : Node_Id;
2355          S            : Node_Id;
2356          Check_List   : List_Id)
2357       is
2358          T : constant Entity_Id := Etype (Index);
2359
2360       begin
2361          if Nkind (S) = N_Range then
2362             Process_Range_Expr_In_Decl (S, T, Check_List);
2363          end if;
2364       end Constrain_Index;
2365
2366       --------------------------------------
2367       -- Parent_Subtype_Renaming_Discrims --
2368       --------------------------------------
2369
2370       function Parent_Subtype_Renaming_Discrims return Boolean is
2371          De : Entity_Id;
2372          Dp : Entity_Id;
2373
2374       begin
2375          if Base_Type (Pe) /= Pe then
2376             return False;
2377          end if;
2378
2379          if Etype (Pe) = Pe
2380            or else not Has_Discriminants (Pe)
2381            or else Is_Constrained (Pe)
2382            or else Is_Tagged_Type (Pe)
2383          then
2384             return False;
2385          end if;
2386
2387          --  If there are no explicit stored discriminants we have inherited
2388          --  the root type discriminants so far, so no renamings occurred.
2389
2390          if First_Discriminant (Pe) = First_Stored_Discriminant (Pe) then
2391             return False;
2392          end if;
2393
2394          --  Check if we have done some trivial renaming of the parent
2395          --  discriminants, i.e. someting like
2396          --
2397          --    type DT (X1,X2: int) is new PT (X1,X2);
2398
2399          De := First_Discriminant (Pe);
2400          Dp := First_Discriminant (Etype (Pe));
2401
2402          while Present (De) loop
2403             pragma Assert (Present (Dp));
2404
2405             if Corresponding_Discriminant (De) /= Dp then
2406                return True;
2407             end if;
2408
2409             Next_Discriminant (De);
2410             Next_Discriminant (Dp);
2411          end loop;
2412
2413          return Present (Dp);
2414       end Parent_Subtype_Renaming_Discrims;
2415
2416       ------------------------
2417       -- Requires_Init_Proc --
2418       ------------------------
2419
2420       function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
2421          Comp_Decl : Node_Id;
2422          Id        : Entity_Id;
2423          Typ       : Entity_Id;
2424
2425       begin
2426          --  Definitely do not need one if specifically suppressed
2427
2428          if Suppress_Init_Proc (Rec_Id) then
2429             return False;
2430          end if;
2431
2432          --  Otherwise we need to generate an initialization procedure if
2433          --  Is_CPP_Class is False and at least one of the following applies:
2434
2435          --  1. Discriminants are present, since they need to be initialized
2436          --     with the appropriate discriminant constraint expressions.
2437          --     However, the discriminant of an unchecked union does not
2438          --     count, since the discriminant is not present.
2439
2440          --  2. The type is a tagged type, since the implicit Tag component
2441          --     needs to be initialized with a pointer to the dispatch table.
2442
2443          --  3. The type contains tasks
2444
2445          --  4. One or more components has an initial value
2446
2447          --  5. One or more components is for a type which itself requires
2448          --     an initialization procedure.
2449
2450          --  6. One or more components is a type that requires simple
2451          --     initialization (see Needs_Simple_Initialization), except
2452          --     that types Tag and Interface_Tag are excluded, since fields
2453          --     of these types are initialized by other means.
2454
2455          --  7. The type is the record type built for a task type (since at
2456          --     the very least, Create_Task must be called)
2457
2458          --  8. The type is the record type built for a protected type (since
2459          --     at least Initialize_Protection must be called)
2460
2461          --  9. The type is marked as a public entity. The reason we add this
2462          --     case (even if none of the above apply) is to properly handle
2463          --     Initialize_Scalars. If a package is compiled without an IS
2464          --     pragma, and the client is compiled with an IS pragma, then
2465          --     the client will think an initialization procedure is present
2466          --     and call it, when in fact no such procedure is required, but
2467          --     since the call is generated, there had better be a routine
2468          --     at the other end of the call, even if it does nothing!)
2469
2470          --  Note: the reason we exclude the CPP_Class case is ???
2471
2472          if Is_CPP_Class (Rec_Id) then
2473             return False;
2474
2475          elsif not Restriction_Active (No_Initialize_Scalars)
2476            and then Is_Public (Rec_Id)
2477          then
2478             return True;
2479
2480          elsif (Has_Discriminants (Rec_Id)
2481                   and then not Is_Unchecked_Union (Rec_Id))
2482            or else Is_Tagged_Type (Rec_Id)
2483            or else Is_Concurrent_Record_Type (Rec_Id)
2484            or else Has_Task (Rec_Id)
2485          then
2486             return True;
2487          end if;
2488
2489          Id := First_Component (Rec_Id);
2490
2491          while Present (Id) loop
2492             Comp_Decl := Parent (Id);
2493             Typ := Etype (Id);
2494
2495             if Present (Expression (Comp_Decl))
2496               or else Has_Non_Null_Base_Init_Proc (Typ)
2497               or else Component_Needs_Simple_Initialization (Typ)
2498             then
2499                return True;
2500             end if;
2501
2502             Next_Component (Id);
2503          end loop;
2504
2505          return False;
2506       end Requires_Init_Proc;
2507
2508    --  Start of processing for Build_Record_Init_Proc
2509
2510    begin
2511       Rec_Type := Defining_Identifier (N);
2512
2513       --  This may be full declaration of a private type, in which case
2514       --  the visible entity is a record, and the private entity has been
2515       --  exchanged with it in the private part of the current package.
2516       --  The initialization procedure is built for the record type, which
2517       --  is retrievable from the private entity.
2518
2519       if Is_Incomplete_Or_Private_Type (Rec_Type) then
2520          Rec_Type := Underlying_Type (Rec_Type);
2521       end if;
2522
2523       --  If there are discriminants, build the discriminant map to replace
2524       --  discriminants by their discriminals in complex bound expressions.
2525       --  These only arise for the corresponding records of protected types.
2526
2527       if Is_Concurrent_Record_Type (Rec_Type)
2528         and then Has_Discriminants (Rec_Type)
2529       then
2530          declare
2531             Disc : Entity_Id;
2532
2533          begin
2534             Disc := First_Discriminant (Rec_Type);
2535
2536             while Present (Disc) loop
2537                Append_Elmt (Disc, Discr_Map);
2538                Append_Elmt (Discriminal (Disc), Discr_Map);
2539                Next_Discriminant (Disc);
2540             end loop;
2541          end;
2542       end if;
2543
2544       --  Derived types that have no type extension can use the initialization
2545       --  procedure of their parent and do not need a procedure of their own.
2546       --  This is only correct if there are no representation clauses for the
2547       --  type or its parent, and if the parent has in fact been frozen so
2548       --  that its initialization procedure exists.
2549
2550       if Is_Derived_Type (Rec_Type)
2551         and then not Is_Tagged_Type (Rec_Type)
2552         and then not Is_Unchecked_Union (Rec_Type)
2553         and then not Has_New_Non_Standard_Rep (Rec_Type)
2554         and then not Parent_Subtype_Renaming_Discrims
2555         and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
2556       then
2557          Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
2558
2559       --  Otherwise if we need an initialization procedure, then build one,
2560       --  mark it as public and inlinable and as having a completion.
2561
2562       elsif Requires_Init_Proc (Rec_Type)
2563         or else Is_Unchecked_Union (Rec_Type)
2564       then
2565          Build_Init_Procedure;
2566          Set_Is_Public (Proc_Id, Is_Public (Pe));
2567
2568          --  The initialization of protected records is not worth inlining.
2569          --  In addition, when compiled for another unit for inlining purposes,
2570          --  it may make reference to entities that have not been elaborated
2571          --  yet. The initialization of controlled records contains a nested
2572          --  clean-up procedure that makes it impractical to inline as well,
2573          --  and leads to undefined symbols if inlined in a different unit.
2574          --  Similar considerations apply to task types.
2575
2576          if not Is_Concurrent_Type (Rec_Type)
2577            and then not Has_Task (Rec_Type)
2578            and then not Controlled_Type (Rec_Type)
2579          then
2580             Set_Is_Inlined  (Proc_Id);
2581          end if;
2582
2583          Set_Is_Internal    (Proc_Id);
2584          Set_Has_Completion (Proc_Id);
2585
2586          if not Debug_Generated_Code then
2587             Set_Debug_Info_Off (Proc_Id);
2588          end if;
2589       end if;
2590    end Build_Record_Init_Proc;
2591
2592    ----------------------------
2593    -- Build_Slice_Assignment --
2594    ----------------------------
2595
2596    --  Generates the following subprogram:
2597
2598    --    procedure Assign
2599    --     (Source,   Target   : Array_Type,
2600    --      Left_Lo,  Left_Hi, Right_Lo, Right_Hi : Index;
2601    --      Rev :     Boolean)
2602    --    is
2603    --       Li1 : Index;
2604    --       Ri1 : Index;
2605
2606    --    begin
2607    --       if Rev  then
2608    --          Li1 := Left_Hi;
2609    --          Ri1 := Right_Hi;
2610    --       else
2611    --          Li1 := Left_Lo;
2612    --          Ri1 := Right_Lo;
2613    --       end if;
2614
2615    --       loop
2616    --             if Rev then
2617    --                exit when Li1 < Left_Lo;
2618    --             else
2619    --                exit when Li1 > Left_Hi;
2620    --             end if;
2621
2622    --             Target (Li1) := Source (Ri1);
2623
2624    --             if Rev then
2625    --                Li1 := Index'pred (Li1);
2626    --                Ri1 := Index'pred (Ri1);
2627    --             else
2628    --                Li1 := Index'succ (Li1);
2629    --                Ri1 := Index'succ (Ri1);
2630    --             end if;
2631    --       end loop;
2632    --    end Assign;
2633
2634    procedure Build_Slice_Assignment (Typ : Entity_Id) is
2635       Loc   : constant Source_Ptr := Sloc (Typ);
2636       Index : constant Entity_Id  := Base_Type (Etype (First_Index (Typ)));
2637
2638       --  Build formal parameters of procedure
2639
2640       Larray   : constant Entity_Id :=
2641                    Make_Defining_Identifier
2642                      (Loc, Chars => New_Internal_Name ('A'));
2643       Rarray   : constant Entity_Id :=
2644                    Make_Defining_Identifier
2645                      (Loc, Chars => New_Internal_Name ('R'));
2646       Left_Lo  : constant Entity_Id :=
2647                    Make_Defining_Identifier
2648                      (Loc, Chars => New_Internal_Name ('L'));
2649       Left_Hi  : constant Entity_Id :=
2650                    Make_Defining_Identifier
2651                      (Loc, Chars => New_Internal_Name ('L'));
2652       Right_Lo : constant Entity_Id :=
2653                    Make_Defining_Identifier
2654                      (Loc, Chars => New_Internal_Name ('R'));
2655       Right_Hi : constant Entity_Id :=
2656                    Make_Defining_Identifier
2657                      (Loc, Chars => New_Internal_Name ('R'));
2658       Rev      : constant Entity_Id :=
2659                    Make_Defining_Identifier
2660                      (Loc, Chars => New_Internal_Name ('D'));
2661       Proc_Name : constant Entity_Id :=
2662                     Make_Defining_Identifier (Loc,
2663                       Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
2664
2665       Lnn : constant Entity_Id :=
2666               Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
2667       Rnn : constant Entity_Id :=
2668               Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2669       --  Subscripts for left and right sides
2670
2671       Decls : List_Id;
2672       Loops : Node_Id;
2673       Stats : List_Id;
2674
2675    begin
2676       --  Build declarations for indices
2677
2678       Decls := New_List;
2679
2680       Append_To (Decls,
2681          Make_Object_Declaration (Loc,
2682            Defining_Identifier => Lnn,
2683            Object_Definition  =>
2684              New_Occurrence_Of (Index, Loc)));
2685
2686       Append_To (Decls,
2687         Make_Object_Declaration (Loc,
2688           Defining_Identifier => Rnn,
2689           Object_Definition  =>
2690             New_Occurrence_Of (Index, Loc)));
2691
2692       Stats := New_List;
2693
2694       --  Build initializations for indices
2695
2696       declare
2697          F_Init : constant List_Id := New_List;
2698          B_Init : constant List_Id := New_List;
2699
2700       begin
2701          Append_To (F_Init,
2702            Make_Assignment_Statement (Loc,
2703              Name => New_Occurrence_Of (Lnn, Loc),
2704              Expression => New_Occurrence_Of (Left_Lo, Loc)));
2705
2706          Append_To (F_Init,
2707            Make_Assignment_Statement (Loc,
2708              Name => New_Occurrence_Of (Rnn, Loc),
2709              Expression => New_Occurrence_Of (Right_Lo, Loc)));
2710
2711          Append_To (B_Init,
2712            Make_Assignment_Statement (Loc,
2713              Name => New_Occurrence_Of (Lnn, Loc),
2714              Expression => New_Occurrence_Of (Left_Hi, Loc)));
2715
2716          Append_To (B_Init,
2717            Make_Assignment_Statement (Loc,
2718              Name => New_Occurrence_Of (Rnn, Loc),
2719              Expression => New_Occurrence_Of (Right_Hi, Loc)));
2720
2721          Append_To (Stats,
2722            Make_If_Statement (Loc,
2723              Condition => New_Occurrence_Of (Rev, Loc),
2724              Then_Statements => B_Init,
2725              Else_Statements => F_Init));
2726       end;
2727
2728       --  Now construct the assignment statement
2729
2730       Loops :=
2731         Make_Loop_Statement (Loc,
2732           Statements => New_List (
2733             Make_Assignment_Statement (Loc,
2734               Name =>
2735                 Make_Indexed_Component (Loc,
2736                   Prefix => New_Occurrence_Of (Larray, Loc),
2737                   Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
2738               Expression =>
2739                 Make_Indexed_Component (Loc,
2740                   Prefix => New_Occurrence_Of (Rarray, Loc),
2741                   Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
2742           End_Label  => Empty);
2743
2744       --  Build exit condition
2745
2746       declare
2747          F_Ass : constant List_Id := New_List;
2748          B_Ass : constant List_Id := New_List;
2749
2750       begin
2751          Append_To (F_Ass,
2752            Make_Exit_Statement (Loc,
2753              Condition =>
2754                Make_Op_Gt (Loc,
2755                  Left_Opnd  => New_Occurrence_Of (Lnn, Loc),
2756                  Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
2757
2758          Append_To (B_Ass,
2759            Make_Exit_Statement (Loc,
2760              Condition =>
2761                Make_Op_Lt (Loc,
2762                  Left_Opnd  => New_Occurrence_Of (Lnn, Loc),
2763                  Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
2764
2765          Prepend_To (Statements (Loops),
2766            Make_If_Statement (Loc,
2767              Condition       => New_Occurrence_Of (Rev, Loc),
2768              Then_Statements => B_Ass,
2769              Else_Statements => F_Ass));
2770       end;
2771
2772       --  Build the increment/decrement statements
2773
2774       declare
2775          F_Ass : constant List_Id := New_List;
2776          B_Ass : constant List_Id := New_List;
2777
2778       begin
2779          Append_To (F_Ass,
2780            Make_Assignment_Statement (Loc,
2781              Name => New_Occurrence_Of (Lnn, Loc),
2782              Expression =>
2783                Make_Attribute_Reference (Loc,
2784                  Prefix =>
2785                    New_Occurrence_Of (Index, Loc),
2786                  Attribute_Name => Name_Succ,
2787                  Expressions => New_List (
2788                    New_Occurrence_Of (Lnn, Loc)))));
2789
2790          Append_To (F_Ass,
2791            Make_Assignment_Statement (Loc,
2792              Name => New_Occurrence_Of (Rnn, Loc),
2793              Expression =>
2794                Make_Attribute_Reference (Loc,
2795                  Prefix =>
2796                    New_Occurrence_Of (Index, Loc),
2797                  Attribute_Name => Name_Succ,
2798                  Expressions => New_List (
2799                    New_Occurrence_Of (Rnn, Loc)))));
2800
2801          Append_To (B_Ass,
2802            Make_Assignment_Statement (Loc,
2803              Name => New_Occurrence_Of (Lnn, Loc),
2804              Expression =>
2805                Make_Attribute_Reference (Loc,
2806                  Prefix =>
2807                    New_Occurrence_Of (Index, Loc),
2808                  Attribute_Name => Name_Pred,
2809                    Expressions => New_List (
2810                      New_Occurrence_Of (Lnn, Loc)))));
2811
2812          Append_To (B_Ass,
2813            Make_Assignment_Statement (Loc,
2814              Name => New_Occurrence_Of (Rnn, Loc),
2815              Expression =>
2816                Make_Attribute_Reference (Loc,
2817                  Prefix =>
2818                    New_Occurrence_Of (Index, Loc),
2819                  Attribute_Name => Name_Pred,
2820                  Expressions => New_List (
2821                    New_Occurrence_Of (Rnn, Loc)))));
2822
2823          Append_To (Statements (Loops),
2824            Make_If_Statement (Loc,
2825              Condition => New_Occurrence_Of (Rev, Loc),
2826              Then_Statements => B_Ass,
2827              Else_Statements => F_Ass));
2828       end;
2829
2830       Append_To (Stats, Loops);
2831
2832       declare
2833          Spec    : Node_Id;
2834          Formals : List_Id := New_List;
2835
2836       begin
2837          Formals := New_List (
2838            Make_Parameter_Specification (Loc,
2839              Defining_Identifier => Larray,
2840              Out_Present => True,
2841              Parameter_Type =>
2842                New_Reference_To (Base_Type (Typ), Loc)),
2843
2844            Make_Parameter_Specification (Loc,
2845              Defining_Identifier => Rarray,
2846              Parameter_Type =>
2847                New_Reference_To (Base_Type (Typ), Loc)),
2848
2849            Make_Parameter_Specification (Loc,
2850              Defining_Identifier => Left_Lo,
2851              Parameter_Type =>
2852                New_Reference_To (Index, Loc)),
2853
2854            Make_Parameter_Specification (Loc,
2855              Defining_Identifier => Left_Hi,
2856              Parameter_Type =>
2857                New_Reference_To (Index, Loc)),
2858
2859            Make_Parameter_Specification (Loc,
2860              Defining_Identifier => Right_Lo,
2861              Parameter_Type =>
2862                New_Reference_To (Index, Loc)),
2863
2864            Make_Parameter_Specification (Loc,
2865              Defining_Identifier => Right_Hi,
2866              Parameter_Type =>
2867                New_Reference_To (Index, Loc)));
2868
2869          Append_To (Formals,
2870            Make_Parameter_Specification (Loc,
2871              Defining_Identifier => Rev,
2872              Parameter_Type =>
2873                New_Reference_To (Standard_Boolean, Loc)));
2874
2875          Spec :=
2876            Make_Procedure_Specification (Loc,
2877              Defining_Unit_Name       => Proc_Name,
2878              Parameter_Specifications => Formals);
2879
2880          Discard_Node (
2881            Make_Subprogram_Body (Loc,
2882              Specification              => Spec,
2883              Declarations               => Decls,
2884              Handled_Statement_Sequence =>
2885                Make_Handled_Sequence_Of_Statements (Loc,
2886                  Statements => Stats)));
2887       end;
2888
2889       Set_TSS (Typ, Proc_Name);
2890       Set_Is_Pure (Proc_Name);
2891    end Build_Slice_Assignment;
2892
2893    ------------------------------------
2894    -- Build_Variant_Record_Equality --
2895    ------------------------------------
2896
2897    --  Generates:
2898
2899    --    function _Equality (X, Y : T) return Boolean is
2900    --    begin
2901    --       --  Compare discriminants
2902
2903    --       if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then
2904    --          return False;
2905    --       end if;
2906
2907    --       --  Compare components
2908
2909    --       if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then
2910    --          return False;
2911    --       end if;
2912
2913    --       --  Compare variant part
2914
2915    --       case X.D1 is
2916    --          when V1 =>
2917    --             if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then
2918    --                return False;
2919    --             end if;
2920    --          ...
2921    --          when Vn =>
2922    --             if False or else X.Cn /= Y.Cn then
2923    --                return False;
2924    --             end if;
2925    --       end case;
2926    --       return True;
2927    --    end _Equality;
2928
2929    procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
2930       Loc   : constant Source_Ptr := Sloc (Typ);
2931
2932       F : constant Entity_Id :=
2933             Make_Defining_Identifier (Loc,
2934               Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
2935
2936       X : constant Entity_Id :=
2937            Make_Defining_Identifier (Loc,
2938              Chars => Name_X);
2939
2940       Y : constant Entity_Id :=
2941             Make_Defining_Identifier (Loc,
2942               Chars => Name_Y);
2943
2944       Def   : constant Node_Id := Parent (Typ);
2945       Comps : constant Node_Id := Component_List (Type_Definition (Def));
2946       Stmts : constant List_Id := New_List;
2947       Pspecs : constant List_Id := New_List;
2948
2949    begin
2950       --  Derived Unchecked_Union types no longer inherit the equality function
2951       --  of their parent.
2952
2953       if Is_Derived_Type (Typ)
2954         and then not Is_Unchecked_Union (Typ)
2955         and then not Has_New_Non_Standard_Rep (Typ)
2956       then
2957          declare
2958             Parent_Eq : constant Entity_Id :=
2959                           TSS (Root_Type (Typ), TSS_Composite_Equality);
2960
2961          begin
2962             if Present (Parent_Eq) then
2963                Copy_TSS (Parent_Eq, Typ);
2964                return;
2965             end if;
2966          end;
2967       end if;
2968
2969       Discard_Node (
2970         Make_Subprogram_Body (Loc,
2971           Specification =>
2972             Make_Function_Specification (Loc,
2973               Defining_Unit_Name       => F,
2974               Parameter_Specifications => Pspecs,
2975               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
2976           Declarations               => New_List,
2977           Handled_Statement_Sequence =>
2978             Make_Handled_Sequence_Of_Statements (Loc,
2979               Statements => Stmts)));
2980
2981       Append_To (Pspecs,
2982         Make_Parameter_Specification (Loc,
2983           Defining_Identifier => X,
2984           Parameter_Type      => New_Reference_To (Typ, Loc)));
2985
2986       Append_To (Pspecs,
2987         Make_Parameter_Specification (Loc,
2988           Defining_Identifier => Y,
2989           Parameter_Type      => New_Reference_To (Typ, Loc)));
2990
2991       --  Unchecked_Unions require additional machinery to support equality.
2992       --  Two extra parameters (A and B) are added to the equality function
2993       --  parameter list in order to capture the inferred values of the
2994       --  discriminants in later calls.
2995
2996       if Is_Unchecked_Union (Typ) then
2997          declare
2998             Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ));
2999
3000             A : constant Node_Id :=
3001                   Make_Defining_Identifier (Loc,
3002                     Chars => Name_A);
3003
3004             B : constant Node_Id :=
3005                   Make_Defining_Identifier (Loc,
3006                     Chars => Name_B);
3007
3008          begin
3009             --  Add A and B to the parameter list
3010
3011             Append_To (Pspecs,
3012               Make_Parameter_Specification (Loc,
3013                 Defining_Identifier => A,
3014                 Parameter_Type => New_Reference_To (Discr_Type, Loc)));
3015
3016             Append_To (Pspecs,
3017               Make_Parameter_Specification (Loc,
3018                 Defining_Identifier => B,
3019                 Parameter_Type => New_Reference_To (Discr_Type, Loc)));
3020
3021             --  Generate the following header code to compare the inferred
3022             --  discriminants:
3023
3024             --  if a /= b then
3025             --     return False;
3026             --  end if;
3027
3028             Append_To (Stmts,
3029               Make_If_Statement (Loc,
3030                 Condition =>
3031                   Make_Op_Ne (Loc,
3032                     Left_Opnd => New_Reference_To (A, Loc),
3033                     Right_Opnd => New_Reference_To (B, Loc)),
3034                 Then_Statements => New_List (
3035                   Make_Return_Statement (Loc,
3036                     Expression => New_Occurrence_Of (Standard_False, Loc)))));
3037
3038             --  Generate component-by-component comparison. Note that we must
3039             --  propagate one of the inferred discriminant formals to act as
3040             --  the case statement switch.
3041
3042             Append_List_To (Stmts,
3043               Make_Eq_Case (Typ, Comps, A));
3044
3045          end;
3046
3047       --  Normal case (not unchecked union)
3048
3049       else
3050          Append_To (Stmts,
3051            Make_Eq_If (Typ,
3052              Discriminant_Specifications (Def)));
3053
3054          Append_List_To (Stmts,
3055            Make_Eq_Case (Typ, Comps));
3056       end if;
3057
3058       Append_To (Stmts,
3059         Make_Return_Statement (Loc,
3060           Expression => New_Reference_To (Standard_True, Loc)));
3061
3062       Set_TSS (Typ, F);
3063       Set_Is_Pure (F);
3064
3065       if not Debug_Generated_Code then
3066          Set_Debug_Info_Off (F);
3067       end if;
3068    end Build_Variant_Record_Equality;
3069
3070    -----------------------------
3071    -- Check_Stream_Attributes --
3072    -----------------------------
3073
3074    procedure Check_Stream_Attributes (Typ : Entity_Id) is
3075       Comp      : Entity_Id;
3076       Par_Read  : constant Boolean :=
3077                     Stream_Attribute_Available (Typ, TSS_Stream_Read)
3078                       and then not Has_Specified_Stream_Read (Typ);
3079       Par_Write : constant Boolean :=
3080                     Stream_Attribute_Available (Typ, TSS_Stream_Write)
3081                       and then not Has_Specified_Stream_Write (Typ);
3082
3083       procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
3084       --  Check that Comp has a user-specified Nam stream attribute
3085
3086       ----------------
3087       -- Check_Attr --
3088       ----------------
3089
3090       procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
3091       begin
3092          if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
3093             Error_Msg_Name_1 := Nam;
3094             Error_Msg_N
3095               ("|component& in limited extension must have% attribute", Comp);
3096          end if;
3097       end Check_Attr;
3098
3099    --  Start of processing for Check_Stream_Attributes
3100
3101    begin
3102       if Par_Read or else Par_Write then
3103          Comp := First_Component (Typ);
3104          while Present (Comp) loop
3105             if Comes_From_Source (Comp)
3106               and then Original_Record_Component (Comp) = Comp
3107               and then Is_Limited_Type (Etype (Comp))
3108             then
3109                if Par_Read then
3110                   Check_Attr (Name_Read, TSS_Stream_Read);
3111                end if;
3112
3113                if Par_Write then
3114                   Check_Attr (Name_Write, TSS_Stream_Write);
3115                end if;
3116             end if;
3117
3118             Next_Component (Comp);
3119          end loop;
3120       end if;
3121    end Check_Stream_Attributes;
3122
3123    -----------------------------
3124    -- Expand_Record_Extension --
3125    -----------------------------
3126
3127    --  Add a field _parent at the beginning of the record extension. This is
3128    --  used to implement inheritance. Here are some examples of expansion:
3129
3130    --  1. no discriminants
3131    --      type T2 is new T1 with null record;
3132    --   gives
3133    --      type T2 is new T1 with record
3134    --        _Parent : T1;
3135    --      end record;
3136
3137    --  2. renamed discriminants
3138    --    type T2 (B, C : Int) is new T1 (A => B) with record
3139    --       _Parent : T1 (A => B);
3140    --       D : Int;
3141    --    end;
3142
3143    --  3. inherited discriminants
3144    --    type T2 is new T1 with record -- discriminant A inherited
3145    --       _Parent : T1 (A);
3146    --       D : Int;
3147    --    end;
3148
3149    procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
3150       Indic        : constant Node_Id    := Subtype_Indication (Def);
3151       Loc          : constant Source_Ptr := Sloc (Def);
3152       Rec_Ext_Part : Node_Id             := Record_Extension_Part (Def);
3153       Par_Subtype  : Entity_Id;
3154       Comp_List    : Node_Id;
3155       Comp_Decl    : Node_Id;
3156       Parent_N     : Node_Id;
3157       D            : Entity_Id;
3158       List_Constr  : constant List_Id    := New_List;
3159
3160    begin
3161       --  Expand_Record_Extension is called directly from the semantics, so
3162       --  we must check to see whether expansion is active before proceeding
3163
3164       if not Expander_Active then
3165          return;
3166       end if;
3167
3168       --  This may be a derivation of an untagged private type whose full
3169       --  view is tagged, in which case the Derived_Type_Definition has no
3170       --  extension part. Build an empty one now.
3171
3172       if No (Rec_Ext_Part) then
3173          Rec_Ext_Part :=
3174            Make_Record_Definition (Loc,
3175              End_Label      => Empty,
3176              Component_List => Empty,
3177              Null_Present   => True);
3178
3179          Set_Record_Extension_Part (Def, Rec_Ext_Part);
3180          Mark_Rewrite_Insertion (Rec_Ext_Part);
3181       end if;
3182
3183       Comp_List := Component_List (Rec_Ext_Part);
3184
3185       Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
3186
3187       --  If the derived type inherits its discriminants the type of the
3188       --  _parent field must be constrained by the inherited discriminants
3189
3190       if Has_Discriminants (T)
3191         and then Nkind (Indic) /= N_Subtype_Indication
3192         and then not Is_Constrained (Entity (Indic))
3193       then
3194          D := First_Discriminant (T);
3195          while Present (D) loop
3196             Append_To (List_Constr, New_Occurrence_Of (D, Loc));
3197             Next_Discriminant (D);
3198          end loop;
3199
3200          Par_Subtype :=
3201            Process_Subtype (
3202              Make_Subtype_Indication (Loc,
3203                Subtype_Mark => New_Reference_To (Entity (Indic), Loc),
3204                Constraint   =>
3205                  Make_Index_Or_Discriminant_Constraint (Loc,
3206                    Constraints => List_Constr)),
3207              Def);
3208
3209       --  Otherwise the original subtype_indication is just what is needed
3210
3211       else
3212          Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
3213       end if;
3214
3215       Set_Parent_Subtype (T, Par_Subtype);
3216
3217       Comp_Decl :=
3218         Make_Component_Declaration (Loc,
3219           Defining_Identifier => Parent_N,
3220           Component_Definition =>
3221             Make_Component_Definition (Loc,
3222               Aliased_Present => False,
3223               Subtype_Indication => New_Reference_To (Par_Subtype, Loc)));
3224
3225       if Null_Present (Rec_Ext_Part) then
3226          Set_Component_List (Rec_Ext_Part,
3227            Make_Component_List (Loc,
3228              Component_Items => New_List (Comp_Decl),
3229              Variant_Part => Empty,
3230              Null_Present => False));
3231          Set_Null_Present (Rec_Ext_Part, False);
3232
3233       elsif Null_Present (Comp_List)
3234         or else Is_Empty_List (Component_Items (Comp_List))
3235       then
3236          Set_Component_Items (Comp_List, New_List (Comp_Decl));
3237          Set_Null_Present (Comp_List, False);
3238
3239       else
3240          Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
3241       end if;
3242
3243       Analyze (Comp_Decl);
3244    end Expand_Record_Extension;
3245
3246    ------------------------------------
3247    -- Expand_N_Full_Type_Declaration --
3248    ------------------------------------
3249
3250    procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
3251       Def_Id : constant Entity_Id := Defining_Identifier (N);
3252       B_Id   : constant Entity_Id := Base_Type (Def_Id);
3253       Par_Id : Entity_Id;
3254       FN     : Node_Id;
3255
3256    begin
3257       if Is_Access_Type (Def_Id) then
3258
3259          --  Anonymous access types are created for the components of the
3260          --  record parameter for an entry declaration.  No master is created
3261          --  for such a type.
3262
3263          if Has_Task (Designated_Type (Def_Id))
3264            and then Comes_From_Source (N)
3265          then
3266             Build_Master_Entity (Def_Id);
3267             Build_Master_Renaming (Parent (Def_Id), Def_Id);
3268
3269          --  Create a class-wide master because a Master_Id must be generated
3270          --  for access-to-limited-class-wide types, whose root may be extended
3271          --  with task components.
3272
3273          elsif Is_Class_Wide_Type (Designated_Type (Def_Id))
3274            and then Is_Limited_Type (Designated_Type (Def_Id))
3275            and then Tasking_Allowed
3276
3277             --  Don't create a class-wide master for types whose convention is
3278             --  Java since these types cannot embed Ada tasks anyway. Note that
3279             --  the following test cannot catch the following case:
3280             --
3281             --      package java.lang.Object is
3282             --         type Typ is tagged limited private;
3283             --         type Ref is access all Typ'Class;
3284             --      private
3285             --         type Typ is tagged limited ...;
3286             --         pragma Convention (Typ, Java)
3287             --      end;
3288             --
3289             --  Because the convention appears after we have done the
3290             --  processing for type Ref.
3291
3292            and then Convention (Designated_Type (Def_Id)) /= Convention_Java
3293          then
3294             Build_Class_Wide_Master (Def_Id);
3295
3296          elsif Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
3297             Expand_Access_Protected_Subprogram_Type (N);
3298          end if;
3299
3300       elsif Has_Task (Def_Id) then
3301          Expand_Previous_Access_Type (Def_Id);
3302       end if;
3303
3304       Par_Id := Etype (B_Id);
3305
3306       --  The parent type is private then we need to inherit
3307       --  any TSS operations from the full view.
3308
3309       if Ekind (Par_Id) in Private_Kind
3310         and then Present (Full_View (Par_Id))
3311       then
3312          Par_Id := Base_Type (Full_View (Par_Id));
3313       end if;
3314
3315       if Nkind (Type_Definition (Original_Node (N)))
3316          = N_Derived_Type_Definition
3317         and then not Is_Tagged_Type (Def_Id)
3318         and then Present (Freeze_Node (Par_Id))
3319         and then Present (TSS_Elist (Freeze_Node (Par_Id)))
3320       then
3321          Ensure_Freeze_Node (B_Id);
3322          FN :=  Freeze_Node (B_Id);
3323
3324          if No (TSS_Elist (FN)) then
3325             Set_TSS_Elist (FN, New_Elmt_List);
3326          end if;
3327
3328          declare
3329             T_E   : constant Elist_Id := TSS_Elist (FN);
3330             Elmt  : Elmt_Id;
3331
3332          begin
3333             Elmt  := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
3334
3335             while Present (Elmt) loop
3336                if Chars (Node (Elmt)) /= Name_uInit then
3337                   Append_Elmt (Node (Elmt), T_E);
3338                end if;
3339
3340                Next_Elmt (Elmt);
3341             end loop;
3342
3343             --  If the derived type itself is private with a full view, then
3344             --  associate the full view with the inherited TSS_Elist as well.
3345
3346             if Ekind (B_Id) in Private_Kind
3347               and then Present (Full_View (B_Id))
3348             then
3349                Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
3350                Set_TSS_Elist
3351                  (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
3352             end if;
3353          end;
3354       end if;
3355    end Expand_N_Full_Type_Declaration;
3356
3357    ---------------------------------
3358    -- Expand_N_Object_Declaration --
3359    ---------------------------------
3360
3361    --  First we do special processing for objects of a tagged type where this
3362    --  is the point at which the type is frozen. The creation of the dispatch
3363    --  table and the initialization procedure have to be deferred to this
3364    --  point, since we reference previously declared primitive subprograms.
3365
3366    --  For all types, we call an initialization procedure if there is one
3367
3368    procedure Expand_N_Object_Declaration (N : Node_Id) is
3369       Def_Id  : constant Entity_Id  := Defining_Identifier (N);
3370       Typ     : constant Entity_Id  := Etype (Def_Id);
3371       Loc     : constant Source_Ptr := Sloc (N);
3372       Expr    : constant Node_Id    := Expression (N);
3373       New_Ref : Node_Id;
3374       Id_Ref  : Node_Id;
3375       Expr_Q  : Node_Id;
3376
3377    begin
3378       --  Don't do anything for deferred constants. All proper actions will
3379       --  be expanded during the full declaration.
3380
3381       if No (Expr) and Constant_Present (N) then
3382          return;
3383       end if;
3384
3385       --  Make shared memory routines for shared passive variable
3386
3387       if Is_Shared_Passive (Def_Id) then
3388          Make_Shared_Var_Procs (N);
3389       end if;
3390
3391       --  If tasks being declared, make sure we have an activation chain
3392       --  defined for the tasks (has no effect if we already have one), and
3393       --  also that a Master variable is established and that the appropriate
3394       --  enclosing construct is established as a task master.
3395
3396       if Has_Task (Typ) then
3397          Build_Activation_Chain_Entity (N);
3398          Build_Master_Entity (Def_Id);
3399       end if;
3400
3401       --  Default initialization required, and no expression present
3402
3403       if No (Expr) then
3404
3405          --  Expand Initialize call for controlled objects.  One may wonder why
3406          --  the Initialize Call is not done in the regular Init procedure
3407          --  attached to the record type. That's because the init procedure is
3408          --  recursively called on each component, including _Parent, thus the
3409          --  Init call for a controlled object would generate not only one
3410          --  Initialize call as it is required but one for each ancestor of
3411          --  its type. This processing is suppressed if No_Initialization set.
3412
3413          if not Controlled_Type (Typ)
3414            or else No_Initialization (N)
3415          then
3416             null;
3417
3418          elsif not Abort_Allowed
3419            or else not Comes_From_Source (N)
3420          then
3421             Insert_Actions_After (N,
3422               Make_Init_Call (
3423                 Ref         => New_Occurrence_Of (Def_Id, Loc),
3424                 Typ         => Base_Type (Typ),
3425                 Flist_Ref   => Find_Final_List (Def_Id),
3426                 With_Attach => Make_Integer_Literal (Loc, 1)));
3427
3428          --  Abort allowed
3429
3430          else
3431             --  We need to protect the initialize call
3432
3433             --  begin
3434             --     Defer_Abort.all;
3435             --     Initialize (...);
3436             --  at end
3437             --     Undefer_Abort.all;
3438             --  end;
3439
3440             --  ??? this won't protect the initialize call for controlled
3441             --  components which are part of the init proc, so this block
3442             --  should probably also contain the call to _init_proc but this
3443             --  requires some code reorganization...
3444
3445             declare
3446                L   : constant List_Id :=
3447                       Make_Init_Call (
3448                         Ref         => New_Occurrence_Of (Def_Id, Loc),
3449                         Typ         => Base_Type (Typ),
3450                         Flist_Ref   => Find_Final_List (Def_Id),
3451                         With_Attach => Make_Integer_Literal (Loc, 1));
3452
3453                Blk : constant Node_Id :=
3454                  Make_Block_Statement (Loc,
3455                    Handled_Statement_Sequence =>
3456                      Make_Handled_Sequence_Of_Statements (Loc, L));
3457
3458             begin
3459                Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
3460                Set_At_End_Proc (Handled_Statement_Sequence (Blk),
3461                  New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
3462                Insert_Actions_After (N, New_List (Blk));
3463                Expand_At_End_Handler
3464                  (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
3465             end;
3466          end if;
3467
3468          --  Call type initialization procedure if there is one. We build the
3469          --  call and put it immediately after the object declaration, so that
3470          --  it will be expanded in the usual manner. Note that this will
3471          --  result in proper handling of defaulted discriminants. The call
3472          --  to the Init_Proc is suppressed if No_Initialization is set.
3473
3474          if Has_Non_Null_Base_Init_Proc (Typ)
3475            and then not No_Initialization (N)
3476          then
3477             --  The call to the initialization procedure does NOT freeze
3478             --  the object being initialized. This is because the call is
3479             --  not a source level call. This works fine, because the only
3480             --  possible statements depending on freeze status that can
3481             --  appear after the _Init call are rep clauses which can
3482             --  safely appear after actual references to the object.
3483
3484             Id_Ref := New_Reference_To (Def_Id, Loc);
3485             Set_Must_Not_Freeze (Id_Ref);
3486             Set_Assignment_OK (Id_Ref);
3487
3488             Insert_Actions_After (N,
3489               Build_Initialization_Call (Loc, Id_Ref, Typ));
3490
3491          --  If simple initialization is required, then set an appropriate
3492          --  simple initialization expression in place. This special
3493          --  initialization is required even though No_Init_Flag is present.
3494
3495          --  An internally generated temporary needs no initialization because
3496          --  it will be assigned subsequently. In particular, there is no
3497          --  point in applying Initialize_Scalars to such a temporary.
3498
3499          elsif Needs_Simple_Initialization (Typ)
3500             and then not Is_Internal (Def_Id)
3501          then
3502             Set_No_Initialization (N, False);
3503             Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id)));
3504             Analyze_And_Resolve (Expression (N), Typ);
3505          end if;
3506
3507          --  Generate attribute for Persistent_BSS if needed
3508
3509          declare
3510             Prag : Node_Id;
3511          begin
3512             if Persistent_BSS_Mode
3513               and then Comes_From_Source (N)
3514               and then Is_Potentially_Persistent_Type (Typ)
3515               and then Is_Library_Level_Entity (Def_Id)
3516             then
3517                Prag :=
3518                  Make_Linker_Section_Pragma
3519                    (Def_Id, Sloc (N), ".persistent.bss");
3520                Insert_After (N, Prag);
3521                Analyze (Prag);
3522             end if;
3523          end;
3524
3525       --  Explicit initialization present
3526
3527       else
3528          --  Obtain actual expression from qualified expression
3529
3530          if Nkind (Expr) = N_Qualified_Expression then
3531             Expr_Q := Expression (Expr);
3532          else
3533             Expr_Q := Expr;
3534          end if;
3535
3536          --  When we have the appropriate type of aggregate in the
3537          --  expression (it has been determined during analysis of the
3538          --  aggregate by setting the delay flag), let's perform in
3539          --  place assignment and thus avoid creating a temporary.
3540
3541          if Is_Delayed_Aggregate (Expr_Q) then
3542             Convert_Aggr_In_Object_Decl (N);
3543
3544          else
3545             --  In most cases, we must check that the initial value meets
3546             --  any constraint imposed by the declared type. However, there
3547             --  is one very important exception to this rule. If the entity
3548             --  has an unconstrained nominal subtype, then it acquired its
3549             --  constraints from the expression in the first place, and not
3550             --  only does this mean that the constraint check is not needed,
3551             --  but an attempt to perform the constraint check can
3552             --  cause order of elaboration problems.
3553
3554             if not Is_Constr_Subt_For_U_Nominal (Typ) then
3555
3556                --  If this is an allocator for an aggregate that has been
3557                --  allocated in place, delay checks until assignments are
3558                --  made, because the discriminants are not initialized.
3559
3560                if Nkind (Expr) = N_Allocator
3561                  and then No_Initialization (Expr)
3562                then
3563                   null;
3564                else
3565                   Apply_Constraint_Check (Expr, Typ);
3566                end if;
3567             end if;
3568
3569             --  If the type is controlled we attach the object to the final
3570             --  list and adjust the target after the copy. This
3571
3572             if Controlled_Type (Typ) then
3573                declare
3574                   Flist : Node_Id;
3575                   F     : Entity_Id;
3576
3577                begin
3578                   --  Attach the result to a dummy final list which will never
3579                   --  be finalized if Delay_Finalize_Attachis set. It is
3580                   --  important to attach to a dummy final list rather than
3581                   --  not attaching at all in order to reset the pointers
3582                   --  coming from the initial value. Equivalent code exists
3583                   --  in the sec-stack case in Exp_Ch4.Expand_N_Allocator.
3584
3585                   if Delay_Finalize_Attach (N) then
3586                      F :=
3587                        Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
3588                      Insert_Action (N,
3589                        Make_Object_Declaration (Loc,
3590                          Defining_Identifier => F,
3591                          Object_Definition   =>
3592                            New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
3593
3594                      Flist := New_Reference_To (F, Loc);
3595
3596                   else
3597                      Flist := Find_Final_List (Def_Id);
3598                   end if;
3599
3600                   Insert_Actions_After (N,
3601                     Make_Adjust_Call (
3602                       Ref          => New_Reference_To (Def_Id, Loc),
3603                       Typ          => Base_Type (Typ),
3604                       Flist_Ref    => Flist,
3605                       With_Attach  => Make_Integer_Literal (Loc, 1)));
3606                end;
3607             end if;
3608
3609             --  For tagged types, when an init value is given, the tag has to
3610             --  be re-initialized separately in order to avoid the propagation
3611             --  of a wrong tag coming from a view conversion unless the type
3612             --  is class wide (in this case the tag comes from the init
3613             --  value). Suppress the tag assignment when Java_VM because JVM
3614             --  tags are represented implicitly in objects. Ditto for types
3615             --  that are CPP_CLASS, and for initializations that are
3616             --  aggregates, because they have to have the right tag.
3617
3618             if Is_Tagged_Type (Typ)
3619               and then not Is_Class_Wide_Type (Typ)
3620               and then not Is_CPP_Class (Typ)
3621               and then not Java_VM
3622               and then Nkind (Expr) /= N_Aggregate
3623             then
3624                --  The re-assignment of the tag has to be done even if
3625                --  the object is a constant
3626
3627                New_Ref :=
3628                  Make_Selected_Component (Loc,
3629                     Prefix => New_Reference_To (Def_Id, Loc),
3630                     Selector_Name =>
3631                       New_Reference_To (First_Tag_Component (Typ), Loc));
3632
3633                Set_Assignment_OK (New_Ref);
3634
3635                Insert_After (N,
3636                  Make_Assignment_Statement (Loc,
3637                    Name => New_Ref,
3638                    Expression =>
3639                      Unchecked_Convert_To (RTE (RE_Tag),
3640                        New_Reference_To
3641                          (Node
3642                            (First_Elmt
3643                              (Access_Disp_Table (Base_Type (Typ)))),
3644                           Loc))));
3645
3646             --  For discrete types, set the Is_Known_Valid flag if the
3647             --  initializing value is known to be valid.
3648
3649             elsif Is_Discrete_Type (Typ)
3650               and then Expr_Known_Valid (Expr)
3651             then
3652                Set_Is_Known_Valid (Def_Id);
3653
3654             elsif Is_Access_Type (Typ) then
3655
3656                --  Ada 2005 (AI-231): Generate conversion to the null-excluding
3657                --  type to force the corresponding run-time check
3658
3659                if Ada_Version >= Ada_05
3660                  and then (Can_Never_Be_Null (Def_Id)
3661                              or else Can_Never_Be_Null (Typ))
3662                then
3663                   Rewrite
3664                     (Expr_Q,
3665                      Convert_To (Etype (Def_Id), Relocate_Node (Expr_Q)));
3666                   Analyze_And_Resolve (Expr_Q, Etype (Def_Id));
3667                end if;
3668
3669                --  For access types set the Is_Known_Non_Null flag if the
3670                --  initializing value is known to be non-null. We can also set
3671                --  Can_Never_Be_Null if this is a constant.
3672
3673                if Known_Non_Null (Expr) then
3674                   Set_Is_Known_Non_Null (Def_Id);
3675
3676                   if Constant_Present (N) then
3677                      Set_Can_Never_Be_Null (Def_Id);
3678                   end if;
3679                end if;
3680             end if;
3681
3682             --  If validity checking on copies, validate initial expression
3683
3684             if Validity_Checks_On
3685                and then Validity_Check_Copies
3686             then
3687                Ensure_Valid (Expr);
3688                Set_Is_Known_Valid (Def_Id);
3689             end if;
3690          end if;
3691
3692          --  Cases where the back end cannot handle the initialization
3693          --  directly. In such cases, we expand an assignment that will
3694          --  be appropriately handled by Expand_N_Assignment_Statement.
3695
3696          --  The exclusion of the unconstrained case is wrong, but for
3697          --  now it is too much trouble ???
3698
3699          if (Is_Possibly_Unaligned_Slice (Expr)
3700                or else (Is_Possibly_Unaligned_Object (Expr)
3701                           and then not Represented_As_Scalar (Etype (Expr))))
3702
3703             --  The exclusion of the unconstrained case is wrong, but for
3704             --  now it is too much trouble ???
3705
3706            and then not (Is_Array_Type (Etype (Expr))
3707                            and then not Is_Constrained (Etype (Expr)))
3708          then
3709             declare
3710                Stat : constant Node_Id :=
3711                        Make_Assignment_Statement (Loc,
3712                          Name       => New_Reference_To (Def_Id, Loc),
3713                          Expression => Relocate_Node (Expr));
3714             begin
3715                Set_Expression (N, Empty);
3716                Set_No_Initialization (N);
3717                Set_Assignment_OK (Name (Stat));
3718                Set_No_Ctrl_Actions (Stat);
3719                Insert_After (N, Stat);
3720                Analyze (Stat);
3721             end;
3722          end if;
3723       end if;
3724
3725       --  For array type, check for size too large
3726       --  We really need this for record types too???
3727
3728       if Is_Array_Type (Typ) then
3729          Apply_Array_Size_Check (N, Typ);
3730       end if;
3731
3732    exception
3733       when RE_Not_Available =>
3734          return;
3735    end Expand_N_Object_Declaration;
3736
3737    ---------------------------------
3738    -- Expand_N_Subtype_Indication --
3739    ---------------------------------
3740
3741    --  Add a check on the range of the subtype. The static case is partially
3742    --  duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
3743    --  to check here for the static case in order to avoid generating
3744    --  extraneous expanded code.
3745
3746    procedure Expand_N_Subtype_Indication (N : Node_Id) is
3747       Ran : constant Node_Id   := Range_Expression (Constraint (N));
3748       Typ : constant Entity_Id := Entity (Subtype_Mark (N));
3749
3750    begin
3751       if Nkind (Parent (N)) = N_Constrained_Array_Definition or else
3752          Nkind (Parent (N)) = N_Slice
3753       then
3754          Resolve (Ran, Typ);
3755          Apply_Range_Check (Ran, Typ);
3756       end if;
3757    end Expand_N_Subtype_Indication;
3758
3759    ---------------------------
3760    -- Expand_N_Variant_Part --
3761    ---------------------------
3762
3763    --  If the last variant does not contain the Others choice, replace it with
3764    --  an N_Others_Choice node since Gigi always wants an Others. Note that we
3765    --  do not bother to call Analyze on the modified variant part, since it's
3766    --  only effect would be to compute the contents of the
3767    --  Others_Discrete_Choices node laboriously, and of course we already know
3768    --  the list of choices that corresponds to the others choice (it's the
3769    --  list we are replacing!)
3770
3771    procedure Expand_N_Variant_Part (N : Node_Id) is
3772       Last_Var    : constant Node_Id := Last_Non_Pragma (Variants (N));
3773       Others_Node : Node_Id;
3774    begin
3775       if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then
3776          Others_Node := Make_Others_Choice (Sloc (Last_Var));
3777          Set_Others_Discrete_Choices
3778            (Others_Node, Discrete_Choices (Last_Var));
3779          Set_Discrete_Choices (Last_Var, New_List (Others_Node));
3780       end if;
3781    end Expand_N_Variant_Part;
3782
3783    ---------------------------------
3784    -- Expand_Previous_Access_Type --
3785    ---------------------------------
3786
3787    procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
3788       T : Entity_Id := First_Entity (Current_Scope);
3789
3790    begin
3791       --  Find all access types declared in the current scope, whose
3792       --  designated type is Def_Id.
3793
3794       while Present (T) loop
3795          if Is_Access_Type (T)
3796            and then Designated_Type (T) = Def_Id
3797          then
3798             Build_Master_Entity (Def_Id);
3799             Build_Master_Renaming (Parent (Def_Id), T);
3800          end if;
3801
3802          Next_Entity (T);
3803       end loop;
3804    end Expand_Previous_Access_Type;
3805
3806    ------------------------------
3807    -- Expand_Record_Controller --
3808    ------------------------------
3809
3810    procedure Expand_Record_Controller (T : Entity_Id) is
3811       Def             : Node_Id := Type_Definition (Parent (T));
3812       Comp_List       : Node_Id;
3813       Comp_Decl       : Node_Id;
3814       Loc             : Source_Ptr;
3815       First_Comp      : Node_Id;
3816       Controller_Type : Entity_Id;
3817       Ent             : Entity_Id;
3818
3819    begin
3820       if Nkind (Def) = N_Derived_Type_Definition then
3821          Def := Record_Extension_Part (Def);
3822       end if;
3823
3824       if Null_Present (Def) then
3825          Set_Component_List (Def,
3826            Make_Component_List (Sloc (Def),
3827              Component_Items => Empty_List,
3828              Variant_Part => Empty,
3829              Null_Present => True));
3830       end if;
3831
3832       Comp_List := Component_List (Def);
3833
3834       if Null_Present (Comp_List)
3835         or else Is_Empty_List (Component_Items (Comp_List))
3836       then
3837          Loc := Sloc (Comp_List);
3838       else
3839          Loc := Sloc (First (Component_Items (Comp_List)));
3840       end if;
3841
3842       if Is_Return_By_Reference_Type (T) then
3843          Controller_Type := RTE (RE_Limited_Record_Controller);
3844       else
3845          Controller_Type := RTE (RE_Record_Controller);
3846       end if;
3847
3848       Ent := Make_Defining_Identifier (Loc, Name_uController);
3849
3850       Comp_Decl :=
3851         Make_Component_Declaration (Loc,
3852           Defining_Identifier =>  Ent,
3853           Component_Definition =>
3854             Make_Component_Definition (Loc,
3855               Aliased_Present => False,
3856               Subtype_Indication => New_Reference_To (Controller_Type, Loc)));
3857
3858       if Null_Present (Comp_List)
3859         or else Is_Empty_List (Component_Items (Comp_List))
3860       then
3861          Set_Component_Items (Comp_List, New_List (Comp_Decl));
3862          Set_Null_Present (Comp_List, False);
3863
3864       else
3865          --  The controller cannot be placed before the _Parent field since
3866          --  gigi lays out field in order and _parent must be first to
3867          --  preserve the polymorphism of tagged types.
3868
3869          First_Comp := First (Component_Items (Comp_List));
3870
3871          if Chars (Defining_Identifier (First_Comp)) /= Name_uParent
3872            and then Chars (Defining_Identifier (First_Comp)) /= Name_uTag
3873          then
3874             Insert_Before (First_Comp, Comp_Decl);
3875          else
3876             Insert_After (First_Comp, Comp_Decl);
3877          end if;
3878       end if;
3879
3880       New_Scope (T);
3881       Analyze (Comp_Decl);
3882       Set_Ekind (Ent, E_Component);
3883       Init_Component_Location (Ent);
3884
3885       --  Move the _controller entity ahead in the list of internal entities
3886       --  of the enclosing record so that it is selected instead of a
3887       --  potentially inherited one.
3888
3889       declare
3890          E    : constant Entity_Id := Last_Entity (T);
3891          Comp : Entity_Id;
3892
3893       begin
3894          pragma Assert (Chars (E) = Name_uController);
3895
3896          Set_Next_Entity (E, First_Entity (T));
3897          Set_First_Entity (T, E);
3898
3899          Comp := Next_Entity (E);
3900          while Next_Entity (Comp) /= E loop
3901             Next_Entity (Comp);
3902          end loop;
3903
3904          Set_Next_Entity (Comp, Empty);
3905          Set_Last_Entity (T, Comp);
3906       end;
3907
3908       End_Scope;
3909
3910    exception
3911       when RE_Not_Available =>
3912          return;
3913    end Expand_Record_Controller;
3914
3915    ------------------------
3916    -- Expand_Tagged_Root --
3917    ------------------------
3918
3919    procedure Expand_Tagged_Root (T : Entity_Id) is
3920       Def       : constant Node_Id := Type_Definition (Parent (T));
3921       Comp_List : Node_Id;
3922       Comp_Decl : Node_Id;
3923       Sloc_N    : Source_Ptr;
3924
3925    begin
3926       if Null_Present (Def) then
3927          Set_Component_List (Def,
3928            Make_Component_List (Sloc (Def),
3929              Component_Items => Empty_List,
3930              Variant_Part => Empty,
3931              Null_Present => True));
3932       end if;
3933
3934       Comp_List := Component_List (Def);
3935
3936       if Null_Present (Comp_List)
3937         or else Is_Empty_List (Component_Items (Comp_List))
3938       then
3939          Sloc_N := Sloc (Comp_List);
3940       else
3941          Sloc_N := Sloc (First (Component_Items (Comp_List)));
3942       end if;
3943
3944       Comp_Decl :=
3945         Make_Component_Declaration (Sloc_N,
3946           Defining_Identifier => First_Tag_Component (T),
3947           Component_Definition =>
3948             Make_Component_Definition (Sloc_N,
3949               Aliased_Present => False,
3950               Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N)));
3951
3952       if Null_Present (Comp_List)
3953         or else Is_Empty_List (Component_Items (Comp_List))
3954       then
3955          Set_Component_Items (Comp_List, New_List (Comp_Decl));
3956          Set_Null_Present (Comp_List, False);
3957
3958       else
3959          Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
3960       end if;
3961
3962       --  We don't Analyze the whole expansion because the tag component has
3963       --  already been analyzed previously. Here we just insure that the tree
3964       --  is coherent with the semantic decoration
3965
3966       Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
3967
3968    exception
3969       when RE_Not_Available =>
3970          return;
3971    end Expand_Tagged_Root;
3972
3973    -----------------------
3974    -- Freeze_Array_Type --
3975    -----------------------
3976
3977    procedure Freeze_Array_Type (N : Node_Id) is
3978       Typ  : constant Entity_Id  := Entity (N);
3979       Base : constant Entity_Id  := Base_Type (Typ);
3980
3981    begin
3982       if not Is_Bit_Packed_Array (Typ) then
3983
3984          --  If the component contains tasks, so does the array type. This may
3985          --  not be indicated in the array type because the component may have
3986          --  been a private type at the point of definition. Same if component
3987          --  type is controlled.
3988
3989          Set_Has_Task (Base, Has_Task (Component_Type (Typ)));
3990          Set_Has_Controlled_Component (Base,
3991            Has_Controlled_Component (Component_Type (Typ))
3992              or else Is_Controlled (Component_Type (Typ)));
3993
3994          if No (Init_Proc (Base)) then
3995
3996             --  If this is an anonymous array created for a declaration with
3997             --  an initial value, its init_proc will never be called. The
3998             --  initial value itself may have been expanded into assign-
3999             --  ments, in which case the object declaration is carries the
4000             --  No_Initialization flag.
4001
4002             if Is_Itype (Base)
4003               and then Nkind (Associated_Node_For_Itype (Base)) =
4004                                                     N_Object_Declaration
4005               and then (Present (Expression (Associated_Node_For_Itype (Base)))
4006                           or else
4007                         No_Initialization (Associated_Node_For_Itype (Base)))
4008             then
4009                null;
4010
4011             --  We do not need an init proc for string or wide [wide] string,
4012             --  since the only time these need initialization in normalize or
4013             --  initialize scalars mode, and these types are treated specially
4014             --  and do not need initialization procedures.
4015
4016             elsif Root_Type (Base) = Standard_String
4017               or else Root_Type (Base) = Standard_Wide_String
4018               or else Root_Type (Base) = Standard_Wide_Wide_String
4019             then
4020                null;
4021
4022             --  Otherwise we have to build an init proc for the subtype
4023
4024             else
4025                Build_Array_Init_Proc (Base, N);
4026             end if;
4027          end if;
4028
4029          if Typ = Base and then Has_Controlled_Component (Base) then
4030             Build_Controlling_Procs (Base);
4031
4032             if not Is_Limited_Type (Component_Type (Typ))
4033               and then Number_Dimensions (Typ) = 1
4034             then
4035                Build_Slice_Assignment (Typ);
4036             end if;
4037          end if;
4038
4039       --  For packed case, there is a default initialization, except if the
4040       --  component type is itself a packed structure with an initialization
4041       --  procedure.
4042
4043       elsif Present (Init_Proc (Component_Type (Base)))
4044         and then No (Base_Init_Proc (Base))
4045       then
4046          Build_Array_Init_Proc (Base, N);
4047       end if;
4048    end Freeze_Array_Type;
4049
4050    -----------------------------
4051    -- Freeze_Enumeration_Type --
4052    -----------------------------
4053
4054    procedure Freeze_Enumeration_Type (N : Node_Id) is
4055       Typ           : constant Entity_Id  := Entity (N);
4056       Loc           : constant Source_Ptr := Sloc (Typ);
4057       Ent           : Entity_Id;
4058       Lst           : List_Id;
4059       Num           : Nat;
4060       Arr           : Entity_Id;
4061       Fent          : Entity_Id;
4062       Ityp          : Entity_Id;
4063       Is_Contiguous : Boolean;
4064       Pos_Expr      : Node_Id;
4065       Last_Repval   : Uint;
4066
4067       Func : Entity_Id;
4068       pragma Warnings (Off, Func);
4069
4070    begin
4071       --  Various optimization are possible if the given representation is
4072       --  contiguous.
4073
4074       Is_Contiguous := True;
4075       Ent := First_Literal (Typ);
4076       Last_Repval := Enumeration_Rep (Ent);
4077       Next_Literal (Ent);
4078
4079       while Present (Ent) loop
4080          if Enumeration_Rep (Ent) - Last_Repval /= 1 then
4081             Is_Contiguous := False;
4082             exit;
4083          else
4084             Last_Repval := Enumeration_Rep (Ent);
4085          end if;
4086
4087          Next_Literal (Ent);
4088       end loop;
4089
4090       if Is_Contiguous then
4091          Set_Has_Contiguous_Rep (Typ);
4092          Ent := First_Literal (Typ);
4093          Num := 1;
4094          Lst := New_List (New_Reference_To (Ent, Sloc (Ent)));
4095
4096       else
4097          --  Build list of literal references
4098
4099          Lst := New_List;
4100          Num := 0;
4101
4102          Ent := First_Literal (Typ);
4103          while Present (Ent) loop
4104             Append_To (Lst, New_Reference_To (Ent, Sloc (Ent)));
4105             Num := Num + 1;
4106             Next_Literal (Ent);
4107          end loop;
4108       end if;
4109
4110       --  Now build an array declaration
4111
4112       --    typA : array (Natural range 0 .. num - 1) of ctype :=
4113       --             (v, v, v, v, v, ....)
4114
4115       --  where ctype is the corresponding integer type. If the representation
4116       --  is contiguous, we only keep the first literal, which provides the
4117       --  offset for Pos_To_Rep computations.
4118
4119       Arr :=
4120         Make_Defining_Identifier (Loc,
4121           Chars => New_External_Name (Chars (Typ), 'A'));
4122
4123       Append_Freeze_Action (Typ,
4124         Make_Object_Declaration (Loc,
4125           Defining_Identifier => Arr,
4126           Constant_Present    => True,
4127
4128           Object_Definition   =>
4129             Make_Constrained_Array_Definition (Loc,
4130               Discrete_Subtype_Definitions => New_List (
4131                 Make_Subtype_Indication (Loc,
4132                   Subtype_Mark => New_Reference_To (Standard_Natural, Loc),
4133                   Constraint =>
4134                     Make_Range_Constraint (Loc,
4135                       Range_Expression =>
4136                         Make_Range (Loc,
4137                           Low_Bound  =>
4138                             Make_Integer_Literal (Loc, 0),
4139                           High_Bound =>
4140                             Make_Integer_Literal (Loc, Num - 1))))),
4141
4142               Component_Definition =>
4143                 Make_Component_Definition (Loc,
4144                   Aliased_Present => False,
4145                   Subtype_Indication => New_Reference_To (Typ, Loc))),
4146
4147           Expression =>
4148             Make_Aggregate (Loc,
4149               Expressions => Lst)));
4150
4151       Set_Enum_Pos_To_Rep (Typ, Arr);
4152
4153       --  Now we build the function that converts representation values to
4154       --  position values. This function has the form:
4155
4156       --    function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
4157       --    begin
4158       --       case ityp!(A) is
4159       --         when enum-lit'Enum_Rep => return posval;
4160       --         when enum-lit'Enum_Rep => return posval;
4161       --         ...
4162       --         when others   =>
4163       --           [raise Constraint_Error when F "invalid data"]
4164       --           return -1;
4165       --       end case;
4166       --    end;
4167
4168       --  Note: the F parameter determines whether the others case (no valid
4169       --  representation) raises Constraint_Error or returns a unique value
4170       --  of minus one. The latter case is used, e.g. in 'Valid code.
4171
4172       --  Note: the reason we use Enum_Rep values in the case here is to avoid
4173       --  the code generator making inappropriate assumptions about the range
4174       --  of the values in the case where the value is invalid. ityp is a
4175       --  signed or unsigned integer type of appropriate width.
4176
4177       --  Note: if exceptions are not supported, then we suppress the raise
4178       --  and return -1 unconditionally (this is an erroneous program in any
4179       --  case and there is no obligation to raise Constraint_Error here!) We
4180       --  also do this if pragma Restrictions (No_Exceptions) is active.
4181
4182       --  Representations are signed
4183
4184       if Enumeration_Rep (First_Literal (Typ)) < 0 then
4185
4186          --  The underlying type is signed. Reset the Is_Unsigned_Type
4187          --  explicitly, because it might have been inherited from
4188          --  parent type.
4189
4190          Set_Is_Unsigned_Type (Typ, False);
4191
4192          if Esize (Typ) <= Standard_Integer_Size then
4193             Ityp := Standard_Integer;
4194          else
4195             Ityp := Universal_Integer;
4196          end if;
4197
4198       --  Representations are unsigned
4199
4200       else
4201          if Esize (Typ) <= Standard_Integer_Size then
4202             Ityp := RTE (RE_Unsigned);
4203          else
4204             Ityp := RTE (RE_Long_Long_Unsigned);
4205          end if;
4206       end if;
4207
4208       --  The body of the function is a case statement. First collect case
4209       --  alternatives, or optimize the contiguous case.
4210
4211       Lst := New_List;
4212
4213       --  If representation is contiguous, Pos is computed by subtracting
4214       --  the representation of the first literal.
4215
4216       if Is_Contiguous then
4217          Ent := First_Literal (Typ);
4218
4219          if Enumeration_Rep (Ent) = Last_Repval then
4220
4221             --  Another special case: for a single literal, Pos is zero
4222
4223             Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
4224
4225          else
4226             Pos_Expr :=
4227               Convert_To (Standard_Integer,
4228                 Make_Op_Subtract (Loc,
4229                   Left_Opnd =>
4230                      Unchecked_Convert_To (Ityp,
4231                        Make_Identifier (Loc, Name_uA)),
4232                    Right_Opnd =>
4233                      Make_Integer_Literal (Loc,
4234                         Intval =>
4235                           Enumeration_Rep (First_Literal (Typ)))));
4236          end if;
4237
4238          Append_To (Lst,
4239               Make_Case_Statement_Alternative (Loc,
4240                 Discrete_Choices => New_List (
4241                   Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
4242                     Low_Bound =>
4243                       Make_Integer_Literal (Loc,
4244                        Intval =>  Enumeration_Rep (Ent)),
4245                     High_Bound =>
4246                       Make_Integer_Literal (Loc, Intval => Last_Repval))),
4247
4248                 Statements => New_List (
4249                   Make_Return_Statement (Loc,
4250                     Expression => Pos_Expr))));
4251
4252       else
4253          Ent := First_Literal (Typ);
4254
4255          while Present (Ent) loop
4256             Append_To (Lst,
4257               Make_Case_Statement_Alternative (Loc,
4258                 Discrete_Choices => New_List (
4259                   Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
4260                     Intval => Enumeration_Rep (Ent))),
4261
4262                 Statements => New_List (
4263                   Make_Return_Statement (Loc,
4264                     Expression =>
4265                       Make_Integer_Literal (Loc,
4266                         Intval => Enumeration_Pos (Ent))))));
4267
4268             Next_Literal (Ent);
4269          end loop;
4270       end if;
4271
4272       --  In normal mode, add the others clause with the test
4273
4274       if not Restriction_Active (No_Exception_Handlers) then
4275          Append_To (Lst,
4276            Make_Case_Statement_Alternative (Loc,
4277              Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4278              Statements => New_List (
4279                Make_Raise_Constraint_Error (Loc,
4280                  Condition => Make_Identifier (Loc, Name_uF),
4281                  Reason    => CE_Invalid_Data),
4282                Make_Return_Statement (Loc,
4283                  Expression =>
4284                    Make_Integer_Literal (Loc, -1)))));
4285
4286       --  If Restriction (No_Exceptions_Handlers) is active then we always
4287       --  return -1 (since we cannot usefully raise Constraint_Error in
4288       --  this case). See description above for further details.
4289
4290       else
4291          Append_To (Lst,
4292            Make_Case_Statement_Alternative (Loc,
4293              Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4294              Statements => New_List (
4295                Make_Return_Statement (Loc,
4296                  Expression =>
4297                    Make_Integer_Literal (Loc, -1)))));
4298       end if;
4299
4300       --  Now we can build the function body
4301
4302       Fent :=
4303         Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
4304
4305       Func :=
4306         Make_Subprogram_Body (Loc,
4307           Specification =>
4308             Make_Function_Specification (Loc,
4309               Defining_Unit_Name       => Fent,
4310               Parameter_Specifications => New_List (
4311                 Make_Parameter_Specification (Loc,
4312                   Defining_Identifier =>
4313                     Make_Defining_Identifier (Loc, Name_uA),
4314                   Parameter_Type => New_Reference_To (Typ, Loc)),
4315                 Make_Parameter_Specification (Loc,
4316                   Defining_Identifier =>
4317                     Make_Defining_Identifier (Loc, Name_uF),
4318                   Parameter_Type => New_Reference_To (Standard_Boolean, Loc))),
4319
4320               Subtype_Mark => New_Reference_To (Standard_Integer, Loc)),
4321
4322             Declarations => Empty_List,
4323
4324             Handled_Statement_Sequence =>
4325               Make_Handled_Sequence_Of_Statements (Loc,
4326                 Statements => New_List (
4327                   Make_Case_Statement (Loc,
4328                     Expression =>
4329                       Unchecked_Convert_To (Ityp,
4330                         Make_Identifier (Loc, Name_uA)),
4331                     Alternatives => Lst))));
4332
4333       Set_TSS (Typ, Fent);
4334       Set_Is_Pure (Fent);
4335
4336       if not Debug_Generated_Code then
4337          Set_Debug_Info_Off (Fent);
4338       end if;
4339
4340    exception
4341       when RE_Not_Available =>
4342          return;
4343    end Freeze_Enumeration_Type;
4344
4345    ------------------------
4346    -- Freeze_Record_Type --
4347    ------------------------
4348
4349    procedure Freeze_Record_Type (N : Node_Id) is
4350       Def_Id      : constant Node_Id := Entity (N);
4351       Comp        : Entity_Id;
4352       Type_Decl   : constant Node_Id := Parent (Def_Id);
4353       Predef_List : List_Id;
4354
4355       Renamed_Eq  : Node_Id := Empty;
4356       --  Could use some comments ???
4357
4358    begin
4359       --  Build discriminant checking functions if not a derived type (for
4360       --  derived types that are not tagged types, we always use the
4361       --  discriminant checking functions of the parent type). However, for
4362       --  untagged types the derivation may have taken place before the
4363       --  parent was frozen, so we copy explicitly the discriminant checking
4364       --  functions from the parent into the components of the derived type.
4365
4366       if not Is_Derived_Type (Def_Id)
4367         or else Has_New_Non_Standard_Rep (Def_Id)
4368         or else Is_Tagged_Type (Def_Id)
4369       then
4370          Build_Discr_Checking_Funcs (Type_Decl);
4371
4372       elsif Is_Derived_Type (Def_Id)
4373         and then not Is_Tagged_Type (Def_Id)
4374
4375          --  If we have a derived Unchecked_Union, we do not inherit the
4376          --  discriminant checking functions from the parent type since the
4377          --  discriminants are non existent.
4378
4379         and then not Is_Unchecked_Union (Def_Id)
4380         and then Has_Discriminants (Def_Id)
4381       then
4382          declare
4383             Old_Comp : Entity_Id;
4384
4385          begin
4386             Old_Comp :=
4387               First_Component (Base_Type (Underlying_Type (Etype (Def_Id))));
4388             Comp := First_Component (Def_Id);
4389             while Present (Comp) loop
4390                if Ekind (Comp) = E_Component
4391                  and then Chars (Comp) = Chars (Old_Comp)
4392                then
4393                   Set_Discriminant_Checking_Func (Comp,
4394                      Discriminant_Checking_Func (Old_Comp));
4395                end if;
4396
4397                Next_Component (Old_Comp);
4398                Next_Component (Comp);
4399             end loop;
4400          end;
4401       end if;
4402
4403       if Is_Derived_Type (Def_Id)
4404         and then Is_Limited_Type (Def_Id)
4405         and then Is_Tagged_Type (Def_Id)
4406       then
4407          Check_Stream_Attributes (Def_Id);
4408       end if;
4409
4410       --  Update task and controlled component flags, because some of the
4411       --  component types may have been private at the point of the record
4412       --  declaration.
4413
4414       Comp := First_Component (Def_Id);
4415
4416       while Present (Comp) loop
4417          if Has_Task (Etype (Comp)) then
4418             Set_Has_Task (Def_Id);
4419
4420          elsif Has_Controlled_Component (Etype (Comp))
4421            or else (Chars (Comp) /= Name_uParent
4422                      and then Is_Controlled (Etype (Comp)))
4423          then
4424             Set_Has_Controlled_Component (Def_Id);
4425          end if;
4426
4427          Next_Component (Comp);
4428       end loop;
4429
4430       --  Creation of the Dispatch Table. Note that a Dispatch Table is
4431       --  created for regular tagged types as well as for Ada types deriving
4432       --  from a C++ Class, but not for tagged types directly corresponding to
4433       --  the C++ classes. In the later case we assume that the Vtable is
4434       --  created in the C++ side and we just use it.
4435
4436       if Is_Tagged_Type (Def_Id) then
4437
4438          if Is_CPP_Class (Def_Id) then
4439             Set_All_DT_Position (Def_Id);
4440             Set_Default_Constructor (Def_Id);
4441
4442          else
4443             --  Usually inherited primitives are not delayed but the first Ada
4444             --  extension of a CPP_Class is an exception since the address of
4445             --  the inherited subprogram has to be inserted in the new Ada
4446             --  Dispatch Table and this is a freezing action (usually the
4447             --  inherited primitive address is inserted in the DT by
4448             --  Inherit_DT)
4449
4450             --  Similarly, if this is an inherited operation whose parent is
4451             --  not frozen yet, it is not in the DT of the parent, and we
4452             --  generate an explicit freeze node for the inherited operation,
4453             --  so that it is properly inserted in the DT of the current type.
4454
4455             declare
4456                Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
4457                Subp : Entity_Id;
4458
4459             begin
4460                while Present (Elmt) loop
4461                   Subp := Node (Elmt);
4462
4463                   if Present (Alias (Subp)) then
4464                      if Is_CPP_Class (Etype (Def_Id)) then
4465                         Set_Has_Delayed_Freeze (Subp);
4466
4467                      elsif Has_Delayed_Freeze (Alias (Subp))
4468                        and then not Is_Frozen (Alias (Subp))
4469                      then
4470                         Set_Is_Frozen (Subp, False);
4471                         Set_Has_Delayed_Freeze (Subp);
4472                      end if;
4473                   end if;
4474
4475                   Next_Elmt (Elmt);
4476                end loop;
4477             end;
4478
4479             if Underlying_Type (Etype (Def_Id)) = Def_Id then
4480                Expand_Tagged_Root (Def_Id);
4481             end if;
4482
4483             --  Build the secondary tables
4484
4485             if not Java_VM
4486               and then Present (Abstract_Interfaces (Def_Id))
4487               and then not Is_Empty_Elmt_List (Abstract_Interfaces (Def_Id))
4488             then
4489                declare
4490                   E      : Entity_Id;
4491                   Result : List_Id;
4492                   ADT    : Elist_Id := Access_Disp_Table (Def_Id);
4493
4494                begin
4495                   E := First_Entity (Def_Id);
4496                   while Present (E) loop
4497                      if Is_Tag (E) and then Chars (E) /= Name_uTag then
4498                         Make_Abstract_Interface_DT
4499                           (AI_Tag          => E,
4500                            Acc_Disp_Tables => ADT,
4501                            Result          => Result);
4502
4503                         Append_Freeze_Actions (Def_Id, Result);
4504                      end if;
4505
4506                      Next_Entity (E);
4507                   end loop;
4508
4509                   Set_Access_Disp_Table (Def_Id, ADT);
4510                end;
4511             end if;
4512
4513             --  Unfreeze momentarily the type to add the predefined primitives
4514             --  operations. The reason we unfreeze is so that these predefined
4515             --  operations will indeed end up as primitive operations (which
4516             --  must be before the freeze point).
4517
4518             Set_Is_Frozen (Def_Id, False);
4519             Make_Predefined_Primitive_Specs
4520               (Def_Id, Predef_List, Renamed_Eq);
4521             Insert_List_Before_And_Analyze (N, Predef_List);
4522             Set_Is_Frozen (Def_Id, True);
4523             Set_All_DT_Position (Def_Id);
4524
4525             --  Add the controlled component before the freezing actions
4526             --  referenced in those actions.
4527
4528             if Has_New_Controlled_Component (Def_Id) then
4529                Expand_Record_Controller (Def_Id);
4530             end if;
4531
4532             --  Suppress creation of a dispatch table when Java_VM because the
4533             --  dispatching mechanism is handled internally by the JVM.
4534
4535             if not Java_VM then
4536                Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
4537             end if;
4538
4539             --  Make sure that the primitives Initialize, Adjust and Finalize
4540             --  are Frozen before other TSS subprograms. We don't want them
4541             --  Frozen inside.
4542
4543             if Is_Controlled (Def_Id) then
4544                if not Is_Limited_Type (Def_Id) then
4545                   Append_Freeze_Actions (Def_Id,
4546                     Freeze_Entity
4547                       (Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id)));
4548                end if;
4549
4550                Append_Freeze_Actions (Def_Id,
4551                  Freeze_Entity
4552                    (Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id)));
4553
4554                Append_Freeze_Actions (Def_Id,
4555                  Freeze_Entity
4556                    (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id)));
4557             end if;
4558
4559             --  Freeze rest of primitive operations
4560
4561             Append_Freeze_Actions
4562               (Def_Id, Predefined_Primitive_Freeze (Def_Id));
4563          end if;
4564
4565       --  In the non-tagged case, an equality function is provided only for
4566       --  variant records (that are not unchecked unions).
4567
4568       elsif Has_Discriminants (Def_Id)
4569         and then not Is_Limited_Type (Def_Id)
4570       then
4571          declare
4572             Comps : constant Node_Id :=
4573                       Component_List (Type_Definition (Type_Decl));
4574
4575          begin
4576             if Present (Comps)
4577               and then Present (Variant_Part (Comps))
4578             then
4579                Build_Variant_Record_Equality (Def_Id);
4580             end if;
4581          end;
4582       end if;
4583
4584       --  Before building the record initialization procedure, if we are
4585       --  dealing with a concurrent record value type, then we must go through
4586       --  the discriminants, exchanging discriminals between the concurrent
4587       --  type and the concurrent record value type. See the section "Handling
4588       --  of Discriminants" in the Einfo spec for details.
4589
4590       if Is_Concurrent_Record_Type (Def_Id)
4591         and then Has_Discriminants (Def_Id)
4592       then
4593          declare
4594             Ctyp : constant Entity_Id :=
4595                      Corresponding_Concurrent_Type (Def_Id);
4596             Conc_Discr : Entity_Id;
4597             Rec_Discr  : Entity_Id;
4598             Temp       : Entity_Id;
4599
4600          begin
4601             Conc_Discr := First_Discriminant (Ctyp);
4602             Rec_Discr  := First_Discriminant (Def_Id);
4603
4604             while Present (Conc_Discr) loop
4605                Temp := Discriminal (Conc_Discr);
4606                Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
4607                Set_Discriminal (Rec_Discr, Temp);
4608
4609                Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
4610                Set_Discriminal_Link (Discriminal (Rec_Discr),  Rec_Discr);
4611
4612                Next_Discriminant (Conc_Discr);
4613                Next_Discriminant (Rec_Discr);
4614             end loop;
4615          end;
4616       end if;
4617
4618       if Has_Controlled_Component (Def_Id) then
4619          if No (Controller_Component (Def_Id)) then
4620             Expand_Record_Controller (Def_Id);
4621          end if;
4622
4623          Build_Controlling_Procs (Def_Id);
4624       end if;
4625
4626       Adjust_Discriminants (Def_Id);
4627       Build_Record_Init_Proc (Type_Decl, Def_Id);
4628
4629       --  For tagged type, build bodies of primitive operations. Note that we
4630       --  do this after building the record initialization experiment, since
4631       --  the primitive operations may need the initialization routine
4632
4633       if Is_Tagged_Type (Def_Id) then
4634          Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
4635          Append_Freeze_Actions (Def_Id, Predef_List);
4636       end if;
4637
4638    end Freeze_Record_Type;
4639
4640    ------------------------------
4641    -- Freeze_Stream_Operations --
4642    ------------------------------
4643
4644    procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
4645       Names     : constant array (1 .. 4) of TSS_Name_Type :=
4646                     (TSS_Stream_Input,
4647                      TSS_Stream_Output,
4648                      TSS_Stream_Read,
4649                      TSS_Stream_Write);
4650       Stream_Op : Entity_Id;
4651
4652    begin
4653       --  Primitive operations of tagged types are frozen when the dispatch
4654       --  table is constructed.
4655
4656       if not Comes_From_Source (Typ)
4657         or else Is_Tagged_Type (Typ)
4658       then
4659          return;
4660       end if;
4661
4662       for J in Names'Range loop
4663          Stream_Op := TSS (Typ, Names (J));
4664
4665          if Present (Stream_Op)
4666            and then Is_Subprogram (Stream_Op)
4667            and then Nkind (Unit_Declaration_Node (Stream_Op)) =
4668                       N_Subprogram_Declaration
4669            and then not Is_Frozen (Stream_Op)
4670          then
4671             Append_Freeze_Actions
4672                (Typ, Freeze_Entity (Stream_Op, Sloc (N)));
4673          end if;
4674       end loop;
4675    end Freeze_Stream_Operations;
4676
4677    -----------------
4678    -- Freeze_Type --
4679    -----------------
4680
4681    --  Full type declarations are expanded at the point at which the type is
4682    --  frozen. The formal N is the Freeze_Node for the type. Any statements or
4683    --  declarations generated by the freezing (e.g. the procedure generated
4684    --  for initialization) are chained in the Actions field list of the freeze
4685    --  node using Append_Freeze_Actions.
4686
4687    function Freeze_Type (N : Node_Id) return Boolean is
4688       Def_Id    : constant Entity_Id := Entity (N);
4689       RACW_Seen : Boolean := False;
4690       Result    : Boolean := False;
4691
4692    begin
4693       --  Process associated access types needing special processing
4694
4695       if Present (Access_Types_To_Process (N)) then
4696          declare
4697             E : Elmt_Id := First_Elmt (Access_Types_To_Process (N));
4698          begin
4699             while Present (E) loop
4700
4701                if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
4702                   RACW_Seen := True;
4703                end if;
4704
4705                E := Next_Elmt (E);
4706             end loop;
4707          end;
4708
4709          if RACW_Seen then
4710
4711             --  If there are RACWs designating this type, make stubs now
4712
4713             Remote_Types_Tagged_Full_View_Encountered (Def_Id);
4714          end if;
4715       end if;
4716
4717       --  Freeze processing for record types
4718
4719       if Is_Record_Type (Def_Id) then
4720          if Ekind (Def_Id) = E_Record_Type then
4721             Freeze_Record_Type (N);
4722
4723          --  The subtype may have been declared before the type was frozen. If
4724          --  the type has controlled components it is necessary to create the
4725          --  entity for the controller explicitly because it did not exist at
4726          --  the point of the subtype declaration. Only the entity is needed,
4727          --  the back-end will obtain the layout from the type. This is only
4728          --  necessary if this is constrained subtype whose component list is
4729          --  not shared with the base type.
4730
4731          elsif Ekind (Def_Id) = E_Record_Subtype
4732            and then Has_Discriminants (Def_Id)
4733            and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id))
4734            and then Present (Controller_Component (Def_Id))
4735          then
4736             declare
4737                Old_C : constant Entity_Id := Controller_Component (Def_Id);
4738                New_C : Entity_Id;
4739
4740             begin
4741                if Scope (Old_C) = Base_Type (Def_Id) then
4742
4743                   --  The entity is the one in the parent. Create new one
4744
4745                   New_C := New_Copy (Old_C);
4746                   Set_Parent (New_C, Parent (Old_C));
4747                   New_Scope (Def_Id);
4748                   Enter_Name (New_C);
4749                   End_Scope;
4750                end if;
4751             end;
4752
4753             if Is_Itype (Def_Id)
4754               and then Is_Record_Type (Underlying_Type (Scope (Def_Id)))
4755             then
4756                --  The freeze node is only used to introduce the controller,
4757                --  the back-end has no use for it for a discriminated
4758                --   component.
4759
4760                Set_Freeze_Node (Def_Id, Empty);
4761                Set_Has_Delayed_Freeze (Def_Id, False);
4762                Result := True;
4763             end if;
4764
4765          --  Similar process if the controller of the subtype is not present
4766          --  but the parent has it. This can happen with constrained
4767          --  record components where the subtype is an itype.
4768
4769          elsif Ekind (Def_Id) = E_Record_Subtype
4770            and then Is_Itype (Def_Id)
4771            and then No (Controller_Component (Def_Id))
4772            and then Present (Controller_Component (Etype (Def_Id)))
4773          then
4774             declare
4775                Old_C : constant Entity_Id :=
4776                          Controller_Component (Etype (Def_Id));
4777                New_C : constant Entity_Id := New_Copy (Old_C);
4778
4779             begin
4780                Set_Next_Entity  (New_C, First_Entity (Def_Id));
4781                Set_First_Entity (Def_Id, New_C);
4782
4783                --  The freeze node is only used to introduce the controller,
4784                --  the back-end has no use for it for a discriminated
4785                --   component.
4786
4787                Set_Freeze_Node (Def_Id, Empty);
4788                Set_Has_Delayed_Freeze (Def_Id, False);
4789                Result := True;
4790             end;
4791          end if;
4792
4793       --  Freeze processing for array types
4794
4795       elsif Is_Array_Type (Def_Id) then
4796          Freeze_Array_Type (N);
4797
4798       --  Freeze processing for access types
4799
4800       --  For pool-specific access types, find out the pool object used for
4801       --  this type, needs actual expansion of it in some cases. Here are the
4802       --  different cases :
4803
4804       --  1. Rep Clause "for Def_Id'Storage_Size use 0;"
4805       --      ---> don't use any storage pool
4806
4807       --  2. Rep Clause : for Def_Id'Storage_Size use Expr.
4808       --     Expand:
4809       --      Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
4810
4811       --  3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
4812       --      ---> Storage Pool is the specified one
4813
4814       --  See GNAT Pool packages in the Run-Time for more details
4815
4816       elsif Ekind (Def_Id) = E_Access_Type
4817         or else Ekind (Def_Id) = E_General_Access_Type
4818       then
4819          declare
4820             Loc         : constant Source_Ptr := Sloc (N);
4821             Desig_Type  : constant Entity_Id := Designated_Type (Def_Id);
4822             Pool_Object : Entity_Id;
4823             Siz_Exp     : Node_Id;
4824
4825             Freeze_Action_Typ : Entity_Id;
4826
4827          begin
4828             if Has_Storage_Size_Clause (Def_Id) then
4829                Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id)));
4830             else
4831                Siz_Exp := Empty;
4832             end if;
4833
4834             --  Case 1
4835
4836             --    Rep Clause "for Def_Id'Storage_Size use 0;"
4837             --    ---> don't use any storage pool
4838
4839             if Has_Storage_Size_Clause (Def_Id)
4840               and then Compile_Time_Known_Value (Siz_Exp)
4841               and then Expr_Value (Siz_Exp) = 0
4842             then
4843                null;
4844
4845             --  Case 2
4846
4847             --    Rep Clause : for Def_Id'Storage_Size use Expr.
4848             --    ---> Expand:
4849             --           Def_Id__Pool : Stack_Bounded_Pool
4850             --                            (Expr, DT'Size, DT'Alignment);
4851
4852             elsif Has_Storage_Size_Clause (Def_Id) then
4853                declare
4854                   DT_Size  : Node_Id;
4855                   DT_Align : Node_Id;
4856
4857                begin
4858                   --  For unconstrained composite types we give a size of zero
4859                   --  so that the pool knows that it needs a special algorithm
4860                   --  for variable size object allocation.
4861
4862                   if Is_Composite_Type (Desig_Type)
4863                     and then not Is_Constrained (Desig_Type)
4864                   then
4865                      DT_Size :=
4866                        Make_Integer_Literal (Loc, 0);
4867
4868                      DT_Align :=
4869                        Make_Integer_Literal (Loc, Maximum_Alignment);
4870
4871                   else
4872                      DT_Size :=
4873                        Make_Attribute_Reference (Loc,
4874                          Prefix => New_Reference_To (Desig_Type, Loc),
4875                          Attribute_Name => Name_Max_Size_In_Storage_Elements);
4876
4877                      DT_Align :=
4878                        Make_Attribute_Reference (Loc,
4879                          Prefix => New_Reference_To (Desig_Type, Loc),
4880                          Attribute_Name => Name_Alignment);
4881                   end if;
4882
4883                   Pool_Object :=
4884                     Make_Defining_Identifier (Loc,
4885                       Chars => New_External_Name (Chars (Def_Id), 'P'));
4886
4887                   --  We put the code associated with the pools in the entity
4888                   --  that has the later freeze node, usually the acces type
4889                   --  but it can also be the designated_type; because the pool
4890                   --  code requires both those types to be frozen
4891
4892                   if Is_Frozen (Desig_Type)
4893                     and then (not Present (Freeze_Node (Desig_Type))
4894                                or else Analyzed (Freeze_Node (Desig_Type)))
4895                   then
4896                      Freeze_Action_Typ := Def_Id;
4897
4898                   --  A Taft amendment type cannot get the freeze actions
4899                   --  since the full view is not there.
4900
4901                   elsif Is_Incomplete_Or_Private_Type (Desig_Type)
4902                     and then No (Full_View (Desig_Type))
4903                   then
4904                      Freeze_Action_Typ := Def_Id;
4905
4906                   else
4907                      Freeze_Action_Typ := Desig_Type;
4908                   end if;
4909
4910                   Append_Freeze_Action (Freeze_Action_Typ,
4911                     Make_Object_Declaration (Loc,
4912                       Defining_Identifier => Pool_Object,
4913                       Object_Definition =>
4914                         Make_Subtype_Indication (Loc,
4915                           Subtype_Mark =>
4916                             New_Reference_To
4917                               (RTE (RE_Stack_Bounded_Pool), Loc),
4918
4919                           Constraint =>
4920                             Make_Index_Or_Discriminant_Constraint (Loc,
4921                               Constraints => New_List (
4922
4923                               --  First discriminant is the Pool Size
4924
4925                                 New_Reference_To (
4926                                   Storage_Size_Variable (Def_Id), Loc),
4927
4928                               --  Second discriminant is the element size
4929
4930                                 DT_Size,
4931
4932                               --  Third discriminant is the alignment
4933
4934                                 DT_Align)))));
4935                end;
4936
4937                Set_Associated_Storage_Pool (Def_Id, Pool_Object);
4938
4939             --  Case 3
4940
4941             --    Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
4942             --    ---> Storage Pool is the specified one
4943
4944             elsif Present (Associated_Storage_Pool (Def_Id)) then
4945
4946                --  Nothing to do the associated storage pool has been attached
4947                --  when analyzing the rep. clause
4948
4949                null;
4950             end if;
4951
4952             --  For access-to-controlled types (including class-wide types and
4953             --  Taft-amendment types which potentially have controlled
4954             --  components), expand the list controller object that will store
4955             --  the dynamically allocated objects. Do not do this
4956             --  transformation for expander-generated access types, but do it
4957             --  for types that are the full view of types derived from other
4958             --  private types. Also suppress the list controller in the case
4959             --  of a designated type with convention Java, since this is used
4960             --  when binding to Java API specs, where there's no equivalent of
4961             --  a finalization list and we don't want to pull in the
4962             --  finalization support if not needed.
4963
4964             if not Comes_From_Source (Def_Id)
4965                and then not Has_Private_Declaration (Def_Id)
4966             then
4967                null;
4968
4969             elsif (Controlled_Type (Desig_Type)
4970                     and then Convention (Desig_Type) /= Convention_Java)
4971               or else
4972                 (Is_Incomplete_Or_Private_Type (Desig_Type)
4973                    and then No (Full_View (Desig_Type))
4974
4975                   --  An exception is made for types defined in the run-time
4976                   --  because Ada.Tags.Tag itself is such a type and cannot
4977                   --  afford this unnecessary overhead that would generates a
4978                   --  loop in the expansion scheme...
4979
4980                   and then not In_Runtime (Def_Id)
4981
4982                   --  Another exception is if Restrictions (No_Finalization)
4983                   --  is active, since then we know nothing is controlled.
4984
4985                   and then not Restriction_Active (No_Finalization))
4986
4987                --  If the designated type is not frozen yet, its controlled
4988                --  status must be retrieved explicitly.
4989
4990               or else (Is_Array_Type (Desig_Type)
4991                 and then not Is_Frozen (Desig_Type)
4992                 and then Controlled_Type (Component_Type (Desig_Type)))
4993             then
4994                Set_Associated_Final_Chain (Def_Id,
4995                  Make_Defining_Identifier (Loc,
4996                    New_External_Name (Chars (Def_Id), 'L')));
4997
4998                Append_Freeze_Action (Def_Id,
4999                  Make_Object_Declaration (Loc,
5000                    Defining_Identifier => Associated_Final_Chain (Def_Id),
5001                    Object_Definition   =>
5002                      New_Reference_To (RTE (RE_List_Controller), Loc)));
5003             end if;
5004          end;
5005
5006       --  Freeze processing for enumeration types
5007
5008       elsif Ekind (Def_Id) = E_Enumeration_Type then
5009
5010          --  We only have something to do if we have a non-standard
5011          --  representation (i.e. at least one literal whose pos value
5012          --  is not the same as its representation)
5013
5014          if Has_Non_Standard_Rep (Def_Id) then
5015             Freeze_Enumeration_Type (N);
5016          end if;
5017
5018       --  Private types that are completed by a derivation from a private
5019       --  type have an internally generated full view, that needs to be
5020       --  frozen. This must be done explicitly because the two views share
5021       --  the freeze node, and the underlying full view is not visible when
5022       --  the freeze node is analyzed.
5023
5024       elsif Is_Private_Type (Def_Id)
5025         and then Is_Derived_Type (Def_Id)
5026         and then Present (Full_View (Def_Id))
5027         and then Is_Itype (Full_View (Def_Id))
5028         and then Has_Private_Declaration (Full_View (Def_Id))
5029         and then Freeze_Node (Full_View (Def_Id)) = N
5030       then
5031          Set_Entity (N, Full_View (Def_Id));
5032          Result := Freeze_Type (N);
5033          Set_Entity (N, Def_Id);
5034
5035       --  All other types require no expander action. There are such cases
5036       --  (e.g. task types and protected types). In such cases, the freeze
5037       --  nodes are there for use by Gigi.
5038
5039       end if;
5040
5041       Freeze_Stream_Operations (N, Def_Id);
5042       return Result;
5043
5044    exception
5045       when RE_Not_Available =>
5046          return False;
5047    end Freeze_Type;
5048
5049    -------------------------
5050    -- Get_Simple_Init_Val --
5051    -------------------------
5052
5053    function Get_Simple_Init_Val
5054      (T    : Entity_Id;
5055       Loc  : Source_Ptr;
5056       Size : Uint := No_Uint) return Node_Id
5057    is
5058       Val    : Node_Id;
5059       Result : Node_Id;
5060       Val_RE : RE_Id;
5061
5062       Size_To_Use : Uint;
5063       --  This is the size to be used for computation of the appropriate
5064       --  initial value for the Normalize_Scalars and Initialize_Scalars case.
5065
5066       Lo_Bound : Uint;
5067       Hi_Bound : Uint;
5068       --  These are the values computed by the procedure Check_Subtype_Bounds
5069
5070       procedure Check_Subtype_Bounds;
5071       --  This procedure examines the subtype T, and its ancestor subtypes and
5072       --  derived types to determine the best known information about the
5073       --  bounds of the subtype. After the call Lo_Bound is set either to
5074       --  No_Uint if no information can be determined, or to a value which
5075       --  represents a known low bound, i.e. a valid value of the subtype can
5076       --  not be less than this value. Hi_Bound is similarly set to a known
5077       --  high bound (valid value cannot be greater than this).
5078
5079       --------------------------
5080       -- Check_Subtype_Bounds --
5081       --------------------------
5082
5083       procedure Check_Subtype_Bounds is
5084          ST1  : Entity_Id;
5085          ST2  : Entity_Id;
5086          Lo   : Node_Id;
5087          Hi   : Node_Id;
5088          Loval : Uint;
5089          Hival : Uint;
5090
5091       begin
5092          Lo_Bound := No_Uint;
5093          Hi_Bound := No_Uint;
5094
5095          --  Loop to climb ancestor subtypes and derived types
5096
5097          ST1 := T;
5098          loop
5099             if not Is_Discrete_Type (ST1) then
5100                return;
5101             end if;
5102
5103             Lo := Type_Low_Bound (ST1);
5104             Hi := Type_High_Bound (ST1);
5105
5106             if Compile_Time_Known_Value (Lo) then
5107                Loval := Expr_Value (Lo);
5108
5109                if Lo_Bound = No_Uint or else Lo_Bound < Loval then
5110                   Lo_Bound := Loval;
5111                end if;
5112             end if;
5113
5114             if Compile_Time_Known_Value (Hi) then
5115                Hival := Expr_Value (Hi);
5116
5117                if Hi_Bound = No_Uint or else Hi_Bound > Hival then
5118                   Hi_Bound := Hival;
5119                end if;
5120             end if;
5121
5122             ST2 := Ancestor_Subtype (ST1);
5123
5124             if No (ST2) then
5125                ST2 := Etype (ST1);
5126             end if;
5127
5128             exit when ST1 = ST2;
5129             ST1 := ST2;
5130          end loop;
5131       end Check_Subtype_Bounds;
5132
5133    --  Start of processing for Get_Simple_Init_Val
5134
5135    begin
5136       --  For a private type, we should always have an underlying type
5137       --  (because this was already checked in Needs_Simple_Initialization).
5138       --  What we do is to get the value for the underlying type and then do
5139       --  an Unchecked_Convert to the private type.
5140
5141       if Is_Private_Type (T) then
5142          Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size);
5143
5144          --  A special case, if the underlying value is null, then qualify it
5145          --  with the underlying type, so that the null is properly typed
5146          --  Similarly, if it is an aggregate it must be qualified, because an
5147          --  unchecked conversion does not provide a context for it.
5148
5149          if Nkind (Val) = N_Null
5150            or else Nkind (Val) = N_Aggregate
5151          then
5152             Val :=
5153               Make_Qualified_Expression (Loc,
5154                 Subtype_Mark =>
5155                   New_Occurrence_Of (Underlying_Type (T), Loc),
5156                 Expression => Val);
5157          end if;
5158
5159          Result := Unchecked_Convert_To (T, Val);
5160
5161          --  Don't truncate result (important for Initialize/Normalize_Scalars)
5162
5163          if Nkind (Result) = N_Unchecked_Type_Conversion
5164            and then Is_Scalar_Type (Underlying_Type (T))
5165          then
5166             Set_No_Truncation (Result);
5167          end if;
5168
5169          return Result;
5170
5171       --  For scalars, we must have normalize/initialize scalars case
5172
5173       elsif Is_Scalar_Type (T) then
5174          pragma Assert (Init_Or_Norm_Scalars);
5175
5176          --  Compute size of object. If it is given by the caller, we can use
5177          --  it directly, otherwise we use Esize (T) as an estimate. As far as
5178          --  we know this covers all cases correctly.
5179
5180          if Size = No_Uint or else Size <= Uint_0 then
5181             Size_To_Use := UI_Max (Uint_1, Esize (T));
5182          else
5183             Size_To_Use := Size;
5184          end if;
5185
5186          --  Maximum size to use is 64 bits, since we will create values
5187          --  of type Unsigned_64 and the range must fit this type.
5188
5189          if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
5190             Size_To_Use := Uint_64;
5191          end if;
5192
5193          --  Check known bounds of subtype
5194
5195          Check_Subtype_Bounds;
5196
5197          --  Processing for Normalize_Scalars case
5198
5199          if Normalize_Scalars then
5200
5201             --  If zero is invalid, it is a convenient value to use that is
5202             --  for sure an appropriate invalid value in all situations.
5203
5204             if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
5205                Val := Make_Integer_Literal (Loc, 0);
5206
5207             --  Cases where all one bits is the appropriate invalid value
5208
5209             --  For modular types, all 1 bits is either invalid or valid. If
5210             --  it is valid, then there is nothing that can be done since there
5211             --  are no invalid values (we ruled out zero already).
5212
5213             --  For signed integer types that have no negative values, either
5214             --  there is room for negative values, or there is not. If there
5215             --  is, then all 1 bits may be interpretecd as minus one, which is
5216             --  certainly invalid. Alternatively it is treated as the largest
5217             --  positive value, in which case the observation for modular types
5218             --  still applies.
5219
5220             --  For float types, all 1-bits is a NaN (not a number), which is
5221             --  certainly an appropriately invalid value.
5222
5223             elsif Is_Unsigned_Type (T)
5224               or else Is_Floating_Point_Type (T)
5225               or else Is_Enumeration_Type (T)
5226             then
5227                Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
5228
5229                --  Resolve as Unsigned_64, because the largest number we
5230                --  can generate is out of range of universal integer.
5231
5232                Analyze_And_Resolve (Val, RTE (RE_Unsigned_64));
5233
5234             --  Case of signed types
5235
5236             else
5237                declare
5238                   Signed_Size : constant Uint :=
5239                                   UI_Min (Uint_63, Size_To_Use - 1);
5240
5241                begin
5242                   --  Normally we like to use the most negative number. The
5243                   --  one exception is when this number is in the known
5244                   --  subtype range and the largest positive number is not in
5245                   --  the known subtype range.
5246
5247                   --  For this exceptional case, use largest positive value
5248
5249                   if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint
5250                     and then Lo_Bound <= (-(2 ** Signed_Size))
5251                     and then Hi_Bound < 2 ** Signed_Size
5252                   then
5253                      Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
5254
5255                      --  Normal case of largest negative value
5256
5257                   else
5258                      Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
5259                   end if;
5260                end;
5261             end if;
5262
5263          --  Here for Initialize_Scalars case
5264
5265          else
5266             --  For float types, use float values from System.Scalar_Values
5267
5268             if Is_Floating_Point_Type (T) then
5269                if Root_Type (T) = Standard_Short_Float then
5270                   Val_RE := RE_IS_Isf;
5271                elsif Root_Type (T) = Standard_Float then
5272                   Val_RE := RE_IS_Ifl;
5273                elsif Root_Type (T) = Standard_Long_Float then
5274                   Val_RE := RE_IS_Ilf;
5275                else pragma Assert (Root_Type (T) = Standard_Long_Long_Float);
5276                   Val_RE := RE_IS_Ill;
5277                end if;
5278
5279             --  If zero is invalid, use zero values from System.Scalar_Values
5280
5281             elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
5282                if Size_To_Use <= 8 then
5283                   Val_RE := RE_IS_Iz1;
5284                elsif Size_To_Use <= 16 then
5285                   Val_RE := RE_IS_Iz2;
5286                elsif Size_To_Use <= 32 then
5287                   Val_RE := RE_IS_Iz4;
5288                else
5289                   Val_RE := RE_IS_Iz8;
5290                end if;
5291
5292             --  For unsigned, use unsigned values from System.Scalar_Values
5293
5294             elsif Is_Unsigned_Type (T) then
5295                if Size_To_Use <= 8 then
5296                   Val_RE := RE_IS_Iu1;
5297                elsif Size_To_Use <= 16 then
5298                   Val_RE := RE_IS_Iu2;
5299                elsif Size_To_Use <= 32 then
5300                   Val_RE := RE_IS_Iu4;
5301                else
5302                   Val_RE := RE_IS_Iu8;
5303                end if;
5304
5305             --  For signed, use signed values from System.Scalar_Values
5306
5307             else
5308                if Size_To_Use <= 8 then
5309                   Val_RE := RE_IS_Is1;
5310                elsif Size_To_Use <= 16 then
5311                   Val_RE := RE_IS_Is2;
5312                elsif Size_To_Use <= 32 then
5313                   Val_RE := RE_IS_Is4;
5314                else
5315                   Val_RE := RE_IS_Is8;
5316                end if;
5317             end if;
5318
5319             Val := New_Occurrence_Of (RTE (Val_RE), Loc);
5320          end if;
5321
5322          --  The final expression is obtained by doing an unchecked conversion
5323          --  of this result to the base type of the required subtype. We use
5324          --  the base type to avoid the unchecked conversion from chopping
5325          --  bits, and then we set Kill_Range_Check to preserve the "bad"
5326          --  value.
5327
5328          Result := Unchecked_Convert_To (Base_Type (T), Val);
5329
5330          --  Ensure result is not truncated, since we want the "bad" bits
5331          --  and also kill range check on result.
5332
5333          if Nkind (Result) = N_Unchecked_Type_Conversion then
5334             Set_No_Truncation (Result);
5335             Set_Kill_Range_Check (Result, True);
5336          end if;
5337
5338          return Result;
5339
5340       --  String or Wide_[Wide]_String (must have Initialize_Scalars set)
5341
5342       elsif Root_Type (T) = Standard_String
5343               or else
5344             Root_Type (T) = Standard_Wide_String
5345               or else
5346             Root_Type (T) = Standard_Wide_Wide_String
5347       then
5348          pragma Assert (Init_Or_Norm_Scalars);
5349
5350          return
5351            Make_Aggregate (Loc,
5352              Component_Associations => New_List (
5353                Make_Component_Association (Loc,
5354                  Choices => New_List (
5355                    Make_Others_Choice (Loc)),
5356                  Expression =>
5357                    Get_Simple_Init_Val
5358                      (Component_Type (T), Loc, Esize (Root_Type (T))))));
5359
5360       --  Access type is initialized to null
5361
5362       elsif Is_Access_Type (T) then
5363          return
5364            Make_Null (Loc);
5365
5366       --  No other possibilities should arise, since we should only be
5367       --  calling Get_Simple_Init_Val if Needs_Simple_Initialization
5368       --  returned True, indicating one of the above cases held.
5369
5370       else
5371          raise Program_Error;
5372       end if;
5373
5374    exception
5375       when RE_Not_Available =>
5376          return Empty;
5377    end Get_Simple_Init_Val;
5378
5379    ------------------------------
5380    -- Has_New_Non_Standard_Rep --
5381    ------------------------------
5382
5383    function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
5384    begin
5385       if not Is_Derived_Type (T) then
5386          return Has_Non_Standard_Rep (T)
5387            or else Has_Non_Standard_Rep (Root_Type (T));
5388
5389       --  If Has_Non_Standard_Rep is not set on the derived type, the
5390       --  representation is fully inherited.
5391
5392       elsif not Has_Non_Standard_Rep (T) then
5393          return False;
5394
5395       else
5396          return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
5397
5398          --  May need a more precise check here: the First_Rep_Item may
5399          --  be a stream attribute, which does not affect the representation
5400          --  of the type ???
5401       end if;
5402    end Has_New_Non_Standard_Rep;
5403
5404    ----------------
5405    -- In_Runtime --
5406    ----------------
5407
5408    function In_Runtime (E : Entity_Id) return Boolean is
5409       S1 : Entity_Id := Scope (E);
5410
5411    begin
5412       while Scope (S1) /= Standard_Standard loop
5413          S1 := Scope (S1);
5414       end loop;
5415
5416       return Chars (S1) = Name_System or else Chars (S1) = Name_Ada;
5417    end In_Runtime;
5418
5419    ------------------
5420    -- Init_Formals --
5421    ------------------
5422
5423    function Init_Formals (Typ : Entity_Id) return List_Id is
5424       Loc     : constant Source_Ptr := Sloc (Typ);
5425       Formals : List_Id;
5426
5427    begin
5428       --  First parameter is always _Init : in out typ. Note that we need
5429       --  this to be in/out because in the case of the task record value,
5430       --  there are default record fields (_Priority, _Size, -Task_Info)
5431       --  that may be referenced in the generated initialization routine.
5432
5433       Formals := New_List (
5434         Make_Parameter_Specification (Loc,
5435           Defining_Identifier =>
5436             Make_Defining_Identifier (Loc, Name_uInit),
5437           In_Present  => True,
5438           Out_Present => True,
5439           Parameter_Type => New_Reference_To (Typ, Loc)));
5440
5441       --  For task record value, or type that contains tasks, add two more
5442       --  formals, _Master : Master_Id and _Chain : in out Activation_Chain
5443       --  We also add these parameters for the task record type case.
5444
5445       if Has_Task (Typ)
5446         or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ))
5447       then
5448          Append_To (Formals,
5449            Make_Parameter_Specification (Loc,
5450              Defining_Identifier =>
5451                Make_Defining_Identifier (Loc, Name_uMaster),
5452              Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc)));
5453
5454          Append_To (Formals,
5455            Make_Parameter_Specification (Loc,
5456              Defining_Identifier =>
5457                Make_Defining_Identifier (Loc, Name_uChain),
5458              In_Present => True,
5459              Out_Present => True,
5460              Parameter_Type =>
5461                New_Reference_To (RTE (RE_Activation_Chain), Loc)));
5462
5463          Append_To (Formals,
5464            Make_Parameter_Specification (Loc,
5465              Defining_Identifier =>
5466                Make_Defining_Identifier (Loc, Name_uTask_Name),
5467              In_Present => True,
5468              Parameter_Type =>
5469                New_Reference_To (Standard_String, Loc)));
5470       end if;
5471
5472       return Formals;
5473
5474    exception
5475       when RE_Not_Available =>
5476          return Empty_List;
5477    end Init_Formals;
5478
5479    ------------------
5480    -- Make_Eq_Case --
5481    ------------------
5482
5483    --  <Make_Eq_if shared components>
5484    --  case X.D1 is
5485    --     when V1 => <Make_Eq_Case> on subcomponents
5486    --     ...
5487    --     when Vn => <Make_Eq_Case> on subcomponents
5488    --  end case;
5489
5490    function Make_Eq_Case
5491      (E     : Entity_Id;
5492       CL    : Node_Id;
5493       Discr : Entity_Id := Empty) return List_Id
5494    is
5495       Loc      : constant Source_Ptr := Sloc (E);
5496       Result   : constant List_Id    := New_List;
5497       Variant  : Node_Id;
5498       Alt_List : List_Id;
5499
5500    begin
5501       Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
5502
5503       if No (Variant_Part (CL)) then
5504          return Result;
5505       end if;
5506
5507       Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
5508
5509       if No (Variant) then
5510          return Result;
5511       end if;
5512
5513       Alt_List := New_List;
5514
5515       while Present (Variant) loop
5516          Append_To (Alt_List,
5517            Make_Case_Statement_Alternative (Loc,
5518              Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
5519              Statements => Make_Eq_Case (E, Component_List (Variant))));
5520
5521          Next_Non_Pragma (Variant);
5522       end loop;
5523
5524       --  If we have an Unchecked_Union, use one of the parameters that
5525       --  captures the discriminants.
5526
5527       if Is_Unchecked_Union (E) then
5528          Append_To (Result,
5529            Make_Case_Statement (Loc,
5530              Expression => New_Reference_To (Discr, Loc),
5531              Alternatives => Alt_List));
5532
5533       else
5534          Append_To (Result,
5535            Make_Case_Statement (Loc,
5536              Expression =>
5537                Make_Selected_Component (Loc,
5538                  Prefix => Make_Identifier (Loc, Name_X),
5539                  Selector_Name => New_Copy (Name (Variant_Part (CL)))),
5540              Alternatives => Alt_List));
5541       end if;
5542
5543       return Result;
5544    end Make_Eq_Case;
5545
5546    ----------------
5547    -- Make_Eq_If --
5548    ----------------
5549
5550    --  Generates:
5551
5552    --    if
5553    --      X.C1 /= Y.C1
5554    --        or else
5555    --      X.C2 /= Y.C2
5556    --        ...
5557    --    then
5558    --       return False;
5559    --    end if;
5560
5561    --  or a null statement if the list L is empty
5562
5563    function Make_Eq_If
5564      (E : Entity_Id;
5565       L : List_Id) return Node_Id
5566    is
5567       Loc        : constant Source_Ptr := Sloc (E);
5568       C          : Node_Id;
5569       Field_Name : Name_Id;
5570       Cond       : Node_Id;
5571
5572    begin
5573       if No (L) then
5574          return Make_Null_Statement (Loc);
5575
5576       else
5577          Cond := Empty;
5578
5579          C := First_Non_Pragma (L);
5580          while Present (C) loop
5581             Field_Name := Chars (Defining_Identifier (C));
5582
5583             --  The tags must not be compared they are not part of the value.
5584             --  Note also that in the following, we use Make_Identifier for
5585             --  the component names. Use of New_Reference_To to identify the
5586             --  components would be incorrect because the wrong entities for
5587             --  discriminants could be picked up in the private type case.
5588
5589             if Field_Name /= Name_uTag then
5590                Evolve_Or_Else (Cond,
5591                  Make_Op_Ne (Loc,
5592                    Left_Opnd =>
5593                      Make_Selected_Component (Loc,
5594                        Prefix        => Make_Identifier (Loc, Name_X),
5595                        Selector_Name =>
5596                          Make_Identifier (Loc, Field_Name)),
5597
5598                    Right_Opnd =>
5599                      Make_Selected_Component (Loc,
5600                        Prefix        => Make_Identifier (Loc, Name_Y),
5601                        Selector_Name =>
5602                          Make_Identifier (Loc, Field_Name))));
5603             end if;
5604
5605             Next_Non_Pragma (C);
5606          end loop;
5607
5608          if No (Cond) then
5609             return Make_Null_Statement (Loc);
5610
5611          else
5612             return
5613               Make_Implicit_If_Statement (E,
5614                 Condition => Cond,
5615                 Then_Statements => New_List (
5616                   Make_Return_Statement (Loc,
5617                     Expression => New_Occurrence_Of (Standard_False, Loc))));
5618          end if;
5619       end if;
5620    end Make_Eq_If;
5621
5622    -------------------------------------
5623    -- Make_Predefined_Primitive_Specs --
5624    -------------------------------------
5625
5626    procedure Make_Predefined_Primitive_Specs
5627      (Tag_Typ     : Entity_Id;
5628       Predef_List : out List_Id;
5629       Renamed_Eq  : out Node_Id)
5630    is
5631       Loc       : constant Source_Ptr := Sloc (Tag_Typ);
5632       Res       : constant List_Id    := New_List;
5633       Prim      : Elmt_Id;
5634       Eq_Needed : Boolean;
5635       Eq_Spec   : Node_Id;
5636       Eq_Name   : Name_Id := Name_Op_Eq;
5637
5638       function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
5639       --  Returns true if Prim is a renaming of an unresolved predefined
5640       --  equality operation.
5641
5642       -------------------------------
5643       -- Is_Predefined_Eq_Renaming --
5644       -------------------------------
5645
5646       function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
5647       begin
5648          return Chars (Prim) /= Name_Op_Eq
5649            and then Present (Alias (Prim))
5650            and then Comes_From_Source (Prim)
5651            and then Is_Intrinsic_Subprogram (Alias (Prim))
5652            and then Chars (Alias (Prim)) = Name_Op_Eq;
5653       end Is_Predefined_Eq_Renaming;
5654
5655    --  Start of processing for Make_Predefined_Primitive_Specs
5656
5657    begin
5658       Renamed_Eq := Empty;
5659
5660       --  Spec of _Size
5661
5662       Append_To (Res, Predef_Spec_Or_Body (Loc,
5663         Tag_Typ => Tag_Typ,
5664         Name    => Name_uSize,
5665         Profile => New_List (
5666           Make_Parameter_Specification (Loc,
5667             Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
5668             Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
5669
5670         Ret_Type => Standard_Long_Long_Integer));
5671
5672       --  Spec of _Alignment
5673
5674       Append_To (Res, Predef_Spec_Or_Body (Loc,
5675         Tag_Typ => Tag_Typ,
5676         Name    => Name_uAlignment,
5677         Profile => New_List (
5678           Make_Parameter_Specification (Loc,
5679             Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
5680             Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
5681
5682         Ret_Type => Standard_Integer));
5683
5684       --  Specs for dispatching stream attributes.
5685
5686       declare
5687          Stream_Op_TSS_Names :
5688            constant array (Integer range <>) of TSS_Name_Type :=
5689              (TSS_Stream_Read,
5690               TSS_Stream_Write,
5691               TSS_Stream_Input,
5692               TSS_Stream_Output);
5693       begin
5694          for Op in Stream_Op_TSS_Names'Range loop
5695             if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
5696                Append_To (Res,
5697                   Predef_Stream_Attr_Spec (Loc, Tag_Typ,
5698                     Stream_Op_TSS_Names (Op)));
5699             end if;
5700          end loop;
5701       end;
5702
5703       --  Spec of "=" if expanded if the type is not limited and if a
5704       --  user defined "=" was not already declared for the non-full
5705       --  view of a private extension
5706
5707       if not Is_Limited_Type (Tag_Typ) then
5708          Eq_Needed := True;
5709
5710          Prim := First_Elmt (Primitive_Operations (Tag_Typ));
5711          while Present (Prim) loop
5712
5713             --  If a primitive is encountered that renames the predefined
5714             --  equality operator before reaching any explicit equality
5715             --  primitive, then we still need to create a predefined
5716             --  equality function, because calls to it can occur via
5717             --  the renaming. A new name is created for the equality
5718             --  to avoid conflicting with any user-defined equality.
5719             --  (Note that this doesn't account for renamings of
5720             --  equality nested within subpackages???)
5721
5722             if Is_Predefined_Eq_Renaming (Node (Prim)) then
5723                Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
5724
5725             elsif Chars (Node (Prim)) = Name_Op_Eq
5726               and then (No (Alias (Node (Prim)))
5727                          or else Nkind (Unit_Declaration_Node (Node (Prim))) =
5728                                             N_Subprogram_Renaming_Declaration)
5729               and then Etype (First_Formal (Node (Prim))) =
5730                          Etype (Next_Formal (First_Formal (Node (Prim))))
5731               and then Base_Type (Etype (Node (Prim))) = Standard_Boolean
5732
5733             then
5734                Eq_Needed := False;
5735                exit;
5736
5737             --  If the parent equality is abstract, the inherited equality is
5738             --  abstract as well, and no body can be created for for it.
5739
5740             elsif Chars (Node (Prim)) = Name_Op_Eq
5741               and then Present (Alias (Node (Prim)))
5742               and then Is_Abstract (Alias (Node (Prim)))
5743             then
5744                Eq_Needed := False;
5745                exit;
5746             end if;
5747
5748             Next_Elmt (Prim);
5749          end loop;
5750
5751          --  If a renaming of predefined equality was found
5752          --  but there was no user-defined equality (so Eq_Needed
5753          --  is still true), then set the name back to Name_Op_Eq.
5754          --  But in the case where a user-defined equality was
5755          --  located after such a renaming, then the predefined
5756          --  equality function is still needed, so Eq_Needed must
5757          --  be set back to True.
5758
5759          if Eq_Name /= Name_Op_Eq then
5760             if Eq_Needed then
5761                Eq_Name := Name_Op_Eq;
5762             else
5763                Eq_Needed := True;
5764             end if;
5765          end if;
5766
5767          if Eq_Needed then
5768             Eq_Spec := Predef_Spec_Or_Body (Loc,
5769               Tag_Typ => Tag_Typ,
5770               Name    => Eq_Name,
5771               Profile => New_List (
5772                 Make_Parameter_Specification (Loc,
5773                   Defining_Identifier =>
5774                     Make_Defining_Identifier (Loc, Name_X),
5775                     Parameter_Type      => New_Reference_To (Tag_Typ, Loc)),
5776                 Make_Parameter_Specification (Loc,
5777                   Defining_Identifier =>
5778                     Make_Defining_Identifier (Loc, Name_Y),
5779                     Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
5780                 Ret_Type => Standard_Boolean);
5781             Append_To (Res, Eq_Spec);
5782
5783             if Eq_Name /= Name_Op_Eq then
5784                Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
5785
5786                Prim := First_Elmt (Primitive_Operations (Tag_Typ));
5787                while Present (Prim) loop
5788
5789                   --  Any renamings of equality that appeared before an
5790                   --  overriding equality must be updated to refer to
5791                   --  the entity for the predefined equality, otherwise
5792                   --  calls via the renaming would get incorrectly
5793                   --  resolved to call the user-defined equality function.
5794
5795                   if Is_Predefined_Eq_Renaming (Node (Prim)) then
5796                      Set_Alias (Node (Prim), Renamed_Eq);
5797
5798                   --  Exit upon encountering a user-defined equality
5799
5800                   elsif Chars (Node (Prim)) = Name_Op_Eq
5801                     and then No (Alias (Node (Prim)))
5802                   then
5803                      exit;
5804                   end if;
5805
5806                   Next_Elmt (Prim);
5807                end loop;
5808             end if;
5809          end if;
5810
5811          --  Spec for dispatching assignment
5812
5813          Append_To (Res, Predef_Spec_Or_Body (Loc,
5814            Tag_Typ => Tag_Typ,
5815            Name    => Name_uAssign,
5816            Profile => New_List (
5817              Make_Parameter_Specification (Loc,
5818                Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
5819                Out_Present         => True,
5820                Parameter_Type      => New_Reference_To (Tag_Typ, Loc)),
5821
5822              Make_Parameter_Specification (Loc,
5823                Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
5824                Parameter_Type      => New_Reference_To (Tag_Typ, Loc)))));
5825       end if;
5826
5827       --  Specs for finalization actions that may be required in case a
5828       --  future extension contain a controlled element. We generate those
5829       --  only for root tagged types where they will get dummy bodies or
5830       --  when the type has controlled components and their body must be
5831       --  generated. It is also impossible to provide those for tagged
5832       --  types defined within s-finimp since it would involve circularity
5833       --  problems
5834
5835       if In_Finalization_Root (Tag_Typ) then
5836          null;
5837
5838       --  We also skip these if finalization is not available
5839
5840       elsif Restriction_Active (No_Finalization) then
5841          null;
5842
5843       elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then
5844          if not Is_Limited_Type (Tag_Typ) then
5845             Append_To (Res,
5846               Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
5847          end if;
5848
5849          Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
5850       end if;
5851
5852       Predef_List := Res;
5853    end Make_Predefined_Primitive_Specs;
5854
5855    ---------------------------------
5856    -- Needs_Simple_Initialization --
5857    ---------------------------------
5858
5859    function Needs_Simple_Initialization (T : Entity_Id) return Boolean is
5860    begin
5861       --  Check for private type, in which case test applies to the
5862       --  underlying type of the private type.
5863
5864       if Is_Private_Type (T) then
5865          declare
5866             RT : constant Entity_Id := Underlying_Type (T);
5867
5868          begin
5869             if Present (RT) then
5870                return Needs_Simple_Initialization (RT);
5871             else
5872                return False;
5873             end if;
5874          end;
5875
5876       --  Cases needing simple initialization are access types, and, if pragma
5877       --  Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
5878       --  types.
5879
5880       elsif Is_Access_Type (T)
5881         or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T)))
5882       then
5883          return True;
5884
5885       --  If Initialize/Normalize_Scalars is in effect, string objects also
5886       --  need initialization, unless they are created in the course of
5887       --  expanding an aggregate (since in the latter case they will be
5888       --  filled with appropriate initializing values before they are used).
5889
5890       elsif Init_Or_Norm_Scalars
5891         and then
5892           (Root_Type (T) = Standard_String
5893              or else Root_Type (T) = Standard_Wide_String
5894              or else Root_Type (T) = Standard_Wide_Wide_String)
5895         and then
5896           (not Is_Itype (T)
5897             or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
5898       then
5899          return True;
5900
5901       else
5902          return False;
5903       end if;
5904    end Needs_Simple_Initialization;
5905
5906    ----------------------
5907    -- Predef_Deep_Spec --
5908    ----------------------
5909
5910    function Predef_Deep_Spec
5911      (Loc      : Source_Ptr;
5912       Tag_Typ  : Entity_Id;
5913       Name     : TSS_Name_Type;
5914       For_Body : Boolean := False) return Node_Id
5915    is
5916       Prof   : List_Id;
5917       Type_B : Entity_Id;
5918
5919    begin
5920       if Name = TSS_Deep_Finalize then
5921          Prof := New_List;
5922          Type_B := Standard_Boolean;
5923
5924       else
5925          Prof := New_List (
5926            Make_Parameter_Specification (Loc,
5927              Defining_Identifier => Make_Defining_Identifier (Loc, Name_L),
5928              In_Present          => True,
5929              Out_Present         => True,
5930              Parameter_Type      =>
5931                New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
5932          Type_B := Standard_Short_Short_Integer;
5933       end if;
5934
5935       Append_To (Prof,
5936            Make_Parameter_Specification (Loc,
5937              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5938              In_Present          => True,
5939              Out_Present         => True,
5940              Parameter_Type      => New_Reference_To (Tag_Typ, Loc)));
5941
5942       Append_To (Prof,
5943            Make_Parameter_Specification (Loc,
5944              Defining_Identifier => Make_Defining_Identifier (Loc, Name_B),
5945              Parameter_Type      => New_Reference_To (Type_B, Loc)));
5946
5947       return Predef_Spec_Or_Body (Loc,
5948         Name     => Make_TSS_Name (Tag_Typ, Name),
5949         Tag_Typ  => Tag_Typ,
5950         Profile  => Prof,
5951         For_Body => For_Body);
5952
5953    exception
5954       when RE_Not_Available =>
5955          return Empty;
5956    end Predef_Deep_Spec;
5957
5958    -------------------------
5959    -- Predef_Spec_Or_Body --
5960    -------------------------
5961
5962    function Predef_Spec_Or_Body
5963      (Loc      : Source_Ptr;
5964       Tag_Typ  : Entity_Id;
5965       Name     : Name_Id;
5966       Profile  : List_Id;
5967       Ret_Type : Entity_Id := Empty;
5968       For_Body : Boolean := False) return Node_Id
5969    is
5970       Id   : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
5971       Spec : Node_Id;
5972
5973    begin
5974       Set_Is_Public (Id, Is_Public (Tag_Typ));
5975
5976       --  The internal flag is set to mark these declarations because
5977       --  they have specific properties. First they are primitives even
5978       --  if they are not defined in the type scope (the freezing point
5979       --  is not necessarily in the same scope), furthermore the
5980       --  predefined equality can be overridden by a user-defined
5981       --  equality, no body will be generated in this case.
5982
5983       Set_Is_Internal (Id);
5984
5985       if not Debug_Generated_Code then
5986          Set_Debug_Info_Off (Id);
5987       end if;
5988
5989       if No (Ret_Type) then
5990          Spec :=
5991            Make_Procedure_Specification (Loc,
5992              Defining_Unit_Name       => Id,
5993              Parameter_Specifications => Profile);
5994       else
5995          Spec :=
5996            Make_Function_Specification (Loc,
5997              Defining_Unit_Name       => Id,
5998              Parameter_Specifications => Profile,
5999              Subtype_Mark             =>
6000                New_Reference_To (Ret_Type, Loc));
6001       end if;
6002
6003       --  If body case, return empty subprogram body. Note that this is
6004       --  ill-formed, because there is not even a null statement, and
6005       --  certainly not a return in the function case. The caller is
6006       --  expected to do surgery on the body to add the appropriate stuff.
6007
6008       if For_Body then
6009          return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
6010
6011       --  For the case of Input/Output attributes applied to an abstract type,
6012       --  generate abstract specifications. These will never be called,
6013       --  but we need the slots allocated in the dispatching table so
6014       --  that typ'Class'Input and typ'Class'Output will work properly.
6015
6016       elsif (Is_TSS (Name, TSS_Stream_Input)
6017               or else
6018              Is_TSS (Name, TSS_Stream_Output))
6019         and then Is_Abstract (Tag_Typ)
6020       then
6021          return Make_Abstract_Subprogram_Declaration (Loc, Spec);
6022
6023       --  Normal spec case, where we return a subprogram declaration
6024
6025       else
6026          return Make_Subprogram_Declaration (Loc, Spec);
6027       end if;
6028    end Predef_Spec_Or_Body;
6029
6030    -----------------------------
6031    -- Predef_Stream_Attr_Spec --
6032    -----------------------------
6033
6034    function Predef_Stream_Attr_Spec
6035      (Loc      : Source_Ptr;
6036       Tag_Typ  : Entity_Id;
6037       Name     : TSS_Name_Type;
6038       For_Body : Boolean := False) return Node_Id
6039    is
6040       Ret_Type : Entity_Id;
6041
6042    begin
6043       if Name = TSS_Stream_Input then
6044          Ret_Type := Tag_Typ;
6045       else
6046          Ret_Type := Empty;
6047       end if;
6048
6049       return Predef_Spec_Or_Body (Loc,
6050         Name     => Make_TSS_Name (Tag_Typ, Name),
6051         Tag_Typ  => Tag_Typ,
6052         Profile  => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
6053         Ret_Type => Ret_Type,
6054         For_Body => For_Body);
6055    end Predef_Stream_Attr_Spec;
6056
6057    ---------------------------------
6058    -- Predefined_Primitive_Bodies --
6059    ---------------------------------
6060
6061    function Predefined_Primitive_Bodies
6062      (Tag_Typ    : Entity_Id;
6063       Renamed_Eq : Node_Id) return List_Id
6064    is
6065       Loc       : constant Source_Ptr := Sloc (Tag_Typ);
6066       Res       : constant List_Id    := New_List;
6067       Decl      : Node_Id;
6068       Prim      : Elmt_Id;
6069       Eq_Needed : Boolean;
6070       Eq_Name   : Name_Id;
6071       Ent       : Entity_Id;
6072
6073    begin
6074       --  See if we have a predefined "=" operator
6075
6076       if Present (Renamed_Eq) then
6077          Eq_Needed := True;
6078          Eq_Name   := Chars (Renamed_Eq);
6079
6080       else
6081          Eq_Needed := False;
6082          Eq_Name   := No_Name;
6083
6084          Prim := First_Elmt (Primitive_Operations (Tag_Typ));
6085          while Present (Prim) loop
6086             if Chars (Node (Prim)) = Name_Op_Eq
6087               and then Is_Internal (Node (Prim))
6088             then
6089                Eq_Needed := True;
6090                Eq_Name := Name_Op_Eq;
6091             end if;
6092
6093             Next_Elmt (Prim);
6094          end loop;
6095       end if;
6096
6097       --  Body of _Alignment
6098
6099       Decl := Predef_Spec_Or_Body (Loc,
6100         Tag_Typ => Tag_Typ,
6101         Name    => Name_uAlignment,
6102         Profile => New_List (
6103           Make_Parameter_Specification (Loc,
6104             Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
6105             Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
6106
6107         Ret_Type => Standard_Integer,
6108         For_Body => True);
6109
6110       Set_Handled_Statement_Sequence (Decl,
6111         Make_Handled_Sequence_Of_Statements (Loc, New_List (
6112           Make_Return_Statement (Loc,
6113             Expression =>
6114               Make_Attribute_Reference (Loc,
6115                 Prefix => Make_Identifier (Loc, Name_X),
6116                 Attribute_Name  => Name_Alignment)))));
6117
6118       Append_To (Res, Decl);
6119
6120       --  Body of _Size
6121
6122       Decl := Predef_Spec_Or_Body (Loc,
6123         Tag_Typ => Tag_Typ,
6124         Name    => Name_uSize,
6125         Profile => New_List (
6126           Make_Parameter_Specification (Loc,
6127             Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
6128             Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
6129
6130         Ret_Type => Standard_Long_Long_Integer,
6131         For_Body => True);
6132
6133       Set_Handled_Statement_Sequence (Decl,
6134         Make_Handled_Sequence_Of_Statements (Loc, New_List (
6135           Make_Return_Statement (Loc,
6136             Expression =>
6137               Make_Attribute_Reference (Loc,
6138                 Prefix => Make_Identifier (Loc, Name_X),
6139                 Attribute_Name  => Name_Size)))));
6140
6141       Append_To (Res, Decl);
6142
6143       --  Bodies for Dispatching stream IO routines. We need these only for
6144       --  non-limited types (in the limited case there is no dispatching).
6145       --  We also skip them if dispatching or finalization are not available.
6146
6147       if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
6148         and then No (TSS (Tag_Typ, TSS_Stream_Read))
6149       then
6150          Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
6151          Append_To (Res, Decl);
6152       end if;
6153
6154       if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
6155         and then No (TSS (Tag_Typ, TSS_Stream_Write))
6156       then
6157          Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
6158          Append_To (Res, Decl);
6159       end if;
6160
6161       --  Skip bodies of _Input and _Output for the abstract case, since
6162       --  the corresponding specs are abstract (see Predef_Spec_Or_Body)
6163
6164       if not Is_Abstract (Tag_Typ) then
6165          if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
6166            and then No (TSS (Tag_Typ, TSS_Stream_Input))
6167          then
6168             Build_Record_Or_Elementary_Input_Function
6169               (Loc, Tag_Typ, Decl, Ent);
6170             Append_To (Res, Decl);
6171          end if;
6172
6173          if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
6174            and then No (TSS (Tag_Typ, TSS_Stream_Output))
6175          then
6176             Build_Record_Or_Elementary_Output_Procedure
6177               (Loc, Tag_Typ, Decl, Ent);
6178             Append_To (Res, Decl);
6179          end if;
6180       end if;
6181
6182       if not Is_Limited_Type (Tag_Typ) then
6183
6184          --  Body for equality
6185
6186          if Eq_Needed then
6187
6188             Decl := Predef_Spec_Or_Body (Loc,
6189               Tag_Typ => Tag_Typ,
6190               Name    => Eq_Name,
6191               Profile => New_List (
6192                 Make_Parameter_Specification (Loc,
6193                   Defining_Identifier =>
6194                     Make_Defining_Identifier (Loc, Name_X),
6195                   Parameter_Type      => New_Reference_To (Tag_Typ, Loc)),
6196
6197                 Make_Parameter_Specification (Loc,
6198                   Defining_Identifier =>
6199                     Make_Defining_Identifier (Loc, Name_Y),
6200                   Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
6201
6202               Ret_Type => Standard_Boolean,
6203               For_Body => True);
6204
6205             declare
6206                Def          : constant Node_Id := Parent (Tag_Typ);
6207                Stmts        : constant List_Id := New_List;
6208                Variant_Case : Boolean := Has_Discriminants (Tag_Typ);
6209                Comps        : Node_Id := Empty;
6210                Typ_Def      : Node_Id := Type_Definition (Def);
6211
6212             begin
6213                if Variant_Case then
6214                   if Nkind (Typ_Def) = N_Derived_Type_Definition then
6215                      Typ_Def := Record_Extension_Part (Typ_Def);
6216                   end if;
6217
6218                   if Present (Typ_Def) then
6219                      Comps := Component_List (Typ_Def);
6220                   end if;
6221
6222                   Variant_Case := Present (Comps)
6223                     and then Present (Variant_Part (Comps));
6224                end if;
6225
6226                if Variant_Case then
6227                   Append_To (Stmts,
6228                     Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def)));
6229                   Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps));
6230                   Append_To (Stmts,
6231                     Make_Return_Statement (Loc,
6232                       Expression => New_Reference_To (Standard_True, Loc)));
6233
6234                else
6235                   Append_To (Stmts,
6236                     Make_Return_Statement (Loc,
6237                       Expression =>
6238                         Expand_Record_Equality (Tag_Typ,
6239                           Typ => Tag_Typ,
6240                           Lhs => Make_Identifier (Loc, Name_X),
6241                           Rhs => Make_Identifier (Loc, Name_Y),
6242                           Bodies => Declarations (Decl))));
6243                end if;
6244
6245                Set_Handled_Statement_Sequence (Decl,
6246                  Make_Handled_Sequence_Of_Statements (Loc, Stmts));
6247             end;
6248             Append_To (Res, Decl);
6249          end if;
6250
6251          --  Body for dispatching assignment
6252
6253          Decl := Predef_Spec_Or_Body (Loc,
6254            Tag_Typ => Tag_Typ,
6255            Name    => Name_uAssign,
6256            Profile => New_List (
6257              Make_Parameter_Specification (Loc,
6258                Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
6259                Out_Present         => True,
6260                Parameter_Type      => New_Reference_To (Tag_Typ, Loc)),
6261
6262              Make_Parameter_Specification (Loc,
6263                Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
6264                Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
6265            For_Body => True);
6266
6267          Set_Handled_Statement_Sequence (Decl,
6268            Make_Handled_Sequence_Of_Statements (Loc, New_List (
6269              Make_Assignment_Statement (Loc,
6270                Name       => Make_Identifier (Loc, Name_X),
6271                Expression => Make_Identifier (Loc, Name_Y)))));
6272
6273          Append_To (Res, Decl);
6274       end if;
6275
6276       --  Generate dummy bodies for finalization actions of types that have
6277       --  no controlled components.
6278
6279       --  Skip this processing if we are in the finalization routine in the
6280       --  runtime itself, otherwise we get hopelessly circularly confused!
6281
6282       if In_Finalization_Root (Tag_Typ) then
6283          null;
6284
6285       --  Skip this if finalization is not available
6286
6287       elsif Restriction_Active (No_Finalization) then
6288          null;
6289
6290       elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ))
6291         and then not Has_Controlled_Component (Tag_Typ)
6292       then
6293          if not Is_Limited_Type (Tag_Typ) then
6294             Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
6295
6296             if Is_Controlled (Tag_Typ) then
6297                Set_Handled_Statement_Sequence (Decl,
6298                  Make_Handled_Sequence_Of_Statements (Loc,
6299                    Make_Adjust_Call (
6300                      Ref          => Make_Identifier (Loc, Name_V),
6301                      Typ          => Tag_Typ,
6302                      Flist_Ref    => Make_Identifier (Loc, Name_L),
6303                      With_Attach  => Make_Identifier (Loc, Name_B))));
6304
6305             else
6306                Set_Handled_Statement_Sequence (Decl,
6307                  Make_Handled_Sequence_Of_Statements (Loc, New_List (
6308                    Make_Null_Statement (Loc))));
6309             end if;
6310
6311             Append_To (Res, Decl);
6312          end if;
6313
6314          Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
6315
6316          if Is_Controlled (Tag_Typ) then
6317             Set_Handled_Statement_Sequence (Decl,
6318               Make_Handled_Sequence_Of_Statements (Loc,
6319                 Make_Final_Call (
6320                   Ref         => Make_Identifier (Loc, Name_V),
6321                   Typ         => Tag_Typ,
6322                   With_Detach => Make_Identifier (Loc, Name_B))));
6323
6324          else
6325             Set_Handled_Statement_Sequence (Decl,
6326               Make_Handled_Sequence_Of_Statements (Loc, New_List (
6327                 Make_Null_Statement (Loc))));
6328          end if;
6329
6330          Append_To (Res, Decl);
6331       end if;
6332
6333       return Res;
6334    end Predefined_Primitive_Bodies;
6335
6336    ---------------------------------
6337    -- Predefined_Primitive_Freeze --
6338    ---------------------------------
6339
6340    function Predefined_Primitive_Freeze
6341      (Tag_Typ : Entity_Id) return List_Id
6342    is
6343       Loc     : constant Source_Ptr := Sloc (Tag_Typ);
6344       Res     : constant List_Id    := New_List;
6345       Prim    : Elmt_Id;
6346       Frnodes : List_Id;
6347
6348    begin
6349       Prim := First_Elmt (Primitive_Operations (Tag_Typ));
6350       while Present (Prim) loop
6351          if Is_Internal (Node (Prim)) then
6352             Frnodes := Freeze_Entity (Node (Prim), Loc);
6353
6354             if Present (Frnodes) then
6355                Append_List_To (Res, Frnodes);
6356             end if;
6357          end if;
6358
6359          Next_Elmt (Prim);
6360       end loop;
6361
6362       return Res;
6363    end Predefined_Primitive_Freeze;
6364
6365    -------------------------
6366    -- Stream_Operation_OK --
6367    -------------------------
6368
6369    function Stream_Operation_OK
6370      (Typ       : Entity_Id;
6371       Operation : TSS_Name_Type) return Boolean
6372    is
6373       Has_Inheritable_Stream_Attribute : Boolean := False;
6374
6375    begin
6376       if Is_Limited_Type (Typ)
6377         and then Is_Tagged_Type (Typ)
6378         and then Is_Derived_Type (Typ)
6379       then
6380          --  Special case of a limited type extension: a default implementation
6381          --  of the stream attributes Read and Write exists if the attribute
6382          --  has been specified for an ancestor type.
6383
6384          Has_Inheritable_Stream_Attribute :=
6385            Present (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
6386       end if;
6387
6388       return
6389         not (Is_Limited_Type (Typ)
6390                and then not Has_Inheritable_Stream_Attribute)
6391           and then RTE_Available (RE_Tag)
6392           and then RTE_Available (RE_Root_Stream_Type)
6393           and then not Restriction_Active (No_Dispatch)
6394           and then not Restriction_Active (No_Streams);
6395    end Stream_Operation_OK;
6396 end Exp_Ch3;