gcc/ada/exp_aggr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ A G G R                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2002 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Expander; use Expander;
  33 with Exp_Util; use Exp_Util;
  34 with Exp_Ch3;  use Exp_Ch3;
  35 with Exp_Ch7;  use Exp_Ch7;
  36 with Freeze;   use Freeze;
  37 with Hostparm; use Hostparm;
  38 with Itypes;   use Itypes;
  39 with Lib;      use Lib;
  40 with Nmake;    use Nmake;
  41 with Nlists;   use Nlists;
  42 with Restrict; use Restrict;
  43 with Rtsfind;  use Rtsfind;
  44 with Ttypes;   use Ttypes;
  45 with Sem;      use Sem;
  46 with Sem_Ch3;  use Sem_Ch3;
  47 with Sem_Eval; use Sem_Eval;
  48 with Sem_Res;  use Sem_Res;
  49 with Sem_Util; use Sem_Util;
  50 with Sinfo;    use Sinfo;
  51 with Snames;   use Snames;
  52 with Stand;    use Stand;
  53 with Tbuild;   use Tbuild;
  54 with Uintp;    use Uintp;
  55
  56 package body Exp_Aggr is
  57
  58    type Case_Bounds is record
  59      Choice_Lo   : Node_Id;
  60      Choice_Hi   : Node_Id;
  61      Choice_Node : Node_Id;
  62    end record;
  63
  64    type Case_Table_Type is array (Nat range <>) of Case_Bounds;
  65    --  Table type used by Check_Case_Choices procedure
  66
  67    procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
  68    --  Sort the Case Table using the Lower Bound of each Choice as the key.
  69    --  A simple insertion sort is used since the number of choices in a case
  70    --  statement of variant part will usually be small and probably in near
  71    --  sorted order.
  72
  73    ------------------------------------------------------
  74    -- Local subprograms for Record Aggregate Expansion --
  75    ------------------------------------------------------
  76
  77    procedure Expand_Record_Aggregate
  78      (N           : Node_Id;
  79       Orig_Tag    : Node_Id := Empty;
  80       Parent_Expr : Node_Id := Empty);
  81    --  This is the top level procedure for record aggregate expansion.
  82    --  Expansion for record aggregates needs expand aggregates for tagged
  83    --  record types. Specifically Expand_Record_Aggregate adds the Tag
  84    --  field in front of the Component_Association list that was created
  85    --  during resolution by Resolve_Record_Aggregate.
  86    --
  87    --    N is the record aggregate node.
  88    --    Orig_Tag is the value of the Tag that has to be provided for this
  89    --      specific aggregate. It carries the tag corresponding to the type
  90    --      of the outermost aggregate during the recursive expansion
  91    --    Parent_Expr is the ancestor part of the original extension
  92    --      aggregate
  93
  94    procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
  95    --  N is an N_Aggregate of a N_Extension_Aggregate. Typ is the type of
  96    --  the aggregate. Transform the given aggregate into a sequence of
  97    --  assignments component per component.
  98
  99    function Build_Record_Aggr_Code
 100      (N      : Node_Id;
 101       Typ    : Entity_Id;
 102       Target : Node_Id;
 103       Flist  : Node_Id   := Empty;
 104       Obj    : Entity_Id := Empty)
 105       return   List_Id;
 106    --  N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type
 107    --  of the aggregate. Target is an expression containing the
 108    --  location on which the component by component assignments will
 109    --  take place. Returns the list of assignments plus all other
 110    --  adjustments needed for tagged and controlled types. Flist is an
 111    --  expression representing the finalization list on which to
 112    --  attach the controlled components if any. Obj is present in the
 113    --  object declaration and dynamic allocation cases, it contains
 114    --  an entity that allows to know if the value being created needs to be
 115    --  attached to the final list in case of pragma finalize_Storage_Only.
 116
 117    procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);
 118    --  If the type of the aggregate is a type extension with renamed discrimi-
 119    --  nants, we must initialize the hidden discriminants of the parent.
 120    --  Otherwise, the target object must not be initialized. The discriminants
 121    --  are initialized by calling the initialization procedure for the type.
 122    --  This is incorrect if the initialization of other components has any
 123    --  side effects. We restrict this call to the case where the parent type
 124    --  has a variant part, because this is the only case where the hidden
 125    --  discriminants are accessed, namely when calling discriminant checking
 126    --  functions of the parent type, and when applying a stream attribute to
 127    --  an object of the derived type.
 128
 129    -----------------------------------------------------
 130    -- Local Subprograms for Array Aggregate Expansion --
 131    -----------------------------------------------------
 132
 133    procedure Convert_To_Positional
 134      (N                    : Node_Id;
 135       Max_Others_Replicate : Nat := 5;
 136       Handle_Bit_Packed    : Boolean := False);
 137    --  If possible, convert named notation to positional notation. This
 138    --  conversion is possible only in some static cases. If the conversion
 139    --  is possible, then N is rewritten with the analyzed converted
 140    --  aggregate. The parameter Max_Others_Replicate controls the maximum
 141    --  number of values corresponding to an others choice that will be
 142    --  converted to positional notation (the default of 5 is the normal
 143    --  limit, and reflects the fact that normally the loop is better than
 144    --  a lot of separate assignments). Note that this limit gets overridden
 145    --  in any case if either of the restrictions No_Elaboration_Code or
 146    --  No_Implicit_Loops is set. The parameter Handle_Bit_Packed is usually
 147    --  set False (since we do not expect the back end to handle bit packed
 148    --  arrays, so the normal case of conversion is pointless), but in the
 149    --  special case of a call from Packed_Array_Aggregate_Handled, we set
 150    --  this parameter to True, since these are cases we handle in there.
 151
 152    procedure Expand_Array_Aggregate (N : Node_Id);
 153    --  This is the top-level routine to perform array aggregate expansion.
 154    --  N is the N_Aggregate node to be expanded.
 155
 156    function Backend_Processing_Possible (N : Node_Id) return Boolean;
 157    --  This function checks if array aggregate N can be processed directly
 158    --  by Gigi. If this is the case True is returned.
 159
 160    function Build_Array_Aggr_Code
 161      (N           : Node_Id;
 162       Index       : Node_Id;
 163       Into        : Node_Id;
 164       Scalar_Comp : Boolean;
 165       Indices     : List_Id := No_List;
 166       Flist       : Node_Id := Empty)
 167       return        List_Id;
 168    --  This recursive routine returns a list of statements containing the
 169    --  loops and assignments that are needed for the expansion of the array
 170    --  aggregate N.
 171    --
 172    --    N is the (sub-)aggregate node to be expanded into code.
 173    --
 174    --    Index is the index node corresponding to the array sub-aggregate N.
 175    --
 176    --    Into is the target expression into which we are copying the aggregate.
 177    --
 178    --    Scalar_Comp is True if the component type of the aggregate is scalar.
 179    --
 180    --    Indices is the current list of expressions used to index the
 181    --    object we are writing into.
 182    --
 183    --    Flist is an expression representing the finalization list on which
 184    --    to attach the controlled components if any.
 185
 186    function Number_Of_Choices (N : Node_Id) return Nat;
 187    --  Returns the number of discrete choices (not including the others choice
 188    --  if present) contained in (sub-)aggregate N.
 189
 190    function Late_Expansion
 191      (N      : Node_Id;
 192       Typ    : Entity_Id;
 193       Target : Node_Id;
 194       Flist  : Node_Id := Empty;
 195       Obj    : Entity_Id := Empty)
 196       return List_Id;
 197    --  N is a nested (record or array) aggregate that has been marked
 198    --  with 'Delay_Expansion'. Typ is the expected type of the
 199    --  aggregate and Target is a (duplicable) expression that will
 200    --  hold the result of the aggregate expansion. Flist is the
 201    --  finalization list to be used to attach controlled
 202    --  components. 'Obj' when non empty, carries the original object
 203    --  being initialized in order to know if it needs to be attached
 204    --  to the previous parameter which may not be the case when
 205    --  Finalize_Storage_Only is set.  Basically this procedure is used
 206    --  to implement top-down expansions of nested aggregates. This is
 207    --  necessary for avoiding temporaries at each level as well as for
 208    --  propagating the right internal finalization list.
 209
 210    function Make_OK_Assignment_Statement
 211      (Sloc       : Source_Ptr;
 212       Name       : Node_Id;
 213       Expression : Node_Id)
 214       return       Node_Id;
 215    --  This is like Make_Assignment_Statement, except that Assignment_OK
 216    --  is set in the left operand. All assignments built by this unit
 217    --  use this routine. This is needed to deal with assignments to
 218    --  initialized constants that are done in place.
 219
 220    function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
 221    --  Given an array aggregate, this function handles the case of a packed
 222    --  array aggregate with all constant values, where the aggregate can be
 223    --  evaluated at compile time. If this is possible, then N is rewritten
 224    --  to be its proper compile time value with all the components properly
 225    --  assembled. The expression is analyzed and resolved and True is
 226    --  returned. If this transformation is not possible, N is unchanged
 227    --  and False is returned
 228
 229    function Safe_Slice_Assignment (N : Node_Id) return Boolean;
 230    --  If a slice assignment has an aggregate with a single others_choice,
 231    --  the assignment can be done in place even if bounds are not static,
 232    --  by converting it into a loop over the discrete range of the slice.
 233
 234    ---------------------------------
 235    -- Backend_Processing_Possible --
 236    ---------------------------------
 237
 238    --  Backend processing by Gigi/gcc is possible only if all the following
 239    --  conditions are met:
 240
 241    --    1. N is fully positional
 242
 243    --    2. N is not a bit-packed array aggregate;
 244
 245    --    3. The size of N's array type must be known at compile time. Note
 246    --       that this implies that the component size is also known
 247
 248    --    4. The array type of N does not follow the Fortran layout convention
 249    --       or if it does it must be 1 dimensional.
 250
 251    --    5. The array component type is tagged, which may necessitate
 252    --       reassignment of proper tags.
 253
 254    function Backend_Processing_Possible (N : Node_Id) return Boolean is
 255       Typ : constant Entity_Id := Etype (N);
 256       --  Typ is the correct constrained array subtype of the aggregate.
 257
 258       function Static_Check (N : Node_Id; Index : Node_Id) return Boolean;
 259       --  Recursively checks that N is fully positional, returns true if so.
 260
 261       ------------------
 262       -- Static_Check --
 263       ------------------
 264
 265       function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is
 266          Expr : Node_Id;
 267
 268       begin
 269          --  Check for component associations
 270
 271          if Present (Component_Associations (N)) then
 272             return False;
 273          end if;
 274
 275          --  Recurse to check subaggregates, which may appear in qualified
 276          --  expressions. If delayed, the front-end will have to expand.
 277
 278          Expr := First (Expressions (N));
 279
 280          while Present (Expr) loop
 281
 282             if Is_Delayed_Aggregate (Expr) then
 283                return False;
 284             end if;
 285
 286             if Present (Next_Index (Index))
 287                and then not Static_Check (Expr, Next_Index (Index))
 288             then
 289                return False;
 290             end if;
 291
 292             Next (Expr);
 293          end loop;
 294
 295          return True;
 296       end Static_Check;
 297
 298    --  Start of processing for Backend_Processing_Possible
 299
 300    begin
 301       --  Checks 2 (array must not be bit packed)
 302
 303       if Is_Bit_Packed_Array (Typ) then
 304          return False;
 305       end if;
 306
 307       --  Checks 4  (array must not be multi-dimensional Fortran case)
 308
 309       if Convention (Typ) = Convention_Fortran
 310         and then Number_Dimensions (Typ) > 1
 311       then
 312          return False;
 313       end if;
 314
 315       --  Checks 3 (size of array must be known at compile time)
 316
 317       if not Size_Known_At_Compile_Time (Typ) then
 318          return False;
 319       end if;
 320
 321       --  Checks 1 (aggregate must be fully positional)
 322
 323       if not Static_Check (N, First_Index (Typ)) then
 324          return False;
 325       end if;
 326
 327       --  Checks 5 (if the component type is tagged, then we may need
 328       --    to do tag adjustments; perhaps this should be refined to
 329       --    check for any component associations that actually
 330       --    need tag adjustment, along the lines of the test that's
 331       --    done in Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
 332       --    for record aggregates with tagged components, but not
 333       --    clear whether it's worthwhile ???; in the case of the
 334       --    JVM, object tags are handled implicitly)
 335
 336       if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then
 337          return False;
 338       end if;
 339
 340       --  Backend processing is possible
 341
 342       Set_Compile_Time_Known_Aggregate (N, True);
 343       Set_Size_Known_At_Compile_Time (Etype (N), True);
 344       return True;
 345    end Backend_Processing_Possible;
 346
 347    ---------------------------
 348    -- Build_Array_Aggr_Code --
 349    ---------------------------
 350
 351    --  The code that we generate from a one dimensional aggregate is
 352
 353    --  1. If the sub-aggregate contains discrete choices we
 354
 355    --     (a) Sort the discrete choices
 356
 357    --     (b) Otherwise for each discrete choice that specifies a range we
 358    --         emit a loop. If a range specifies a maximum of three values, or
 359    --         we are dealing with an expression we emit a sequence of
 360    --         assignments instead of a loop.
 361
 362    --     (c) Generate the remaining loops to cover the others choice if any.
 363
 364    --  2. If the aggregate contains positional elements we
 365
 366    --     (a) translate the positional elements in a series of assignments.
 367
 368    --     (b) Generate a final loop to cover the others choice if any.
 369    --         Note that this final loop has to be a while loop since the case
 370
 371    --             L : Integer := Integer'Last;
 372    --             H : Integer := Integer'Last;
 373    --             A : array (L .. H) := (1, others =>0);
 374
 375    --         cannot be handled by a for loop. Thus for the following
 376
 377    --             array (L .. H) := (.. positional elements.., others =>E);
 378
 379    --         we always generate something like:
 380
 381    --             J : Index_Type := Index_Of_Last_Positional_Element;
 382    --             while J < H loop
 383    --                J := Index_Base'Succ (J)
 384    --                Tmp (J) := E;
 385    --             end loop;
 386
 387    function Build_Array_Aggr_Code
 388      (N           : Node_Id;
 389       Index       : Node_Id;
 390       Into        : Node_Id;
 391       Scalar_Comp : Boolean;
 392       Indices     : List_Id := No_List;
 393       Flist       : Node_Id := Empty)
 394       return        List_Id
 395    is
 396       Loc          : constant Source_Ptr := Sloc (N);
 397       Index_Base   : constant Entity_Id  := Base_Type (Etype (Index));
 398       Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base);
 399       Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);
 400
 401       function Add (Val : Int; To : Node_Id) return Node_Id;
 402       --  Returns an expression where Val is added to expression To,
 403       --  unless To+Val is provably out of To's base type range.
 404       --  To must be an already analyzed expression.
 405
 406       function Empty_Range (L, H : Node_Id) return Boolean;
 407       --  Returns True if the range defined by L .. H is certainly empty.
 408
 409       function Equal (L, H : Node_Id) return Boolean;
 410       --  Returns True if L = H for sure.
 411
 412       function Index_Base_Name return Node_Id;
 413       --  Returns a new reference to the index type name.
 414
 415       function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
 416       --  Ind must be a side-effect free expression.
 417       --  If the input aggregate N to Build_Loop contains no sub-aggregates,
 418       --  This routine returns the assignment statement
 419       --
 420       --     Into (Indices, Ind) := Expr;
 421       --
 422       --  Otherwise we call Build_Code recursively.
 423
 424       function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
 425       --  Nodes L and H must be side-effect free expressions.
 426       --  If the input aggregate N to Build_Loop contains no sub-aggregates,
 427       --  This routine returns the for loop statement
 428       --
 429       --     for J in Index_Base'(L) .. Index_Base'(H) loop
 430       --        Into (Indices, J) := Expr;
 431       --     end loop;
 432       --
 433       --  Otherwise we call Build_Code recursively.
 434       --  As an optimization if the loop covers 3 or less scalar elements we
 435       --  generate a sequence of assignments.
 436
 437       function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
 438       --  Nodes L and H must be side-effect free expressions.
 439       --  If the input aggregate N to Build_Loop contains no sub-aggregates,
 440       --  This routine returns the while loop statement
 441       --
 442       --     J : Index_Base := L;
 443       --     while J < H loop
 444       --        J := Index_Base'Succ (J);
 445       --        Into (Indices, J) := Expr;
 446       --     end loop;
 447       --
 448       --  Otherwise we call Build_Code recursively.
 449
 450       function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
 451       function Local_Expr_Value               (E : Node_Id) return Uint;
 452       --  These two Local routines are used to replace the corresponding ones
 453       --  in sem_eval because while processing the bounds of an aggregate with
 454       --  discrete choices whose index type is an enumeration, we build static
 455       --  expressions not recognized by Compile_Time_Known_Value as such since
 456       --  they have not yet been analyzed and resolved. All the expressions in
 457       --  question are things like Index_Base_Name'Val (Const) which we can
 458       --  easily recognize as being constant.
 459
 460       ---------
 461       -- Add --
 462       ---------
 463
 464       function Add (Val : Int; To : Node_Id) return Node_Id is
 465          Expr_Pos : Node_Id;
 466          Expr     : Node_Id;
 467          To_Pos   : Node_Id;
 468
 469          U_To  : Uint;
 470          U_Val : Uint := UI_From_Int (Val);
 471
 472       begin
 473          --  Note: do not try to optimize the case of Val = 0, because
 474          --  we need to build a new node with the proper Sloc value anyway.
 475
 476          --  First test if we can do constant folding
 477
 478          if Local_Compile_Time_Known_Value (To) then
 479             U_To := Local_Expr_Value (To) + Val;
 480
 481             --  Determine if our constant is outside the range of the index.
 482             --  If so return an Empty node. This empty node will be caught
 483             --  by Empty_Range below.
 484
 485             if Compile_Time_Known_Value (Index_Base_L)
 486               and then U_To < Expr_Value (Index_Base_L)
 487             then
 488                return Empty;
 489
 490             elsif Compile_Time_Known_Value (Index_Base_H)
 491               and then U_To > Expr_Value (Index_Base_H)
 492             then
 493                return Empty;
 494             end if;
 495
 496             Expr_Pos := Make_Integer_Literal (Loc, U_To);
 497             Set_Is_Static_Expression (Expr_Pos);
 498
 499             if not Is_Enumeration_Type (Index_Base) then
 500                Expr := Expr_Pos;
 501
 502             --  If we are dealing with enumeration return
 503             --     Index_Base'Val (Expr_Pos)
 504
 505             else
 506                Expr :=
 507                  Make_Attribute_Reference
 508                    (Loc,
 509                     Prefix         => Index_Base_Name,
 510                     Attribute_Name => Name_Val,
 511                     Expressions    => New_List (Expr_Pos));
 512             end if;
 513
 514             return Expr;
 515          end if;
 516
 517          --  If we are here no constant folding possible
 518
 519          if not Is_Enumeration_Type (Index_Base) then
 520             Expr :=
 521               Make_Op_Add (Loc,
 522                            Left_Opnd  => Duplicate_Subexpr (To),
 523                            Right_Opnd => Make_Integer_Literal (Loc, U_Val));
 524
 525          --  If we are dealing with enumeration return
 526          --    Index_Base'Val (Index_Base'Pos (To) + Val)
 527
 528          else
 529             To_Pos :=
 530               Make_Attribute_Reference
 531                 (Loc,
 532                  Prefix         => Index_Base_Name,
 533                  Attribute_Name => Name_Pos,
 534                  Expressions    => New_List (Duplicate_Subexpr (To)));
 535
 536             Expr_Pos :=
 537               Make_Op_Add (Loc,
 538                            Left_Opnd  => To_Pos,
 539                            Right_Opnd => Make_Integer_Literal (Loc, U_Val));
 540
 541             Expr :=
 542               Make_Attribute_Reference
 543                 (Loc,
 544                  Prefix         => Index_Base_Name,
 545                  Attribute_Name => Name_Val,
 546                  Expressions    => New_List (Expr_Pos));
 547          end if;
 548
 549          return Expr;
 550       end Add;
 551
 552       -----------------
 553       -- Empty_Range --
 554       -----------------
 555
 556       function Empty_Range (L, H : Node_Id) return Boolean is
 557          Is_Empty : Boolean := False;
 558          Low      : Node_Id;
 559          High     : Node_Id;
 560
 561       begin
 562          --  First check if L or H were already detected as overflowing the
 563          --  index base range type by function Add above. If this is so Add
 564          --  returns the empty node.
 565
 566          if No (L) or else No (H) then
 567             return True;
 568          end if;
 569
 570          for J in 1 .. 3 loop
 571             case J is
 572
 573                --  L > H    range is empty
 574
 575                when 1 =>
 576                   Low  := L;
 577                   High := H;
 578
 579                --  B_L > H  range must be empty
 580
 581                when 2 =>
 582                   Low  := Index_Base_L;
 583                   High := H;
 584
 585                --  L > B_H  range must be empty
 586
 587                when 3 =>
 588                   Low  := L;
 589                   High := Index_Base_H;
 590             end case;
 591
 592             if Local_Compile_Time_Known_Value (Low)
 593               and then Local_Compile_Time_Known_Value (High)
 594             then
 595                Is_Empty :=
 596                  UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High));
 597             end if;
 598
 599             exit when Is_Empty;
 600          end loop;
 601
 602          return Is_Empty;
 603       end Empty_Range;
 604
 605       -----------
 606       -- Equal --
 607       -----------
 608
 609       function Equal (L, H : Node_Id) return Boolean is
 610       begin
 611          if L = H then
 612             return True;
 613
 614          elsif Local_Compile_Time_Known_Value (L)
 615            and then Local_Compile_Time_Known_Value (H)
 616          then
 617             return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H));
 618          end if;
 619
 620          return False;
 621       end Equal;
 622
 623       ----------------
 624       -- Gen_Assign --
 625       ----------------
 626
 627       function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
 628          L : List_Id := New_List;
 629          F : Entity_Id;
 630          A : Node_Id;
 631
 632          New_Indices  : List_Id;
 633          Indexed_Comp : Node_Id;
 634          Expr_Q       : Node_Id;
 635          Comp_Type    : Entity_Id := Empty;
 636
 637          function Add_Loop_Actions (Lis : List_Id) return List_Id;
 638          --  Collect insert_actions generated in the construction of a
 639          --  loop, and prepend them to the sequence of assignments to
 640          --  complete the eventual body of the loop.
 641
 642          ----------------------
 643          -- Add_Loop_Actions --
 644          ----------------------
 645
 646          function Add_Loop_Actions (Lis : List_Id) return List_Id is
 647             Res : List_Id;
 648
 649          begin
 650             if Nkind (Parent (Expr)) = N_Component_Association
 651               and then Present (Loop_Actions (Parent (Expr)))
 652             then
 653                Append_List (Lis, Loop_Actions (Parent (Expr)));
 654                Res := Loop_Actions (Parent (Expr));
 655                Set_Loop_Actions (Parent (Expr), No_List);
 656                return Res;
 657
 658             else
 659                return Lis;
 660             end if;
 661          end Add_Loop_Actions;
 662
 663       --  Start of processing for Gen_Assign
 664
 665       begin
 666          if No (Indices) then
 667             New_Indices := New_List;
 668          else
 669             New_Indices := New_Copy_List_Tree (Indices);
 670          end if;
 671
 672          Append_To (New_Indices, Ind);
 673
 674          if Present (Flist) then
 675             F := New_Copy_Tree (Flist);
 676
 677          elsif Present (Etype (N)) and then Controlled_Type (Etype (N)) then
 678             if Is_Entity_Name (Into)
 679               and then Present (Scope (Entity (Into)))
 680             then
 681                F := Find_Final_List (Scope (Entity (Into)));
 682
 683             else
 684                F := Find_Final_List (Current_Scope);
 685             end if;
 686          else
 687             F := 0;
 688          end if;
 689
 690          if Present (Next_Index (Index)) then
 691             return
 692               Add_Loop_Actions (
 693                 Build_Array_Aggr_Code
 694                   (Expr, Next_Index (Index),
 695                     Into, Scalar_Comp, New_Indices, F));
 696          end if;
 697
 698          --  If we get here then we are at a bottom-level (sub-)aggregate
 699
 700          Indexed_Comp :=  Checks_Off (
 701              Make_Indexed_Component (Loc,
 702                Prefix      => New_Copy_Tree (Into),
 703                Expressions => New_Indices));
 704
 705          Set_Assignment_OK (Indexed_Comp);
 706
 707          if Nkind (Expr) = N_Qualified_Expression then
 708             Expr_Q := Expression (Expr);
 709          else
 710             Expr_Q := Expr;
 711          end if;
 712
 713          if Present (Etype (N))
 714            and then Etype (N) /= Any_Composite
 715          then
 716             Comp_Type := Component_Type (Etype (N));
 717
 718          elsif Present (Next (First (New_Indices))) then
 719
 720             --  this is a multidimensional array. Recover the component
 721             --  type from the outermost aggregate, because subaggregates
 722             --  do not have an assigned type.
 723
 724             declare
 725                P : Node_Id := Parent (Expr);
 726
 727             begin
 728                while Present (P) loop
 729
 730                   if Nkind (P) = N_Aggregate
 731                     and then Present (Etype (P))
 732                   then
 733                      Comp_Type := Component_Type (Etype (P));
 734                      exit;
 735
 736                   else
 737                      P := Parent (P);
 738                   end if;
 739                end loop;
 740             end;
 741          end if;
 742
 743          if (Nkind (Expr_Q) = N_Aggregate
 744            or else Nkind (Expr_Q) = N_Extension_Aggregate)
 745          then
 746
 747             --  At this stage the Expression may not have been
 748             --  analyzed yet because the array aggregate code has not
 749             --  been updated to use the Expansion_Delayed flag and
 750             --  avoid analysis altogether to solve the same problem
 751             --  (see Resolve_Aggr_Expr) so let's do the analysis of
 752             --  non-array aggregates now in order to get the value of
 753             --  Expansion_Delayed flag for the inner aggregate ???
 754
 755             if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then
 756                Analyze_And_Resolve (Expr_Q, Comp_Type);
 757             end if;
 758
 759             if Is_Delayed_Aggregate (Expr_Q) then
 760                return
 761                  Add_Loop_Actions (
 762                    Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp, F));
 763             end if;
 764          end if;
 765
 766          --  Now generate the assignment with no associated controlled
 767          --  actions since the target of the assignment may not have
 768          --  been initialized, it is not possible to Finalize it as
 769          --  expected by normal controlled assignment. The rest of the
 770          --  controlled actions are done manually with the proper
 771          --  finalization list coming from the context.
 772
 773          A :=
 774            Make_OK_Assignment_Statement (Loc,
 775              Name       => Indexed_Comp,
 776              Expression => New_Copy_Tree (Expr));
 777
 778          if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
 779             Set_No_Ctrl_Actions (A);
 780          end if;
 781
 782          Append_To (L, A);
 783
 784          --  Adjust the tag if tagged (because of possible view
 785          --  conversions), unless compiling for the Java VM
 786          --  where tags are implicit.
 787
 788          if Present (Comp_Type)
 789            and then Is_Tagged_Type (Comp_Type)
 790            and then not Java_VM
 791          then
 792             A :=
 793               Make_OK_Assignment_Statement (Loc,
 794                 Name =>
 795                   Make_Selected_Component (Loc,
 796                     Prefix =>  New_Copy_Tree (Indexed_Comp),
 797                     Selector_Name =>
 798                       New_Reference_To (Tag_Component (Comp_Type), Loc)),
 799
 800                 Expression =>
 801                   Unchecked_Convert_To (RTE (RE_Tag),
 802                     New_Reference_To (
 803                       Access_Disp_Table (Comp_Type), Loc)));
 804
 805             Append_To (L, A);
 806          end if;
 807
 808          --  Adjust and Attach the component to the proper final list
 809          --  which can be the controller of the outer record object or
 810          --  the final list associated with the scope
 811
 812          if Present (Comp_Type)  and then Controlled_Type (Comp_Type) then
 813             Append_List_To (L,
 814               Make_Adjust_Call (
 815                 Ref         => New_Copy_Tree (Indexed_Comp),
 816                 Typ         => Comp_Type,
 817                 Flist_Ref   => F,
 818                 With_Attach => Make_Integer_Literal (Loc, 1)));
 819          end if;
 820
 821          return Add_Loop_Actions (L);
 822       end Gen_Assign;
 823
 824       --------------
 825       -- Gen_Loop --
 826       --------------
 827
 828       function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
 829          L_J : Node_Id;
 830
 831          L_Range : Node_Id;
 832          --  Index_Base'(L) .. Index_Base'(H)
 833
 834          L_Iteration_Scheme : Node_Id;
 835          --  L_J in Index_Base'(L) .. Index_Base'(H)
 836
 837          L_Body : List_Id;
 838          --  The statements to execute in the loop
 839
 840          S : List_Id := New_List;
 841          --  list of statement
 842
 843          Tcopy : Node_Id;
 844          --  Copy of expression tree, used for checking purposes
 845
 846       begin
 847          --  If loop bounds define an empty range return the null statement
 848
 849          if Empty_Range (L, H) then
 850             Append_To (S, Make_Null_Statement (Loc));
 851
 852             --  The expression must be type-checked even though no component
 853             --  of the aggregate will have this value. This is done only for
 854             --  actual components of the array, not for subaggregates. Do the
 855             --  check on a copy, because the expression may be shared among
 856             --  several choices, some of which might be non-null.
 857
 858             if Present (Etype (N))
 859               and then Is_Array_Type (Etype (N))
 860               and then No (Next_Index (Index))
 861             then
 862                Expander_Mode_Save_And_Set (False);
 863                Tcopy := New_Copy_Tree (Expr);
 864                Set_Parent (Tcopy, N);
 865                Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
 866                Expander_Mode_Restore;
 867             end if;
 868
 869             return S;
 870
 871          --  If loop bounds are the same then generate an assignment
 872
 873          elsif Equal (L, H) then
 874             return Gen_Assign (New_Copy_Tree (L), Expr);
 875
 876          --  If H - L <= 2 then generate a sequence of assignments
 877          --  when we are processing the bottom most aggregate and it contains
 878          --  scalar components.
 879
 880          elsif No (Next_Index (Index))
 881            and then Scalar_Comp
 882            and then Local_Compile_Time_Known_Value (L)
 883            and then Local_Compile_Time_Known_Value (H)
 884            and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
 885          then
 886             Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
 887             Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
 888
 889             if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then
 890                Append_List_To (S, Gen_Assign (Add (2, To => L), Expr));
 891             end if;
 892
 893             return S;
 894          end if;
 895
 896          --  Otherwise construct the loop, starting with the loop index L_J
 897
 898          L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
 899
 900          --  Construct "L .. H"
 901
 902          L_Range :=
 903            Make_Range
 904              (Loc,
 905               Low_Bound  => Make_Qualified_Expression
 906                               (Loc,
 907                                Subtype_Mark => Index_Base_Name,
 908                                Expression   => L),
 909               High_Bound => Make_Qualified_Expression
 910                               (Loc,
 911                                Subtype_Mark => Index_Base_Name,
 912                                Expression => H));
 913
 914          --  Construct "for L_J in Index_Base range L .. H"
 915
 916          L_Iteration_Scheme :=
 917            Make_Iteration_Scheme
 918              (Loc,
 919               Loop_Parameter_Specification =>
 920                 Make_Loop_Parameter_Specification
 921                   (Loc,
 922                    Defining_Identifier         => L_J,
 923                    Discrete_Subtype_Definition => L_Range));
 924
 925          --  Construct the statements to execute in the loop body
 926
 927          L_Body := Gen_Assign (New_Reference_To (L_J, Loc), Expr);
 928
 929          --  Construct the final loop
 930
 931          Append_To (S, Make_Implicit_Loop_Statement
 932                          (Node             => N,
 933                           Identifier       => Empty,
 934                           Iteration_Scheme => L_Iteration_Scheme,
 935                           Statements       => L_Body));
 936
 937          return S;
 938       end Gen_Loop;
 939
 940       ---------------
 941       -- Gen_While --
 942       ---------------
 943
 944       --  The code built is
 945
 946       --     W_J : Index_Base := L;
 947       --     while W_J < H loop
 948       --        W_J := Index_Base'Succ (W);
 949       --        L_Body;
 950       --     end loop;
 951
 952       function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is
 953
 954          W_J : Node_Id;
 955
 956          W_Decl : Node_Id;
 957          --  W_J : Base_Type := L;
 958
 959          W_Iteration_Scheme : Node_Id;
 960          --  while W_J < H
 961
 962          W_Index_Succ : Node_Id;
 963          --  Index_Base'Succ (J)
 964
 965          W_Increment  : Node_Id;
 966          --  W_J := Index_Base'Succ (W)
 967
 968          W_Body : List_Id := New_List;
 969          --  The statements to execute in the loop
 970
 971          S : List_Id := New_List;
 972          --  list of statement
 973
 974       begin
 975          --  If loop bounds define an empty range or are equal return null
 976
 977          if Empty_Range (L, H) or else Equal (L, H) then
 978             Append_To (S, Make_Null_Statement (Loc));
 979             return S;
 980          end if;
 981
 982          --  Build the decl of W_J
 983
 984          W_J    := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
 985          W_Decl :=
 986            Make_Object_Declaration
 987              (Loc,
 988               Defining_Identifier => W_J,
 989               Object_Definition   => Index_Base_Name,
 990               Expression          => L);
 991
 992          --  Theoretically we should do a New_Copy_Tree (L) here, but we know
 993          --  that in this particular case L is a fresh Expr generated by
 994          --  Add which we are the only ones to use.
 995
 996          Append_To (S, W_Decl);
 997
 998          --  construct " while W_J < H"
 999
1000          W_Iteration_Scheme :=
1001            Make_Iteration_Scheme
1002              (Loc,
1003               Condition => Make_Op_Lt
1004                              (Loc,
1005                               Left_Opnd  => New_Reference_To (W_J, Loc),
1006                               Right_Opnd => New_Copy_Tree (H)));
1007
1008          --  Construct the statements to execute in the loop body
1009
1010          W_Index_Succ :=
1011            Make_Attribute_Reference
1012              (Loc,
1013               Prefix         => Index_Base_Name,
1014               Attribute_Name => Name_Succ,
1015               Expressions    => New_List (New_Reference_To (W_J, Loc)));
1016
1017          W_Increment  :=
1018            Make_OK_Assignment_Statement
1019              (Loc,
1020               Name       => New_Reference_To (W_J, Loc),
1021               Expression => W_Index_Succ);
1022
1023          Append_To (W_Body, W_Increment);
1024          Append_List_To (W_Body,
1025            Gen_Assign (New_Reference_To (W_J, Loc), Expr));
1026
1027          --  Construct the final loop
1028
1029          Append_To (S, Make_Implicit_Loop_Statement
1030                          (Node             => N,
1031                           Identifier       => Empty,
1032                           Iteration_Scheme => W_Iteration_Scheme,
1033                           Statements       => W_Body));
1034
1035          return S;
1036       end Gen_While;
1037
1038       ---------------------
1039       -- Index_Base_Name --
1040       ---------------------
1041
1042       function Index_Base_Name return Node_Id is
1043       begin
1044          return New_Reference_To (Index_Base, Sloc (N));
1045       end Index_Base_Name;
1046
1047       ------------------------------------
1048       -- Local_Compile_Time_Known_Value --
1049       ------------------------------------
1050
1051       function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is
1052       begin
1053          return Compile_Time_Known_Value (E)
1054            or else
1055              (Nkind (E) = N_Attribute_Reference
1056               and then Attribute_Name (E) = Name_Val
1057               and then Compile_Time_Known_Value (First (Expressions (E))));
1058       end Local_Compile_Time_Known_Value;
1059
1060       ----------------------
1061       -- Local_Expr_Value --
1062       ----------------------
1063
1064       function Local_Expr_Value (E : Node_Id) return Uint is
1065       begin
1066          if Compile_Time_Known_Value (E) then
1067             return Expr_Value (E);
1068          else
1069             return Expr_Value (First (Expressions (E)));
1070          end if;
1071       end Local_Expr_Value;
1072
1073       --  Build_Array_Aggr_Code Variables
1074
1075       Assoc  : Node_Id;
1076       Choice : Node_Id;
1077       Expr   : Node_Id;
1078
1079       Others_Expr : Node_Id   := Empty;
1080
1081       Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
1082       Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
1083       --  The aggregate bounds of this specific sub-aggregate. Note that if
1084       --  the code generated by Build_Array_Aggr_Code is executed then these
1085       --  bounds are OK. Otherwise a Constraint_Error would have been raised.
1086
1087       Aggr_Low  : constant Node_Id := Duplicate_Subexpr (Aggr_L);
1088       Aggr_High : constant Node_Id := Duplicate_Subexpr (Aggr_H);
1089       --  After Duplicate_Subexpr these are side-effect free.
1090
1091       Low  : Node_Id;
1092       High : Node_Id;
1093
1094       Nb_Choices : Nat := 0;
1095       Table      : Case_Table_Type (1 .. Number_Of_Choices (N));
1096       --  Used to sort all the different choice values
1097
1098       Nb_Elements : Int;
1099       --  Number of elements in the positional aggregate
1100
1101       New_Code : List_Id := New_List;
1102
1103    --  Start of processing for Build_Array_Aggr_Code
1104
1105    begin
1106       --  STEP 1: Process component associations
1107
1108       if No (Expressions (N)) then
1109
1110          --  STEP 1 (a): Sort the discrete choices
1111
1112          Assoc := First (Component_Associations (N));
1113          while Present (Assoc) loop
1114
1115             Choice := First (Choices (Assoc));
1116             while Present (Choice) loop
1117
1118                if Nkind (Choice) = N_Others_Choice then
1119                   Others_Expr := Expression (Assoc);
1120                   exit;
1121                end if;
1122
1123                Get_Index_Bounds (Choice, Low, High);
1124
1125                Nb_Choices := Nb_Choices + 1;
1126                Table (Nb_Choices) := (Choice_Lo   => Low,
1127                                       Choice_Hi   => High,
1128                                       Choice_Node => Expression (Assoc));
1129
1130                Next (Choice);
1131             end loop;
1132
1133             Next (Assoc);
1134          end loop;
1135
1136          --  If there is more than one set of choices these must be static
1137          --  and we can therefore sort them. Remember that Nb_Choices does not
1138          --  account for an others choice.
1139
1140          if Nb_Choices > 1 then
1141             Sort_Case_Table (Table);
1142          end if;
1143
1144          --  STEP 1 (b):  take care of the whole set of discrete choices.
1145
1146          for J in 1 .. Nb_Choices loop
1147             Low  := Table (J).Choice_Lo;
1148             High := Table (J).Choice_Hi;
1149             Expr := Table (J).Choice_Node;
1150
1151             Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
1152          end loop;
1153
1154          --  STEP 1 (c): generate the remaining loops to cover others choice
1155          --  We don't need to generate loops over empty gaps, but if there is
1156          --  a single empty range we must analyze the expression for semantics
1157
1158          if Present (Others_Expr) then
1159             declare
1160                First : Boolean := True;
1161
1162             begin
1163                for J in 0 .. Nb_Choices loop
1164
1165                   if J = 0 then
1166                      Low := Aggr_Low;
1167                   else
1168                      Low := Add (1, To => Table (J).Choice_Hi);
1169                   end if;
1170
1171                   if J = Nb_Choices then
1172                      High := Aggr_High;
1173                   else
1174                      High := Add (-1, To => Table (J + 1).Choice_Lo);
1175                   end if;
1176
1177                   --  If this is an expansion within an init_proc, make
1178                   --  sure that discriminant references are replaced by
1179                   --  the corresponding discriminal.
1180
1181                   if Inside_Init_Proc then
1182                      if Is_Entity_Name (Low)
1183                        and then Ekind (Entity (Low)) = E_Discriminant
1184                      then
1185                         Set_Entity (Low, Discriminal (Entity (Low)));
1186                      end if;
1187
1188                      if Is_Entity_Name (High)
1189                        and then Ekind (Entity (High)) = E_Discriminant
1190                      then
1191                         Set_Entity (High, Discriminal (Entity (High)));
1192                      end if;
1193                   end if;
1194
1195                   if First
1196                     or else not Empty_Range (Low, High)
1197                   then
1198                      First := False;
1199                      Append_List
1200                        (Gen_Loop (Low, High, Others_Expr), To => New_Code);
1201                   end if;
1202                end loop;
1203             end;
1204          end if;
1205
1206       --  STEP 2: Process positional components
1207
1208       else
1209          --  STEP 2 (a): Generate the assignments for each positional element
1210          --  Note that here we have to use Aggr_L rather than Aggr_Low because
1211          --  Aggr_L is analyzed and Add wants an analyzed expression.
1212
1213          Expr        := First (Expressions (N));
1214          Nb_Elements := -1;
1215
1216          while Present (Expr) loop
1217             Nb_Elements := Nb_Elements + 1;
1218             Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr),
1219                          To => New_Code);
1220             Next (Expr);
1221          end loop;
1222
1223          --  STEP 2 (b): Generate final loop if an others choice is present
1224          --  Here Nb_Elements gives the offset of the last positional element.
1225
1226          if Present (Component_Associations (N)) then
1227             Assoc := Last (Component_Associations (N));
1228             Expr  := Expression (Assoc);
1229
1230             Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1231                                     Aggr_High,
1232                                     Expr),
1233                          To => New_Code);
1234          end if;
1235       end if;
1236
1237       return New_Code;
1238    end Build_Array_Aggr_Code;
1239
1240    ----------------------------
1241    -- Build_Record_Aggr_Code --
1242    ----------------------------
1243
1244    function Build_Record_Aggr_Code
1245      (N      : Node_Id;
1246       Typ    : Entity_Id;
1247       Target : Node_Id;
1248       Flist  : Node_Id   := Empty;
1249       Obj    : Entity_Id := Empty)
1250       return   List_Id
1251    is
1252       Loc     : constant Source_Ptr := Sloc (N);
1253       L       : constant List_Id    := New_List;
1254       Start_L : constant List_Id    := New_List;
1255       N_Typ   : constant Entity_Id  := Etype (N);
1256
1257       Comp      : Node_Id;
1258       Instr     : Node_Id;
1259       Ref       : Node_Id;
1260       F         : Node_Id;
1261       Comp_Type : Entity_Id;
1262       Selector  : Entity_Id;
1263       Comp_Expr : Node_Id;
1264       Comp_Kind : Node_Kind;
1265       Expr_Q    : Node_Id;
1266
1267       Internal_Final_List : Node_Id;
1268
1269       --  If this is an internal aggregate, the External_Final_List is an
1270       --  expression for the controller record of the enclosing type.
1271       --  If the current aggregate has several controlled components, this
1272       --  expression will appear in several calls to attach to the finali-
1273       --  zation list, and it must not be shared.
1274
1275       External_Final_List      : Node_Id;
1276       Ancestor_Is_Expression   : Boolean := False;
1277       Ancestor_Is_Subtype_Mark : Boolean := False;
1278
1279       Init_Typ : Entity_Id := Empty;
1280       Attach   : Node_Id;
1281
1282       function Get_Constraint_Association (T : Entity_Id) return Node_Id;
1283       --  Returns the first discriminant association in the constraint
1284       --  associated with T, if any, otherwise returns Empty.
1285
1286       function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
1287       --  Returns the value that the given discriminant of an ancestor
1288       --  type should receive (in the absence of a conflict with the
1289       --  value provided by an ancestor part of an extension aggregate).
1290
1291       procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id);
1292       --  Check that each of the discriminant values defined by the
1293       --  ancestor part of an extension aggregate match the corresponding
1294       --  values provided by either an association of the aggregate or
1295       --  by the constraint imposed by a parent type (RM95-4.3.2(8)).
1296
1297       function Init_Controller
1298         (Target  : Node_Id;
1299          Typ     : Entity_Id;
1300          F       : Node_Id;
1301          Attach  : Node_Id;
1302          Init_Pr : Boolean)
1303         return List_Id;
1304       --  returns the list of statements necessary to initialize the internal
1305       --  controller of the (possible) ancestor typ into target and attach
1306       --  it to finalization list F. Init_Pr conditions the call to the
1307       --  init_proc since it may already be done due to ancestor initialization
1308
1309       ---------------------------------
1310       -- Ancestor_Discriminant_Value --
1311       ---------------------------------
1312
1313       function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is
1314          Assoc        : Node_Id;
1315          Assoc_Elmt   : Elmt_Id;
1316          Aggr_Comp    : Entity_Id;
1317          Corresp_Disc : Entity_Id;
1318          Current_Typ  : Entity_Id := Base_Type (Typ);
1319          Parent_Typ   : Entity_Id;
1320          Parent_Disc  : Entity_Id;
1321          Save_Assoc   : Node_Id := Empty;
1322
1323       begin
1324          --  First check any discriminant associations to see if
1325          --  any of them provide a value for the discriminant.
1326
1327          if Present (Discriminant_Specifications (Parent (Current_Typ))) then
1328             Assoc := First (Component_Associations (N));
1329             while Present (Assoc) loop
1330                Aggr_Comp := Entity (First (Choices (Assoc)));
1331
1332                if Ekind (Aggr_Comp) = E_Discriminant then
1333                   Save_Assoc := Expression (Assoc);
1334
1335                   Corresp_Disc := Corresponding_Discriminant (Aggr_Comp);
1336                   while Present (Corresp_Disc) loop
1337                      --  If found a corresponding discriminant then return
1338                      --  the value given in the aggregate. (Note: this is
1339                      --  not correct in the presence of side effects. ???)
1340
1341                      if Disc = Corresp_Disc then
1342                         return Duplicate_Subexpr (Expression (Assoc));
1343                      end if;
1344                      Corresp_Disc :=
1345                        Corresponding_Discriminant (Corresp_Disc);
1346                   end loop;
1347                end if;
1348
1349                Next (Assoc);
1350             end loop;
1351          end if;
1352
1353          --  No match found in aggregate, so chain up parent types to find
1354          --  a constraint that defines the value of the discriminant.
1355
1356          Parent_Typ := Etype (Current_Typ);
1357          while Current_Typ /= Parent_Typ loop
1358             if Has_Discriminants (Parent_Typ) then
1359                Parent_Disc := First_Discriminant (Parent_Typ);
1360
1361                --  We either get the association from the subtype indication
1362                --  of the type definition itself, or from the discriminant
1363                --  constraint associated with the type entity (which is
1364                --  preferable, but it's not always present ???)
1365
1366                if Is_Empty_Elmt_List (
1367                  Discriminant_Constraint (Current_Typ))
1368                then
1369                   Assoc := Get_Constraint_Association (Current_Typ);
1370                   Assoc_Elmt := No_Elmt;
1371                else
1372                   Assoc_Elmt :=
1373                     First_Elmt (Discriminant_Constraint (Current_Typ));
1374                   Assoc := Node (Assoc_Elmt);
1375                end if;
1376
1377                --  Traverse the discriminants of the parent type looking
1378                --  for one that corresponds.
1379
1380                while Present (Parent_Disc) and then Present (Assoc) loop
1381                   Corresp_Disc := Parent_Disc;
1382                   while Present (Corresp_Disc)
1383                     and then Disc /= Corresp_Disc
1384                   loop
1385                      Corresp_Disc :=
1386                        Corresponding_Discriminant (Corresp_Disc);
1387                   end loop;
1388
1389                   if Disc = Corresp_Disc then
1390                      if Nkind (Assoc) = N_Discriminant_Association then
1391                         Assoc := Expression (Assoc);
1392                      end if;
1393
1394                      --  If the located association directly denotes
1395                      --  a discriminant, then use the value of a saved
1396                      --  association of the aggregate. This is a kludge
1397                      --  to handle certain cases involving multiple
1398                      --  discriminants mapped to a single discriminant
1399                      --  of a descendant. It's not clear how to locate the
1400                      --  appropriate discriminant value for such cases. ???
1401
1402                      if Is_Entity_Name (Assoc)
1403                        and then Ekind (Entity (Assoc)) = E_Discriminant
1404                      then
1405                         Assoc := Save_Assoc;
1406                      end if;
1407
1408                      return Duplicate_Subexpr (Assoc);
1409                   end if;
1410
1411                   Next_Discriminant (Parent_Disc);
1412
1413                   if No (Assoc_Elmt) then
1414                      Next (Assoc);
1415                   else
1416                      Next_Elmt (Assoc_Elmt);
1417                      if Present (Assoc_Elmt) then
1418                         Assoc := Node (Assoc_Elmt);
1419                      else
1420                         Assoc := Empty;
1421                      end if;
1422                   end if;
1423                end loop;
1424             end if;
1425
1426             Current_Typ := Parent_Typ;
1427             Parent_Typ := Etype (Current_Typ);
1428          end loop;
1429
1430          --  In some cases there's no ancestor value to locate (such as
1431          --  when an ancestor part given by an expression defines the
1432          --  discriminant value).
1433
1434          return Empty;
1435       end Ancestor_Discriminant_Value;
1436
1437       ----------------------------------
1438       -- Check_Ancestor_Discriminants --
1439       ----------------------------------
1440
1441       procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is
1442          Discr      : Entity_Id := First_Discriminant (Base_Type (Anc_Typ));
1443          Disc_Value : Node_Id;
1444          Cond       : Node_Id;
1445
1446       begin
1447          while Present (Discr) loop
1448             Disc_Value := Ancestor_Discriminant_Value (Discr);
1449
1450             if Present (Disc_Value) then
1451                Cond := Make_Op_Ne (Loc,
1452                  Left_Opnd =>
1453                    Make_Selected_Component (Loc,
1454                      Prefix        => New_Copy_Tree (Target),
1455                      Selector_Name => New_Occurrence_Of (Discr, Loc)),
1456                  Right_Opnd => Disc_Value);
1457
1458                Append_To (L,
1459                  Make_Raise_Constraint_Error (Loc,
1460                    Condition => Cond,
1461                    Reason    => CE_Discriminant_Check_Failed));
1462             end if;
1463
1464             Next_Discriminant (Discr);
1465          end loop;
1466       end Check_Ancestor_Discriminants;
1467
1468       --------------------------------
1469       -- Get_Constraint_Association --
1470       --------------------------------
1471
1472       function Get_Constraint_Association (T : Entity_Id) return Node_Id is
1473          Typ_Def : constant Node_Id := Type_Definition (Parent (T));
1474          Indic   : constant Node_Id := Subtype_Indication (Typ_Def);
1475
1476       begin
1477          --  ??? Also need to cover case of a type mark denoting a subtype
1478          --  with constraint.
1479
1480          if Nkind (Indic) = N_Subtype_Indication
1481            and then Present (Constraint (Indic))
1482          then
1483             return First (Constraints (Constraint (Indic)));
1484          end if;
1485
1486          return Empty;
1487       end Get_Constraint_Association;
1488
1489       ---------------------
1490       -- Init_controller --
1491       ---------------------
1492
1493       function Init_Controller
1494         (Target  : Node_Id;
1495          Typ     : Entity_Id;
1496          F       : Node_Id;
1497          Attach  : Node_Id;
1498          Init_Pr : Boolean)
1499         return List_Id
1500       is
1501          Ref : Node_Id;
1502          L   : List_Id := New_List;
1503
1504       begin
1505          --     _init_proc (target._controller);
1506          --     initialize (target._controller);
1507          --     Attach_to_Final_List (target._controller, F);
1508
1509          Ref := Make_Selected_Component (Loc,
1510                   Prefix        => Convert_To (Typ, New_Copy_Tree (Target)),
1511                   Selector_Name => Make_Identifier (Loc, Name_uController));
1512          Set_Assignment_OK (Ref);
1513
1514          if Init_Pr then
1515             Append_List_To (L,
1516               Build_Initialization_Call (Loc,
1517                 Id_Ref       => Ref,
1518                 Typ          => RTE (RE_Record_Controller),
1519                 In_Init_Proc => Within_Init_Proc));
1520          end if;
1521
1522          Append_To (L,
1523            Make_Procedure_Call_Statement (Loc,
1524              Name =>
1525                New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
1526                  Name_Initialize), Loc),
1527              Parameter_Associations => New_List (New_Copy_Tree (Ref))));
1528
1529          Append_To (L,
1530            Make_Attach_Call (
1531              Obj_Ref     => New_Copy_Tree (Ref),
1532              Flist_Ref   => F,
1533              With_Attach => Attach));
1534          return L;
1535       end Init_Controller;
1536
1537    --  Start of processing for Build_Record_Aggr_Code
1538
1539    begin
1540
1541       --  Deal with the ancestor part of extension aggregates
1542       --  or with the discriminants of the root type
1543
1544       if Nkind (N) = N_Extension_Aggregate then
1545          declare
1546             A : constant Node_Id := Ancestor_Part (N);
1547
1548          begin
1549
1550             --  If the ancestor part is a subtype mark "T", we generate
1551             --     _init_proc (T(tmp));  if T is constrained and
1552             --     _init_proc (S(tmp));  where S applies an appropriate
1553             --                           constraint if T is unconstrained
1554
1555             if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
1556
1557                Ancestor_Is_Subtype_Mark := True;
1558
1559                if Is_Constrained (Entity (A)) then
1560                   Init_Typ := Entity (A);
1561
1562                --  For an ancestor part given by an unconstrained type
1563                --  mark, create a subtype constrained by appropriate
1564                --  corresponding discriminant values coming from either
1565                --  associations of the aggregate or a constraint on
1566                --  a parent type. The subtype will be used to generate
1567                --  the correct default value for the ancestor part.
1568
1569                elsif Has_Discriminants (Entity (A)) then
1570                   declare
1571                      Anc_Typ    : Entity_Id := Entity (A);
1572                      Discrim    : Entity_Id := First_Discriminant (Anc_Typ);
1573                      Anc_Constr : List_Id := New_List;
1574                      Disc_Value : Node_Id;
1575                      New_Indic  : Node_Id;
1576                      Subt_Decl  : Node_Id;
1577                   begin
1578                      while Present (Discrim) loop
1579                         Disc_Value := Ancestor_Discriminant_Value (Discrim);
1580                         Append_To (Anc_Constr, Disc_Value);
1581                         Next_Discriminant (Discrim);
1582                      end loop;
1583
1584                      New_Indic :=
1585                        Make_Subtype_Indication (Loc,
1586                          Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc),
1587                          Constraint   =>
1588                            Make_Index_Or_Discriminant_Constraint (Loc,
1589                              Constraints => Anc_Constr));
1590
1591                      Init_Typ := Create_Itype (Ekind (Anc_Typ), N);
1592
1593                      Subt_Decl :=
1594                        Make_Subtype_Declaration (Loc,
1595                          Defining_Identifier => Init_Typ,
1596                          Subtype_Indication  => New_Indic);
1597
1598                      --  Itypes must be analyzed with checks off
1599                      --  Declaration must have a parent for proper
1600                      --  handling of subsidiary actions.
1601
1602                      Set_Parent (Subt_Decl, N);
1603                      Analyze (Subt_Decl, Suppress => All_Checks);
1604                   end;
1605                end if;
1606
1607                Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
1608                Set_Assignment_OK (Ref);
1609
1610                Append_List_To (Start_L,
1611                  Build_Initialization_Call (Loc,
1612                    Id_Ref => Ref,
1613                    Typ    => Init_Typ,
1614                    In_Init_Proc => Within_Init_Proc));
1615
1616                if Is_Constrained (Entity (A))
1617                  and then Has_Discriminants (Entity (A))
1618                then
1619                   Check_Ancestor_Discriminants (Entity (A));
1620                end if;
1621
1622             --  If the ancestor part is an expression "E", we generate
1623             --     T(tmp) := E;
1624
1625             else
1626                Ancestor_Is_Expression := True;
1627                Init_Typ := Etype (A);
1628
1629                --  Assign the tag before doing the assignment to make sure
1630                --  that the dispatching call in the subsequent deep_adjust
1631                --  works properly (unless Java_VM, where tags are implicit).
1632
1633                if not Java_VM then
1634                   Instr :=
1635                     Make_OK_Assignment_Statement (Loc,
1636                       Name =>
1637                         Make_Selected_Component (Loc,
1638                           Prefix => New_Copy_Tree (Target),
1639                           Selector_Name => New_Reference_To (
1640                             Tag_Component (Base_Type (Typ)), Loc)),
1641
1642                       Expression =>
1643                         Unchecked_Convert_To (RTE (RE_Tag),
1644                           New_Reference_To (
1645                             Access_Disp_Table (Base_Type (Typ)), Loc)));
1646
1647                   Set_Assignment_OK (Name (Instr));
1648                   Append_To (L, Instr);
1649                end if;
1650
1651                --  If the ancestor part is an aggregate, force its full
1652                --  expansion, which was delayed.
1653
1654                if Nkind (A) = N_Qualified_Expression
1655                  and then (Nkind (Expression (A)) = N_Aggregate
1656                              or else
1657                            Nkind (Expression (A)) = N_Extension_Aggregate)
1658                then
1659                   Set_Analyzed (A, False);
1660                   Set_Analyzed (Expression (A), False);
1661                end if;
1662
1663                Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
1664                Set_Assignment_OK (Ref);
1665                Append_To (L,
1666                  Make_Unsuppress_Block (Loc,
1667                    Name_Discriminant_Check,
1668                    New_List (
1669                      Make_OK_Assignment_Statement (Loc,
1670                        Name       => Ref,
1671                        Expression => A))));
1672
1673                if Has_Discriminants (Init_Typ) then
1674                   Check_Ancestor_Discriminants (Init_Typ);
1675                end if;
1676             end if;
1677          end;
1678
1679       else
1680          --  Generate the discriminant expressions, component by component.
1681          --  If the base type is an unchecked union, the discriminants are
1682          --  unknown to the back-end and absent from a value of the type, so
1683          --  assignments for them are not emitted.
1684
1685          if Has_Discriminants (Typ)
1686            and then not Is_Unchecked_Union (Base_Type (Typ))
1687          then
1688
1689             --  ??? The discriminants of the object not inherited in the type
1690             --  of the object should be initialized here
1691
1692             null;
1693
1694             --  Generate discriminant init values
1695
1696             declare
1697                Discriminant : Entity_Id;
1698                Discriminant_Value : Node_Id;
1699
1700             begin
1701                Discriminant := First_Girder_Discriminant (Typ);
1702
1703                while Present (Discriminant) loop
1704
1705                   Comp_Expr :=
1706                     Make_Selected_Component (Loc,
1707                       Prefix        => New_Copy_Tree (Target),
1708                       Selector_Name => New_Occurrence_Of (Discriminant, Loc));
1709
1710                   Discriminant_Value :=
1711                     Get_Discriminant_Value (
1712                       Discriminant,
1713                       N_Typ,
1714                       Discriminant_Constraint (N_Typ));
1715
1716                   Instr :=
1717                     Make_OK_Assignment_Statement (Loc,
1718                       Name       => Comp_Expr,
1719                       Expression => New_Copy_Tree (Discriminant_Value));
1720
1721                   Set_No_Ctrl_Actions (Instr);
1722                   Append_To (L, Instr);
1723
1724                   Next_Girder_Discriminant (Discriminant);
1725                end loop;
1726             end;
1727          end if;
1728       end if;
1729
1730       --  Generate the assignments, component by component
1731
1732       --    tmp.comp1 := Expr1_From_Aggr;
1733       --    tmp.comp2 := Expr2_From_Aggr;
1734       --    ....
1735
1736       Comp := First (Component_Associations (N));
1737       while Present (Comp) loop
1738          Selector  := Entity (First (Choices (Comp)));
1739
1740          if Ekind (Selector) /= E_Discriminant
1741            or else Nkind (N) = N_Extension_Aggregate
1742          then
1743             Comp_Type := Etype (Selector);
1744             Comp_Kind := Nkind (Expression (Comp));
1745             Comp_Expr :=
1746               Make_Selected_Component (Loc,
1747                 Prefix        => New_Copy_Tree (Target),
1748                 Selector_Name => New_Occurrence_Of (Selector, Loc));
1749
1750             if Nkind (Expression (Comp)) = N_Qualified_Expression then
1751                Expr_Q := Expression (Expression (Comp));
1752             else
1753                Expr_Q := Expression (Comp);
1754             end if;
1755
1756             --  The controller is the one of the parent type defining
1757             --  the component (in case of inherited components).
1758
1759             if Controlled_Type (Comp_Type) then
1760                Internal_Final_List :=
1761                  Make_Selected_Component (Loc,
1762                    Prefix => Convert_To (
1763                      Scope (Original_Record_Component (Selector)),
1764                      New_Copy_Tree (Target)),
1765                    Selector_Name =>
1766                      Make_Identifier (Loc, Name_uController));
1767                Internal_Final_List :=
1768                  Make_Selected_Component (Loc,
1769                    Prefix => Internal_Final_List,
1770                    Selector_Name => Make_Identifier (Loc, Name_F));
1771
1772                --  The internal final list can be part of a constant object
1773
1774                Set_Assignment_OK (Internal_Final_List);
1775             else
1776                Internal_Final_List := Empty;
1777             end if;
1778
1779             if Is_Delayed_Aggregate (Expr_Q) then
1780                Append_List_To (L,
1781                  Late_Expansion (Expr_Q, Comp_Type, Comp_Expr,
1782                    Internal_Final_List));
1783             else
1784                Instr :=
1785                  Make_OK_Assignment_Statement (Loc,
1786                    Name       => Comp_Expr,
1787                    Expression => Expression (Comp));
1788
1789                Set_No_Ctrl_Actions (Instr);
1790                Append_To (L, Instr);
1791
1792                --  Adjust the tag if tagged (because of possible view
1793                --  conversions), unless compiling for the Java VM
1794                --  where tags are implicit.
1795
1796                --    tmp.comp._tag := comp_typ'tag;
1797
1798                if Is_Tagged_Type (Comp_Type) and then not Java_VM then
1799                   Instr :=
1800                     Make_OK_Assignment_Statement (Loc,
1801                       Name =>
1802                         Make_Selected_Component (Loc,
1803                           Prefix =>  New_Copy_Tree (Comp_Expr),
1804                           Selector_Name =>
1805                             New_Reference_To (Tag_Component (Comp_Type), Loc)),
1806
1807                       Expression =>
1808                         Unchecked_Convert_To (RTE (RE_Tag),
1809                           New_Reference_To (
1810                             Access_Disp_Table (Comp_Type), Loc)));
1811
1812                   Append_To (L, Instr);
1813                end if;
1814
1815                --  Adjust and Attach the component to the proper controller
1816                --     Adjust (tmp.comp);
1817                --     Attach_To_Final_List (tmp.comp,
1818                --       comp_typ (tmp)._record_controller.f)
1819
1820                if Controlled_Type (Comp_Type) then
1821                   Append_List_To (L,
1822                     Make_Adjust_Call (
1823                       Ref         => New_Copy_Tree (Comp_Expr),
1824                       Typ         => Comp_Type,
1825                       Flist_Ref   => Internal_Final_List,
1826                       With_Attach => Make_Integer_Literal (Loc, 1)));
1827                end if;
1828             end if;
1829          end if;
1830
1831          Next (Comp);
1832       end loop;
1833
1834       --  If the type is tagged, the tag needs to be initialized (unless
1835       --  compiling for the Java VM where tags are implicit). It is done
1836       --  late in the initialization process because in some cases, we call
1837       --  the init_proc of an ancestor which will not leave out the right tag
1838
1839       if Ancestor_Is_Expression then
1840          null;
1841
1842       elsif Is_Tagged_Type (Typ) and then not Java_VM then
1843          Instr :=
1844            Make_OK_Assignment_Statement (Loc,
1845              Name =>
1846                Make_Selected_Component (Loc,
1847                   Prefix => New_Copy_Tree (Target),
1848                  Selector_Name =>
1849                    New_Reference_To (Tag_Component (Base_Type (Typ)), Loc)),
1850
1851              Expression =>
1852                Unchecked_Convert_To (RTE (RE_Tag),
1853                  New_Reference_To (Access_Disp_Table (Base_Type (Typ)), Loc)));
1854
1855          Append_To (L, Instr);
1856       end if;
1857
1858       --  Now deal with the various controlled type data structure
1859       --  initializations
1860
1861       if Present (Obj)
1862         and then Finalize_Storage_Only (Typ)
1863         and then (Is_Library_Level_Entity (Obj)
1864         or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
1865                   = Standard_True)
1866       then
1867          Attach := Make_Integer_Literal (Loc, 0);
1868
1869       elsif Nkind (Parent (N)) = N_Qualified_Expression
1870         and then Nkind (Parent (Parent (N))) = N_Allocator
1871       then
1872          Attach := Make_Integer_Literal (Loc, 2);
1873
1874       else
1875          Attach := Make_Integer_Literal (Loc, 1);
1876       end if;
1877
1878       --  Determine the external finalization list. It is either the
1879       --  finalization list of the outer-scope or the one coming from
1880       --  an outer aggregate.  When the target is not a temporary, the
1881       --  proper scope is the scope of the target rather than the
1882       --  potentially transient current scope.
1883
1884       if Controlled_Type (Typ) then
1885          if Present (Flist) then
1886             External_Final_List := New_Copy_Tree (Flist);
1887
1888          elsif Is_Entity_Name (Target)
1889            and then Present (Scope (Entity (Target)))
1890          then
1891             External_Final_List := Find_Final_List (Scope (Entity (Target)));
1892
1893          else
1894             External_Final_List := Find_Final_List (Current_Scope);
1895          end if;
1896
1897       else
1898          External_Final_List := Empty;
1899       end if;
1900
1901       --  initialize and attach the outer object in the is_controlled
1902       --  case
1903
1904       if Is_Controlled (Typ) then
1905          if Ancestor_Is_Subtype_Mark then
1906             Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
1907             Set_Assignment_OK (Ref);
1908             Append_To (L,
1909               Make_Procedure_Call_Statement (Loc,
1910                 Name => New_Reference_To (
1911                   Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
1912                 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
1913          end if;
1914
1915          --  ??? when the ancestor part is an expression, the global
1916          --  object is already attached at the wrong level. It should
1917          --  be detached and re-attached. We have a design problem here.
1918
1919          if Ancestor_Is_Expression
1920            and then Has_Controlled_Component (Init_Typ)
1921          then
1922             null;
1923
1924          elsif Has_Controlled_Component (Typ) then
1925             F := Make_Selected_Component (Loc,
1926                    Prefix        => New_Copy_Tree (Target),
1927                    Selector_Name => Make_Identifier (Loc, Name_uController));
1928             F := Make_Selected_Component (Loc,
1929                    Prefix        => F,
1930                    Selector_Name => Make_Identifier (Loc, Name_F));
1931
1932             Ref := New_Copy_Tree (Target);
1933             Set_Assignment_OK (Ref);
1934
1935             Append_To (L,
1936               Make_Attach_Call (
1937                 Obj_Ref     => Ref,
1938                 Flist_Ref   => F,
1939                 With_Attach => Make_Integer_Literal (Loc, 1)));
1940
1941          else --  is_Controlled (Typ) and not Has_Controlled_Component (Typ)
1942             Ref := New_Copy_Tree (Target);
1943             Set_Assignment_OK (Ref);
1944             Append_To (Start_L,
1945               Make_Attach_Call (
1946                 Obj_Ref     => Ref,
1947                 Flist_Ref   => New_Copy_Tree (External_Final_List),
1948                 With_Attach => Attach));
1949          end if;
1950       end if;
1951
1952       --  in the Has_Controlled component case, all the intermediate
1953       --  controllers must be initialized
1954
1955       if Has_Controlled_Component (Typ) then
1956          declare
1957             Inner_Typ : Entity_Id;
1958             Outer_Typ : Entity_Id;
1959             At_Root   : Boolean;
1960
1961          begin
1962
1963             Outer_Typ := Base_Type (Typ);
1964
1965             --  find outer type with a controller
1966
1967             while Outer_Typ /= Init_Typ
1968               and then not Has_New_Controlled_Component (Outer_Typ)
1969             loop
1970                Outer_Typ := Etype (Outer_Typ);
1971             end loop;
1972
1973             --  attach it to the outer record controller to the
1974             --  external final list
1975
1976             if Outer_Typ = Init_Typ then
1977                Append_List_To (Start_L,
1978                  Init_Controller (
1979                    Target  => Target,
1980                    Typ     => Outer_Typ,
1981                    F       => External_Final_List,
1982                    Attach  => Attach,
1983                    Init_Pr => Ancestor_Is_Expression));
1984                At_Root := True;
1985                Inner_Typ := Init_Typ;
1986
1987             else
1988                Append_List_To (Start_L,
1989                  Init_Controller (
1990                    Target  => Target,
1991                    Typ     => Outer_Typ,
1992                    F       => External_Final_List,
1993                    Attach  => Attach,
1994                    Init_Pr => True));
1995
1996                Inner_Typ := Etype (Outer_Typ);
1997                At_Root   :=
1998                  not Is_Tagged_Type (Typ) or else Inner_Typ = Outer_Typ;
1999             end if;
2000
2001             --  Initialize the internal controllers for tagged types with
2002             --  more than one controller.
2003
2004             while not At_Root and then Inner_Typ /= Init_Typ loop
2005                if Has_New_Controlled_Component (Inner_Typ) then
2006                   F :=
2007                     Make_Selected_Component (Loc,
2008                       Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
2009                       Selector_Name =>
2010                         Make_Identifier (Loc, Name_uController));
2011                   F := Make_Selected_Component (Loc,
2012                          Prefix => F,
2013                          Selector_Name => Make_Identifier (Loc, Name_F));
2014                   Append_List_To (Start_L,
2015                     Init_Controller (
2016                       Target  => Target,
2017                       Typ     => Inner_Typ,
2018                       F       => F,
2019                       Attach  => Make_Integer_Literal (Loc, 1),
2020                       Init_Pr => True));
2021                   Outer_Typ := Inner_Typ;
2022                end if;
2023
2024                --  Stop at the root
2025
2026                At_Root := Inner_Typ = Etype (Inner_Typ);
2027                Inner_Typ := Etype (Inner_Typ);
2028             end loop;
2029
2030             --  if not done yet attach the controller of the ancestor part
2031
2032             if Outer_Typ /= Init_Typ
2033               and then Inner_Typ = Init_Typ
2034               and then Has_Controlled_Component (Init_Typ)
2035             then
2036                F :=
2037                   Make_Selected_Component (Loc,
2038                     Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
2039                     Selector_Name => Make_Identifier (Loc, Name_uController));
2040                F := Make_Selected_Component (Loc,
2041                        Prefix => F,
2042                        Selector_Name => Make_Identifier (Loc, Name_F));
2043
2044                Attach := Make_Integer_Literal (Loc, 1);
2045                Append_List_To (Start_L,
2046                  Init_Controller (
2047                    Target  => Target,
2048                    Typ     => Init_Typ,
2049                    F       => F,
2050                    Attach  => Attach,
2051                    Init_Pr => Ancestor_Is_Expression));
2052             end if;
2053          end;
2054       end if;
2055
2056       Append_List_To (Start_L, L);
2057       return Start_L;
2058    end Build_Record_Aggr_Code;
2059
2060    -------------------------------
2061    -- Convert_Aggr_In_Allocator --
2062    -------------------------------
2063
2064    procedure Convert_Aggr_In_Allocator (Decl, Aggr : Node_Id) is
2065       Loc  : constant Source_Ptr := Sloc (Aggr);
2066       Typ  : constant Entity_Id  := Etype (Aggr);
2067       Temp : constant Entity_Id  := Defining_Identifier (Decl);
2068       Occ  : constant Node_Id    := Unchecked_Convert_To (Typ,
2069         Make_Explicit_Dereference (Loc, New_Reference_To (Temp, Loc)));
2070
2071       Access_Type : constant Entity_Id := Etype (Temp);
2072
2073    begin
2074       Insert_Actions_After (Decl,
2075         Late_Expansion (Aggr, Typ, Occ,
2076           Find_Final_List (Access_Type),
2077           Associated_Final_Chain (Base_Type (Access_Type))));
2078    end Convert_Aggr_In_Allocator;
2079
2080    --------------------------------
2081    -- Convert_Aggr_In_Assignment --
2082    --------------------------------
2083
2084    procedure Convert_Aggr_In_Assignment (N : Node_Id) is
2085       Aggr :          Node_Id    := Expression (N);
2086       Typ  : constant Entity_Id  := Etype (Aggr);
2087       Occ  : constant Node_Id    := New_Copy_Tree (Name (N));
2088
2089    begin
2090       if Nkind (Aggr) = N_Qualified_Expression then
2091          Aggr := Expression (Aggr);
2092       end if;
2093
2094       Insert_Actions_After (N,
2095         Late_Expansion (Aggr, Typ, Occ,
2096           Find_Final_List (Typ, New_Copy_Tree (Occ))));
2097    end Convert_Aggr_In_Assignment;
2098
2099    ---------------------------------
2100    -- Convert_Aggr_In_Object_Decl --
2101    ---------------------------------
2102
2103    procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is
2104       Obj  : constant Entity_Id  := Defining_Identifier (N);
2105       Aggr :          Node_Id    := Expression (N);
2106       Loc  : constant Source_Ptr := Sloc (Aggr);
2107       Typ  : constant Entity_Id  := Etype (Aggr);
2108       Occ  : constant Node_Id    := New_Occurrence_Of (Obj, Loc);
2109
2110    begin
2111       Set_Assignment_OK (Occ);
2112
2113       if Nkind (Aggr) = N_Qualified_Expression then
2114          Aggr := Expression (Aggr);
2115       end if;
2116
2117       Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj));
2118       Set_No_Initialization (N);
2119       Initialize_Discriminants (N, Typ);
2120    end Convert_Aggr_In_Object_Decl;
2121
2122    ----------------------------
2123    -- Convert_To_Assignments --
2124    ----------------------------
2125
2126    procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
2127       Loc  : constant Source_Ptr := Sloc (N);
2128       Temp : Entity_Id;
2129
2130       Instr         : Node_Id;
2131       Target_Expr   : Node_Id;
2132       Parent_Kind   : Node_Kind;
2133       Unc_Decl      : Boolean := False;
2134       Parent_Node   : Node_Id;
2135
2136    begin
2137
2138       Parent_Node := Parent (N);
2139       Parent_Kind := Nkind (Parent_Node);
2140
2141       if Parent_Kind = N_Qualified_Expression then
2142
2143          --  Check if we are in a unconstrained declaration because in this
2144          --  case the current delayed expansion mechanism doesn't work when
2145          --  the declared object size depend on the initializing expr.
2146
2147          begin
2148             Parent_Node := Parent (Parent_Node);
2149             Parent_Kind := Nkind (Parent_Node);
2150             if Parent_Kind = N_Object_Declaration then
2151                Unc_Decl :=
2152                  not Is_Entity_Name (Object_Definition (Parent_Node))
2153                  or else Has_Discriminants (
2154                    Entity (Object_Definition (Parent_Node)))
2155                  or else Is_Class_Wide_Type (
2156                    Entity (Object_Definition (Parent_Node)));
2157             end if;
2158          end;
2159       end if;
2160
2161       --  Just set the Delay flag in the following cases where the
2162       --  transformation will be done top down from above
2163       --    - internal aggregate (transformed when expanding the parent)
2164       --    - allocators  (see Convert_Aggr_In_Allocator)
2165       --    - object decl (see Convert_Aggr_In_Object_Decl)
2166       --    - safe assignments (see Convert_Aggr_Assignments)
2167       --      so far only the assignments in the init_procs are taken
2168       --      into account
2169
2170       if Parent_Kind = N_Aggregate
2171         or else Parent_Kind = N_Extension_Aggregate
2172         or else Parent_Kind = N_Component_Association
2173         or else Parent_Kind = N_Allocator
2174         or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
2175         or else (Parent_Kind = N_Assignment_Statement
2176                   and then Inside_Init_Proc)
2177       then
2178          Set_Expansion_Delayed (N);
2179          return;
2180       end if;
2181
2182       if Requires_Transient_Scope (Typ) then
2183          Establish_Transient_Scope (N, Sec_Stack =>
2184               Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
2185       end if;
2186
2187       --  Create the temporary
2188
2189       Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
2190
2191       Instr :=
2192         Make_Object_Declaration (Loc,
2193           Defining_Identifier => Temp,
2194           Object_Definition => New_Occurrence_Of (Typ, Loc));
2195
2196       Set_No_Initialization (Instr);
2197       Insert_Action (N, Instr);
2198       Initialize_Discriminants (Instr, Typ);
2199       Target_Expr := New_Occurrence_Of (Temp, Loc);
2200
2201       Insert_Actions (N, Build_Record_Aggr_Code (N, Typ, Target_Expr));
2202       Rewrite (N, New_Occurrence_Of (Temp, Loc));
2203       Analyze_And_Resolve (N, Typ);
2204    end Convert_To_Assignments;
2205
2206    ---------------------------
2207    -- Convert_To_Positional --
2208    ---------------------------
2209
2210    procedure Convert_To_Positional
2211      (N                    : Node_Id;
2212       Max_Others_Replicate : Nat := 5;
2213       Handle_Bit_Packed    : Boolean := False)
2214    is
2215       Loc  : constant Source_Ptr := Sloc (N);
2216       Typ  : constant Entity_Id  := Etype (N);
2217       Ndim : constant Pos        := Number_Dimensions (Typ);
2218       Xtyp : constant Entity_Id  := Etype (First_Index (Typ));
2219       Indx : constant Node_Id    := First_Index (Base_Type (Typ));
2220       Blo  : constant Node_Id    := Type_Low_Bound (Etype (Indx));
2221       Lo   : constant Node_Id    := Type_Low_Bound (Xtyp);
2222       Hi   : constant Node_Id    := Type_High_Bound (Xtyp);
2223       Lov  : Uint;
2224       Hiv  : Uint;
2225
2226       --  The following constant determines the maximum size of an
2227       --  aggregate produced by converting named to positional
2228       --  notation (e.g. from others clauses). This avoids running
2229       --  away with attempts to convert huge aggregates.
2230
2231       --  The normal limit is 5000, but we increase this limit to
2232       --  2**24 (about 16 million) if Restrictions (No_Elaboration_Code)
2233       --  or Restrictions (No_Implicit_Loops) is specified, since in
2234       --  either case, we are at risk of declaring the program illegal
2235       --  because of this limit.
2236
2237       Max_Aggr_Size : constant Nat :=
2238          5000 + (2 ** 24 - 5000) * Boolean'Pos
2239                            (Restrictions (No_Elaboration_Code)
2240                               or else
2241                             Restrictions (No_Implicit_Loops));
2242
2243    begin
2244       --  For now, we only handle the one dimensional case and aggregates
2245       --  that are not part of a component_association
2246
2247       if Ndim > 1 or else Nkind (Parent (N)) = N_Aggregate
2248         or else Nkind (Parent (N)) = N_Component_Association
2249       then
2250          return;
2251       end if;
2252
2253       --  If already positional, nothing to do!
2254
2255       if No (Component_Associations (N)) then
2256          return;
2257       end if;
2258
2259       --  Bounds need to be known at compile time
2260
2261       if not Compile_Time_Known_Value (Lo)
2262         or else not Compile_Time_Known_Value (Hi)
2263       then
2264          return;
2265       end if;
2266
2267       --  Normally we do not attempt to convert bit packed arrays. The
2268       --  exception is when we are explicitly asked to do so (this call
2269       --  is from the Packed_Array_Aggregate_Handled procedure).
2270
2271       if Is_Bit_Packed_Array (Typ)
2272         and then not Handle_Bit_Packed
2273       then
2274          return;
2275       end if;
2276
2277       --  Do not convert to positional if controlled components are
2278       --  involved since these require special processing
2279
2280       if Has_Controlled_Component (Typ) then
2281          return;
2282       end if;
2283
2284       --  Get bounds and check reasonable size (positive, not too large)
2285       --  Also only handle bounds starting at the base type low bound for now
2286       --  since the compiler isn't able to handle different low bounds yet.
2287
2288       Lov := Expr_Value (Lo);
2289       Hiv := Expr_Value (Hi);
2290
2291       if Hiv < Lov
2292         or else (Hiv - Lov > Max_Aggr_Size)
2293         or else not Compile_Time_Known_Value (Blo)
2294         or else (Lov /= Expr_Value (Blo))
2295       then
2296          return;
2297       end if;
2298
2299       --  Bounds must be in integer range (for array Vals below)
2300
2301       if not UI_Is_In_Int_Range (Lov)
2302           or else
2303          not UI_Is_In_Int_Range (Hiv)
2304       then
2305          return;
2306       end if;
2307
2308       --  Determine if set of alternatives is suitable for conversion
2309       --  and build an array containing the values in sequence.
2310
2311       declare
2312          Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv))
2313                   of Node_Id := (others => Empty);
2314          --  The values in the aggregate sorted appropriately
2315
2316          Vlist : List_Id;
2317          --  Same data as Vals in list form
2318
2319          Rep_Count : Nat;
2320          --  Used to validate Max_Others_Replicate limit
2321
2322          Elmt   : Node_Id;
2323          Num    : Int := UI_To_Int (Lov);
2324          Choice : Node_Id;
2325          Lo, Hi : Node_Id;
2326
2327       begin
2328          if Present (Expressions (N)) then
2329             Elmt := First (Expressions (N));
2330             while Present (Elmt) loop
2331                Vals (Num) := Relocate_Node (Elmt);
2332                Num := Num + 1;
2333                Next (Elmt);
2334             end loop;
2335          end if;
2336
2337          Elmt := First (Component_Associations (N));
2338          Component_Loop : while Present (Elmt) loop
2339
2340             Choice := First (Choices (Elmt));
2341             Choice_Loop : while Present (Choice) loop
2342
2343                --  If we have an others choice, fill in the missing elements
2344                --  subject to the limit established by Max_Others_Replicate.
2345
2346                if Nkind (Choice) = N_Others_Choice then
2347                   Rep_Count := 0;
2348
2349                   for J in Vals'Range loop
2350                      if No (Vals (J)) then
2351                         Vals (J) := New_Copy_Tree (Expression (Elmt));
2352                         Rep_Count := Rep_Count + 1;
2353
2354                         --  Check for maximum others replication. Note that
2355                         --  we skip this test if either of the restrictions
2356                         --  No_Elaboration_Code or No_Implicit_Loops is
2357                         --  active, or if this is a preelaborable unit.
2358
2359                         if Rep_Count > Max_Others_Replicate
2360                           and then not Restrictions (No_Elaboration_Code)
2361                           and then not Restrictions (No_Implicit_Loops)
2362                           and then not
2363                             Is_Preelaborated (Cunit_Entity (Current_Sem_Unit))
2364                         then
2365                            return;
2366                         end if;
2367                      end if;
2368                   end loop;
2369
2370                   exit Component_Loop;
2371
2372                --  Case of a subtype mark
2373
2374                elsif (Nkind (Choice) = N_Identifier
2375                        and then Is_Type (Entity (Choice)))
2376                then
2377                   Lo := Type_Low_Bound  (Etype (Choice));
2378                   Hi := Type_High_Bound (Etype (Choice));
2379
2380                --  Case of subtype indication
2381
2382                elsif Nkind (Choice) = N_Subtype_Indication then
2383                   Lo := Low_Bound  (Range_Expression (Constraint (Choice)));
2384                   Hi := High_Bound (Range_Expression (Constraint (Choice)));
2385
2386                --  Case of a range
2387
2388                elsif Nkind (Choice) = N_Range then
2389                   Lo := Low_Bound (Choice);
2390                   Hi := High_Bound (Choice);
2391
2392                --  Normal subexpression case
2393
2394                else pragma Assert (Nkind (Choice) in N_Subexpr);
2395                   if not Compile_Time_Known_Value (Choice) then
2396                      return;
2397
2398                   else
2399                      Vals (UI_To_Int (Expr_Value (Choice))) :=
2400                        New_Copy_Tree (Expression (Elmt));
2401                      goto Continue;
2402                   end if;
2403                end if;
2404
2405                --  Range cases merge with Lo,Hi said
2406
2407                if not Compile_Time_Known_Value (Lo)
2408                     or else
2409                   not Compile_Time_Known_Value (Hi)
2410                then
2411                   return;
2412                else
2413                   for J in UI_To_Int (Expr_Value (Lo)) ..
2414                            UI_To_Int (Expr_Value (Hi))
2415                   loop
2416                      Vals (J) := New_Copy_Tree (Expression (Elmt));
2417                   end loop;
2418                end if;
2419
2420             <<Continue>>
2421                Next (Choice);
2422             end loop Choice_Loop;
2423
2424             Next (Elmt);
2425          end loop Component_Loop;
2426
2427          --  If we get here the conversion is possible
2428
2429          Vlist := New_List;
2430          for J in Vals'Range loop
2431             Append (Vals (J), Vlist);
2432          end loop;
2433
2434          Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist));
2435          Analyze_And_Resolve (N, Typ);
2436       end;
2437    end Convert_To_Positional;
2438
2439    ----------------------------
2440    -- Expand_Array_Aggregate --
2441    ----------------------------
2442
2443    --  Array aggregate expansion proceeds as follows:
2444
2445    --  1. If requested we generate code to perform all the array aggregate
2446    --     bound checks, specifically
2447
2448    --         (a) Check that the index range defined by aggregate bounds is
2449    --             compatible with corresponding index subtype.
2450
2451    --         (b) If an others choice is present check that no aggregate
2452    --             index is outside the bounds of the index constraint.
2453
2454    --         (c) For multidimensional arrays make sure that all subaggregates
2455    --             corresponding to the same dimension have the same bounds.
2456
2457    --  2. Check if the aggregate can be statically processed. If this is the
2458    --     case pass it as is to Gigi. Note that a necessary condition for
2459    --     static processing is that the aggregate be fully positional.
2460
2461    --  3. If in place aggregate expansion is possible (i.e. no need to create
2462    --     a temporary) then mark the aggregate as such and return. Otherwise
2463    --     create a new temporary and generate the appropriate initialization
2464    --     code.
2465
2466    procedure Expand_Array_Aggregate (N : Node_Id) is
2467       Loc : constant Source_Ptr := Sloc (N);
2468
2469       Typ  : constant Entity_Id := Etype (N);
2470       Ctyp : constant Entity_Id := Component_Type (Typ);
2471       --  Typ is the correct constrained array subtype of the aggregate
2472       --  Ctyp is the corresponding component type.
2473
2474       Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
2475       --  Number of aggregate index dimensions.
2476
2477       Aggr_Low  : array (1 .. Aggr_Dimension) of Node_Id;
2478       Aggr_High : array (1 .. Aggr_Dimension) of Node_Id;
2479       --  Low and High bounds of the constraint for each aggregate index.
2480
2481       Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
2482       --  The type of each index.
2483
2484       Maybe_In_Place_OK : Boolean;
2485       --  If the type is neither controlled nor packed and the aggregate
2486       --  is the expression in an assignment, assignment in place may be
2487       --  possible, provided other conditions are met on the LHS.
2488
2489       Others_Present : array (1 .. Aggr_Dimension) of Boolean :=
2490                          (others => False);
2491       --  If Others_Present (J) is True, then there is an others choice
2492       --  in one of the sub-aggregates of N at dimension J.
2493
2494       procedure Build_Constrained_Type (Positional : Boolean);
2495       --  If the subtype is not static or unconstrained, build a constrained
2496       --  type using the computable sizes of the aggregate and its sub-
2497       --  aggregates.
2498
2499       procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id);
2500       --  Checks that the bounds of Aggr_Bounds are within the bounds defined
2501       --  by Index_Bounds.
2502
2503       procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos);
2504       --  Checks that in a multi-dimensional array aggregate all subaggregates
2505       --  corresponding to the same dimension have the same bounds.
2506       --  Sub_Aggr is an array sub-aggregate. Dim is the dimension
2507       --  corresponding to the sub-aggregate.
2508
2509       procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos);
2510       --  Computes the values of array Others_Present. Sub_Aggr is the
2511       --  array sub-aggregate we start the computation from. Dim is the
2512       --  dimension corresponding to the sub-aggregate.
2513
2514       function Has_Address_Clause (D : Node_Id) return Boolean;
2515       --  If the aggregate is the expression in an object declaration, it
2516       --  cannot be expanded in place. This function does a lookahead in the
2517       --  current declarative part to find an address clause for the object
2518       --  being declared.
2519
2520       function In_Place_Assign_OK return Boolean;
2521       --  Simple predicate to determine whether an aggregate assignment can
2522       --  be done in place, because none of the new values can depend on the
2523       --  components of the target of the assignment.
2524
2525       procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
2526       --  Checks that if an others choice is present in any sub-aggregate no
2527       --  aggregate index is outside the bounds of the index constraint.
2528       --  Sub_Aggr is an array sub-aggregate. Dim is the dimension
2529       --  corresponding to the sub-aggregate.
2530
2531       ----------------------------
2532       -- Build_Constrained_Type --
2533       ----------------------------
2534
2535       procedure Build_Constrained_Type (Positional : Boolean) is
2536          Loc        : constant Source_Ptr := Sloc (N);
2537          Agg_Type   : Entity_Id;
2538          Comp       : Node_Id;
2539          Decl       : Node_Id;
2540          Typ        : constant Entity_Id := Etype (N);
2541          Indices    : List_Id := New_List;
2542          Num        : Int;
2543          Sub_Agg    : Node_Id;
2544
2545       begin
2546          Agg_Type :=
2547            Make_Defining_Identifier (
2548              Loc, New_Internal_Name ('A'));
2549
2550          --  If the aggregate is purely positional, all its subaggregates
2551          --  have the same size. We collect the dimensions from the first
2552          --  subaggregate at each level.
2553
2554          if Positional then
2555             Sub_Agg := N;
2556
2557             for D in 1 .. Number_Dimensions (Typ) loop
2558                Comp := First (Expressions (Sub_Agg));
2559
2560                Sub_Agg := Comp;
2561                Num := 0;
2562
2563                while Present (Comp) loop
2564                   Num := Num + 1;
2565                   Next (Comp);
2566                end loop;
2567
2568                Append (
2569                  Make_Range (Loc,
2570                    Low_Bound => Make_Integer_Literal (Loc, 1),
2571                    High_Bound =>
2572                           Make_Integer_Literal (Loc, Num)),
2573                  Indices);
2574             end loop;
2575
2576          else
2577
2578             --  We know the aggregate type is unconstrained and the
2579             --  aggregate is not processable by the back end, therefore
2580             --  not necessarily positional. Retrieve the bounds of each
2581             --  dimension as computed earlier.
2582
2583             for D in 1 .. Number_Dimensions (Typ) loop
2584                Append (
2585                  Make_Range (Loc,
2586                     Low_Bound  => Aggr_Low  (D),
2587                     High_Bound => Aggr_High (D)),
2588                  Indices);
2589             end loop;
2590          end if;
2591
2592          Decl :=
2593            Make_Full_Type_Declaration (Loc,
2594                Defining_Identifier => Agg_Type,
2595                Type_Definition =>
2596                  Make_Constrained_Array_Definition (Loc,
2597                    Discrete_Subtype_Definitions => Indices,
2598                    Subtype_Indication =>
2599                      New_Occurrence_Of (Component_Type (Typ), Loc)));
2600
2601          Insert_Action (N, Decl);
2602          Analyze (Decl);
2603          Set_Etype (N, Agg_Type);
2604          Set_Is_Itype (Agg_Type);
2605          Freeze_Itype (Agg_Type, N);
2606       end Build_Constrained_Type;
2607
2608       ------------------
2609       -- Check_Bounds --
2610       ------------------
2611
2612       procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is
2613          Aggr_Lo : Node_Id;
2614          Aggr_Hi : Node_Id;
2615
2616          Ind_Lo  : Node_Id;
2617          Ind_Hi  : Node_Id;
2618
2619          Cond    : Node_Id := Empty;
2620
2621       begin
2622          Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi);
2623          Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi);
2624
2625          --  Generate the following test:
2626          --
2627          --    [constraint_error when
2628          --      Aggr_Lo <= Aggr_Hi and then
2629          --        (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
2630          --
2631          --  As an optimization try to see if some tests are trivially vacuos
2632          --  because we are comparing an expression against itself.
2633
2634          if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then
2635             Cond := Empty;
2636
2637          elsif Aggr_Hi = Ind_Hi then
2638             Cond :=
2639               Make_Op_Lt (Loc,
2640                 Left_Opnd  => Duplicate_Subexpr (Aggr_Lo),
2641                 Right_Opnd => Duplicate_Subexpr (Ind_Lo));
2642
2643          elsif Aggr_Lo = Ind_Lo then
2644             Cond :=
2645               Make_Op_Gt (Loc,
2646                 Left_Opnd  => Duplicate_Subexpr (Aggr_Hi),
2647                 Right_Opnd => Duplicate_Subexpr (Ind_Hi));
2648
2649          else
2650             Cond :=
2651               Make_Or_Else (Loc,
2652                 Left_Opnd =>
2653                   Make_Op_Lt (Loc,
2654                     Left_Opnd  => Duplicate_Subexpr (Aggr_Lo),
2655                     Right_Opnd => Duplicate_Subexpr (Ind_Lo)),
2656
2657                 Right_Opnd =>
2658                   Make_Op_Gt (Loc,
2659                     Left_Opnd  => Duplicate_Subexpr (Aggr_Hi),
2660                     Right_Opnd => Duplicate_Subexpr (Ind_Hi)));
2661          end if;
2662
2663          if Present (Cond) then
2664             Cond :=
2665               Make_And_Then (Loc,
2666                 Left_Opnd =>
2667                   Make_Op_Le (Loc,
2668                     Left_Opnd  => Duplicate_Subexpr (Aggr_Lo),
2669                     Right_Opnd => Duplicate_Subexpr (Aggr_Hi)),
2670
2671                 Right_Opnd => Cond);
2672
2673             Set_Analyzed (Left_Opnd  (Left_Opnd (Cond)), False);
2674             Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False);
2675             Insert_Action (N,
2676               Make_Raise_Constraint_Error (Loc,
2677                 Condition => Cond,
2678                 Reason    => CE_Length_Check_Failed));
2679          end if;
2680       end Check_Bounds;
2681
2682       ----------------------------
2683       -- Check_Same_Aggr_Bounds --
2684       ----------------------------
2685
2686       procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
2687          Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr));
2688          Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr));
2689          --  The bounds of this specific sub-aggregate.
2690
2691          Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
2692          Aggr_Hi : constant Node_Id := Aggr_High (Dim);
2693          --  The bounds of the aggregate for this dimension
2694
2695          Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
2696          --  The index type for this dimension.
2697
2698          Cond : Node_Id := Empty;
2699
2700          Assoc  : Node_Id;
2701          Expr   : Node_Id;
2702
2703       begin
2704          --  If index checks are on generate the test
2705          --
2706          --    [constraint_error when
2707          --      Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
2708          --
2709          --  As an optimization try to see if some tests are trivially vacuos
2710          --  because we are comparing an expression against itself. Also for
2711          --  the first dimension the test is trivially vacuous because there
2712          --  is just one aggregate for dimension 1.
2713
2714          if Index_Checks_Suppressed (Ind_Typ) then
2715             Cond := Empty;
2716
2717          elsif Dim = 1
2718            or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi)
2719          then
2720             Cond := Empty;
2721
2722          elsif Aggr_Hi = Sub_Hi then
2723             Cond :=
2724               Make_Op_Ne (Loc,
2725                 Left_Opnd  => Duplicate_Subexpr (Aggr_Lo),
2726                 Right_Opnd => Duplicate_Subexpr (Sub_Lo));
2727
2728          elsif Aggr_Lo = Sub_Lo then
2729             Cond :=
2730               Make_Op_Ne (Loc,
2731                 Left_Opnd  => Duplicate_Subexpr (Aggr_Hi),
2732                 Right_Opnd => Duplicate_Subexpr (Sub_Hi));
2733
2734          else
2735             Cond :=
2736               Make_Or_Else (Loc,
2737                 Left_Opnd =>
2738                   Make_Op_Ne (Loc,
2739                     Left_Opnd  => Duplicate_Subexpr (Aggr_Lo),
2740                     Right_Opnd => Duplicate_Subexpr (Sub_Lo)),
2741
2742                 Right_Opnd =>
2743                   Make_Op_Ne (Loc,
2744                     Left_Opnd  => Duplicate_Subexpr (Aggr_Hi),
2745                     Right_Opnd => Duplicate_Subexpr (Sub_Hi)));
2746          end if;
2747
2748          if Present (Cond) then
2749             Insert_Action (N,
2750               Make_Raise_Constraint_Error (Loc,
2751                 Condition => Cond,
2752                 Reason    => CE_Length_Check_Failed));
2753          end if;
2754
2755          --  Now look inside the sub-aggregate to see if there is more work
2756
2757          if Dim < Aggr_Dimension then
2758
2759             --  Process positional components
2760
2761             if Present (Expressions (Sub_Aggr)) then
2762                Expr := First (Expressions (Sub_Aggr));
2763                while Present (Expr) loop
2764                   Check_Same_Aggr_Bounds (Expr, Dim + 1);
2765                   Next (Expr);
2766                end loop;
2767             end if;
2768
2769             --  Process component associations
2770
2771             if Present (Component_Associations (Sub_Aggr)) then
2772                Assoc := First (Component_Associations (Sub_Aggr));
2773                while Present (Assoc) loop
2774                   Expr := Expression (Assoc);
2775                   Check_Same_Aggr_Bounds (Expr, Dim + 1);
2776                   Next (Assoc);
2777                end loop;
2778             end if;
2779          end if;
2780       end Check_Same_Aggr_Bounds;
2781
2782       ----------------------------
2783       -- Compute_Others_Present --
2784       ----------------------------
2785
2786       procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is
2787          Assoc  : Node_Id;
2788          Expr   : Node_Id;
2789
2790       begin
2791          if Present (Component_Associations (Sub_Aggr)) then
2792             Assoc := Last (Component_Associations (Sub_Aggr));
2793
2794             if Nkind (First (Choices (Assoc))) = N_Others_Choice then
2795                Others_Present (Dim) := True;
2796             end if;
2797          end if;
2798
2799          --  Now look inside the sub-aggregate to see if there is more work
2800
2801          if Dim < Aggr_Dimension then
2802
2803             --  Process positional components
2804
2805             if Present (Expressions (Sub_Aggr)) then
2806                Expr := First (Expressions (Sub_Aggr));
2807                while Present (Expr) loop
2808                   Compute_Others_Present (Expr, Dim + 1);
2809                   Next (Expr);
2810                end loop;
2811             end if;
2812
2813             --  Process component associations
2814
2815             if Present (Component_Associations (Sub_Aggr)) then
2816                Assoc := First (Component_Associations (Sub_Aggr));
2817                while Present (Assoc) loop
2818                   Expr := Expression (Assoc);
2819                   Compute_Others_Present (Expr, Dim + 1);
2820                   Next (Assoc);
2821                end loop;
2822             end if;
2823          end if;
2824       end Compute_Others_Present;
2825
2826       -------------------------
2827       --  Has_Address_Clause --
2828       -------------------------
2829
2830       function Has_Address_Clause (D : Node_Id) return Boolean is
2831          Id   : Entity_Id := Defining_Identifier (D);
2832          Decl : Node_Id := Next (D);
2833
2834       begin
2835          while Present (Decl) loop
2836
2837             if Nkind (Decl) = N_At_Clause
2838                and then Chars (Identifier (Decl)) = Chars (Id)
2839             then
2840                return True;
2841
2842             elsif Nkind (Decl) = N_Attribute_Definition_Clause
2843                and then Chars (Decl) = Name_Address
2844                and then Chars (Name (Decl)) = Chars (Id)
2845             then
2846                return True;
2847             end if;
2848
2849             Next (Decl);
2850          end loop;
2851
2852          return False;
2853       end Has_Address_Clause;
2854
2855       ------------------------
2856       -- In_Place_Assign_OK --
2857       ------------------------
2858
2859       function In_Place_Assign_OK return Boolean is
2860          Aggr_In : Node_Id;
2861          Aggr_Lo : Node_Id;
2862          Aggr_Hi : Node_Id;
2863          Obj_In  : Node_Id;
2864          Obj_Lo  : Node_Id;
2865          Obj_Hi  : Node_Id;
2866
2867          function Is_Others_Aggregate (Aggr : Node_Id) return Boolean;
2868          --   Aggregates that consist of a single Others choice are safe
2869          --  if the single expression is.
2870
2871          function Safe_Aggregate (Aggr : Node_Id) return Boolean;
2872          --  Check recursively that each component of a (sub)aggregate does
2873          --  not depend on the variable being assigned to.
2874
2875          function Safe_Component (Expr : Node_Id) return Boolean;
2876          --  Verify that an expression cannot depend on the variable being
2877          --  assigned to. Room for improvement here (but less than before).
2878
2879          -------------------------
2880          -- Is_Others_Aggregate --
2881          -------------------------
2882
2883          function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is
2884          begin
2885             return No (Expressions (Aggr))
2886               and then Nkind
2887                 (First (Choices (First (Component_Associations (Aggr)))))
2888                   = N_Others_Choice;
2889          end Is_Others_Aggregate;
2890
2891          --------------------
2892          -- Safe_Aggregate --
2893          --------------------
2894
2895          function Safe_Aggregate (Aggr : Node_Id) return Boolean is
2896             Expr : Node_Id;
2897
2898          begin
2899             if Present (Expressions (Aggr)) then
2900                Expr := First (Expressions (Aggr));
2901
2902                while Present (Expr) loop
2903                   if Nkind (Expr) = N_Aggregate then
2904                      if not Safe_Aggregate (Expr) then
2905                         return False;
2906                      end if;
2907
2908                   elsif not Safe_Component (Expr) then
2909                      return False;
2910                   end if;
2911
2912                   Next (Expr);
2913                end loop;
2914             end if;
2915
2916             if Present (Component_Associations (Aggr)) then
2917                Expr := First (Component_Associations (Aggr));
2918
2919                while Present (Expr) loop
2920                   if Nkind (Expression (Expr)) = N_Aggregate then
2921                      if not Safe_Aggregate (Expression (Expr)) then
2922                         return False;
2923                      end if;
2924
2925                   elsif not Safe_Component (Expression (Expr)) then
2926                      return False;
2927                   end if;
2928
2929                   Next (Expr);
2930                end loop;
2931             end if;
2932
2933             return True;
2934          end Safe_Aggregate;
2935
2936          --------------------
2937          -- Safe_Component --
2938          --------------------
2939
2940          function Safe_Component (Expr : Node_Id) return Boolean is
2941             Comp : Node_Id := Expr;
2942
2943             function Check_Component (Comp : Node_Id) return Boolean;
2944             --  Do the recursive traversal, after copy.
2945
2946             function Check_Component (Comp : Node_Id) return Boolean is
2947             begin
2948                if Is_Overloaded (Comp) then
2949                   return False;
2950                end if;
2951
2952                return Compile_Time_Known_Value (Comp)
2953
2954                  or else (Is_Entity_Name (Comp)
2955                            and then  Present (Entity (Comp))
2956                            and then No (Renamed_Object (Entity (Comp))))
2957
2958                  or else (Nkind (Comp) = N_Attribute_Reference
2959                            and then Check_Component (Prefix (Comp)))
2960
2961                  or else (Nkind (Comp) in N_Binary_Op
2962                            and then Check_Component (Left_Opnd  (Comp))
2963                            and then Check_Component (Right_Opnd (Comp)))
2964
2965                  or else (Nkind (Comp) in N_Unary_Op
2966                            and then Check_Component (Right_Opnd (Comp)))
2967
2968                  or else (Nkind (Comp) = N_Selected_Component
2969                            and then Check_Component (Prefix (Comp)));
2970             end Check_Component;
2971
2972             --  Start of processing for Safe_Component
2973
2974          begin
2975             --  If the component appears in an association that may
2976             --  correspond to more than one element, it is not analyzed
2977             --  before the expansion into assignments, to avoid side effects.
2978             --  We analyze, but do not resolve the copy, to obtain sufficient
2979             --  entity information for the checks that follow. If component is
2980             --  overloaded we assume an unsafe function call.
2981
2982             if not Analyzed (Comp) then
2983                if Is_Overloaded (Expr) then
2984                   return False;
2985
2986                elsif Nkind (Expr) = N_Aggregate
2987                   and then not Is_Others_Aggregate (Expr)
2988                then
2989                   return False;
2990
2991                elsif Nkind (Expr) = N_Allocator then
2992                   --  For now, too complex to analyze.
2993
2994                   return False;
2995                end if;
2996
2997                Comp := New_Copy_Tree (Expr);
2998                Set_Parent (Comp, Parent (Expr));
2999                Analyze (Comp);
3000             end if;
3001
3002             if Nkind (Comp) = N_Aggregate then
3003                return Safe_Aggregate (Comp);
3004             else
3005                return Check_Component (Comp);
3006             end if;
3007          end Safe_Component;
3008
3009       --  Start of processing for In_Place_Assign_OK
3010
3011       begin
3012          if Present (Component_Associations (N)) then
3013
3014             --  On assignment, sliding can take place, so we cannot do the
3015             --  assignment in place unless the bounds of the aggregate are
3016             --  statically equal to those of the target.
3017
3018             --  If the aggregate is given by an others choice, the bounds
3019             --  are derived from the left-hand side, and the assignment is
3020             --  safe if the expression is.
3021
3022             if Is_Others_Aggregate (N) then
3023                return
3024                  Safe_Component
3025                   (Expression (First (Component_Associations (N))));
3026             end if;
3027
3028             Aggr_In := First_Index (Etype (N));
3029             Obj_In  := First_Index (Etype (Name (Parent (N))));
3030
3031             while Present (Aggr_In) loop
3032                Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
3033                Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
3034
3035                if not Compile_Time_Known_Value (Aggr_Lo)
3036                  or else not Compile_Time_Known_Value (Aggr_Hi)
3037                  or else not Compile_Time_Known_Value (Obj_Lo)
3038                  or else not Compile_Time_Known_Value (Obj_Hi)
3039                  or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
3040                  or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
3041                then
3042                   return False;
3043                end if;
3044
3045                Next_Index (Aggr_In);
3046                Next_Index (Obj_In);
3047             end loop;
3048          end if;
3049
3050          --  Now check the component values themselves.
3051
3052          return Safe_Aggregate (N);
3053       end In_Place_Assign_OK;
3054
3055       ------------------
3056       -- Others_Check --
3057       ------------------
3058
3059       procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is
3060          Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
3061          Aggr_Hi : constant Node_Id := Aggr_High (Dim);
3062          --  The bounds of the aggregate for this dimension.
3063
3064          Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
3065          --  The index type for this dimension.
3066
3067          Need_To_Check : Boolean := False;
3068
3069          Choices_Lo : Node_Id := Empty;
3070          Choices_Hi : Node_Id := Empty;
3071          --  The lowest and highest discrete choices for a named sub-aggregate
3072
3073          Nb_Choices : Int := -1;
3074          --  The number of discrete non-others choices in this sub-aggregate
3075
3076          Nb_Elements : Uint := Uint_0;
3077          --  The number of elements in a positional aggregate
3078
3079          Cond : Node_Id := Empty;
3080
3081          Assoc  : Node_Id;
3082          Choice : Node_Id;
3083          Expr   : Node_Id;
3084
3085       begin
3086          --  Check if we have an others choice. If we do make sure that this
3087          --  sub-aggregate contains at least one element in addition to the
3088          --  others choice.
3089
3090          if Range_Checks_Suppressed (Ind_Typ) then
3091             Need_To_Check := False;
3092
3093          elsif Present (Expressions (Sub_Aggr))
3094            and then Present (Component_Associations (Sub_Aggr))
3095          then
3096             Need_To_Check := True;
3097
3098          elsif Present (Component_Associations (Sub_Aggr)) then
3099             Assoc := Last (Component_Associations (Sub_Aggr));
3100
3101             if Nkind (First (Choices (Assoc))) /= N_Others_Choice then
3102                Need_To_Check := False;
3103
3104             else
3105                --  Count the number of discrete choices. Start with -1
3106                --  because the others choice does not count.
3107
3108                Nb_Choices := -1;
3109                Assoc := First (Component_Associations (Sub_Aggr));
3110                while Present (Assoc) loop
3111                   Choice := First (Choices (Assoc));
3112                   while Present (Choice) loop
3113                      Nb_Choices := Nb_Choices + 1;
3114                      Next (Choice);
3115                   end loop;
3116
3117                   Next (Assoc);
3118                end loop;
3119
3120                --  If there is only an others choice nothing to do
3121
3122                Need_To_Check := (Nb_Choices > 0);
3123             end if;
3124
3125          else
3126             Need_To_Check := False;
3127          end if;
3128
3129          --  If we are dealing with a positional sub-aggregate with an
3130          --  others choice then compute the number or positional elements.
3131
3132          if Need_To_Check and then Present (Expressions (Sub_Aggr)) then
3133             Expr := First (Expressions (Sub_Aggr));
3134             Nb_Elements := Uint_0;
3135             while Present (Expr) loop
3136                Nb_Elements := Nb_Elements + 1;
3137                Next (Expr);
3138             end loop;
3139
3140          --  If the aggregate contains discrete choices and an others choice
3141          --  compute the smallest and largest discrete choice values.
3142
3143          elsif Need_To_Check then
3144             Compute_Choices_Lo_And_Choices_Hi : declare
3145
3146                Table : Case_Table_Type (1 .. Nb_Choices);
3147                --  Used to sort all the different choice values
3148
3149                J    : Pos := 1;
3150                Low  : Node_Id;
3151                High : Node_Id;
3152
3153             begin
3154                Assoc := First (Component_Associations (Sub_Aggr));
3155                while Present (Assoc) loop
3156                   Choice := First (Choices (Assoc));
3157                   while Present (Choice) loop
3158                      if Nkind (Choice) = N_Others_Choice then
3159                         exit;
3160                      end if;
3161
3162                      Get_Index_Bounds (Choice, Low, High);
3163                      Table (J).Choice_Lo := Low;
3164                      Table (J).Choice_Hi := High;
3165
3166                      J := J + 1;
3167                      Next (Choice);
3168                   end loop;
3169
3170                   Next (Assoc);
3171                end loop;
3172
3173                --  Sort the discrete choices
3174
3175                Sort_Case_Table (Table);
3176
3177                Choices_Lo := Table (1).Choice_Lo;
3178                Choices_Hi := Table (Nb_Choices).Choice_Hi;
3179             end Compute_Choices_Lo_And_Choices_Hi;
3180          end if;
3181
3182          --  If no others choice in this sub-aggregate, or the aggregate
3183          --  comprises only an others choice, nothing to do.
3184
3185          if not Need_To_Check then
3186             Cond := Empty;
3187
3188          --  If we are dealing with an aggregate containing an others
3189          --  choice and positional components, we generate the following test:
3190          --
3191          --    if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
3192          --            Ind_Typ'Pos (Aggr_Hi)
3193          --    then
3194          --       raise Constraint_Error;
3195          --    end if;
3196
3197          elsif Nb_Elements > Uint_0 then
3198             Cond :=
3199               Make_Op_Gt (Loc,
3200                 Left_Opnd  =>
3201                   Make_Op_Add (Loc,
3202                     Left_Opnd  =>
3203                       Make_Attribute_Reference (Loc,
3204                         Prefix         => New_Reference_To (Ind_Typ, Loc),
3205                         Attribute_Name => Name_Pos,
3206                         Expressions    =>
3207                           New_List (Duplicate_Subexpr (Aggr_Lo))),
3208                     Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
3209
3210                 Right_Opnd =>
3211                   Make_Attribute_Reference (Loc,
3212                     Prefix         => New_Reference_To (Ind_Typ, Loc),
3213                     Attribute_Name => Name_Pos,
3214                     Expressions    => New_List (Duplicate_Subexpr (Aggr_Hi))));
3215
3216          --  If we are dealing with an aggregate containing an others
3217          --  choice and discrete choices we generate the following test:
3218          --
3219          --    [constraint_error when
3220          --      Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
3221
3222          else
3223             Cond :=
3224               Make_Or_Else (Loc,
3225                 Left_Opnd =>
3226                   Make_Op_Lt (Loc,
3227                     Left_Opnd  => Duplicate_Subexpr (Choices_Lo),
3228                     Right_Opnd => Duplicate_Subexpr (Aggr_Lo)),
3229
3230                 Right_Opnd =>
3231                   Make_Op_Gt (Loc,
3232                     Left_Opnd  => Duplicate_Subexpr (Choices_Hi),
3233                     Right_Opnd => Duplicate_Subexpr (Aggr_Hi)));
3234          end if;
3235
3236          if Present (Cond) then
3237             Insert_Action (N,
3238               Make_Raise_Constraint_Error (Loc,
3239                 Condition => Cond,
3240                 Reason    => CE_Length_Check_Failed));
3241          end if;
3242
3243          --  Now look inside the sub-aggregate to see if there is more work
3244
3245          if Dim < Aggr_Dimension then
3246
3247             --  Process positional components
3248
3249             if Present (Expressions (Sub_Aggr)) then
3250                Expr := First (Expressions (Sub_Aggr));
3251                while Present (Expr) loop
3252                   Others_Check (Expr, Dim + 1);
3253                   Next (Expr);
3254                end loop;
3255             end if;
3256
3257             --  Process component associations
3258
3259             if Present (Component_Associations (Sub_Aggr)) then
3260                Assoc := First (Component_Associations (Sub_Aggr));
3261                while Present (Assoc) loop
3262                   Expr := Expression (Assoc);
3263                   Others_Check (Expr, Dim + 1);
3264                   Next (Assoc);
3265                end loop;
3266             end if;
3267          end if;
3268       end Others_Check;
3269
3270       --  Remaining Expand_Array_Aggregate variables
3271
3272       Tmp : Entity_Id;
3273       --  Holds the temporary aggregate value.
3274
3275       Tmp_Decl : Node_Id;
3276       --  Holds the declaration of Tmp.
3277
3278       Aggr_Code   : List_Id;
3279       Parent_Node : Node_Id;
3280       Parent_Kind : Node_Kind;
3281
3282    --  Start of processing for Expand_Array_Aggregate
3283
3284    begin
3285       --  Do not touch the special aggregates of attributes used for Asm calls
3286
3287       if Is_RTE (Ctyp, RE_Asm_Input_Operand)
3288         or else Is_RTE (Ctyp, RE_Asm_Output_Operand)
3289       then
3290          return;
3291       end if;
3292
3293       --  If the semantic analyzer has determined that aggregate N will raise
3294       --  Constraint_Error at run-time, then the aggregate node has been
3295       --  replaced with an N_Raise_Constraint_Error node and we should
3296       --  never get here.
3297
3298       pragma Assert (not Raises_Constraint_Error (N));
3299
3300       --  STEP 1: Check (a)
3301
3302       Index_Compatibility_Check : declare
3303          Aggr_Index_Range : Node_Id := First_Index (Typ);
3304          --  The current aggregate index range
3305
3306          Index_Constraint : Node_Id := First_Index (Etype (Typ));
3307          --  The corresponding index constraint against which we have to
3308          --  check the above aggregate index range.
3309
3310       begin
3311          Compute_Others_Present (N, 1);
3312
3313          for J in 1 .. Aggr_Dimension loop
3314             --  There is no need to emit a check if an others choice is
3315             --  present for this array aggregate dimension since in this
3316             --  case one of N's sub-aggregates has taken its bounds from the
3317             --  context and these bounds must have been checked already. In
3318             --  addition all sub-aggregates corresponding to the same
3319             --  dimension must all have the same bounds (checked in (c) below).
3320
3321             if not Range_Checks_Suppressed (Etype (Index_Constraint))
3322               and then not Others_Present (J)
3323             then
3324                --  We don't use Checks.Apply_Range_Check here because it
3325                --  emits a spurious check. Namely it checks that the range
3326                --  defined by the aggregate bounds is non empty. But we know
3327                --  this already if we get here.
3328
3329                Check_Bounds (Aggr_Index_Range, Index_Constraint);
3330             end if;
3331
3332             --  Save the low and high bounds of the aggregate index as well
3333             --  as the index type for later use in checks (b) and (c) below.
3334
3335             Aggr_Low  (J) := Low_Bound (Aggr_Index_Range);
3336             Aggr_High (J) := High_Bound (Aggr_Index_Range);
3337
3338             Aggr_Index_Typ (J) := Etype (Index_Constraint);
3339
3340             Next_Index (Aggr_Index_Range);
3341             Next_Index (Index_Constraint);
3342          end loop;
3343       end Index_Compatibility_Check;
3344
3345       --  STEP 1: Check (b)
3346
3347       Others_Check (N, 1);
3348
3349       --  STEP 1: Check (c)
3350
3351       if Aggr_Dimension > 1 then
3352          Check_Same_Aggr_Bounds (N, 1);
3353       end if;
3354
3355       --  STEP 2.
3356
3357       --  First try to convert to positional form. If the result is not
3358       --  an aggregate any more, then we are done with the analysis (it
3359       --  it could be a string literal or an identifier for a temporary
3360       --  variable following this call). If result is an analyzed aggregate
3361       --  the transformation was also successful and we are done as well.
3362
3363       Convert_To_Positional (N);
3364
3365       if Nkind (N) /= N_Aggregate then
3366          return;
3367
3368       elsif Analyzed (N)
3369         and then N /= Original_Node (N)
3370       then
3371          return;
3372       end if;
3373
3374       if Backend_Processing_Possible (N) then
3375
3376          --  If the aggregate is static but the constraints are not, build
3377          --  a static subtype for the aggregate, so that Gigi can place it
3378          --  in static memory. Perform an unchecked_conversion to the non-
3379          --  static type imposed by the context.
3380
3381          declare
3382             Itype      : constant Entity_Id := Etype (N);
3383             Index      : Node_Id;
3384             Needs_Type : Boolean := False;
3385
3386          begin
3387             Index := First_Index (Itype);
3388
3389             while Present (Index) loop
3390                if not Is_Static_Subtype (Etype (Index)) then
3391                   Needs_Type := True;
3392                   exit;
3393                else
3394                   Next_Index (Index);
3395                end if;
3396             end loop;
3397
3398             if Needs_Type then
3399                Build_Constrained_Type (Positional => True);
3400                Rewrite (N, Unchecked_Convert_To (Itype, N));
3401                Analyze (N);
3402             end if;
3403          end;
3404
3405          return;
3406       end if;
3407
3408       --  Delay expansion for nested aggregates it will be taken care of
3409       --  when the parent aggregate is expanded
3410
3411       Parent_Node := Parent (N);
3412       Parent_Kind := Nkind (Parent_Node);
3413
3414       if Parent_Kind = N_Qualified_Expression then
3415          Parent_Node := Parent (Parent_Node);
3416          Parent_Kind := Nkind (Parent_Node);
3417       end if;
3418
3419       if Parent_Kind = N_Aggregate
3420         or else Parent_Kind = N_Extension_Aggregate
3421         or else Parent_Kind = N_Component_Association
3422         or else (Parent_Kind = N_Object_Declaration
3423                   and then Controlled_Type (Typ))
3424         or else (Parent_Kind = N_Assignment_Statement
3425                   and then Inside_Init_Proc)
3426       then
3427          Set_Expansion_Delayed (N);
3428          return;
3429       end if;
3430
3431       --  STEP 3.
3432
3433       --  Look if in place aggregate expansion is possible
3434
3435       --  First case to test for is packed array aggregate that we can
3436       --  handle at compile time. If so, return with transformation done.
3437
3438       if Packed_Array_Aggregate_Handled (N) then
3439          return;
3440       end if;
3441
3442       --  For object declarations we build the aggregate in place, unless
3443       --  the array is bit-packed or the component is controlled.
3444
3445       --  For assignments we do the assignment in place if all the component
3446       --  associations have compile-time known values. For other cases we
3447       --  create a temporary. The analysis for safety of on-line assignment
3448       --  is delicate, i.e. we don't know how to do it fully yet ???
3449
3450       if Requires_Transient_Scope (Typ) then
3451          Establish_Transient_Scope
3452            (N, Sec_Stack => Has_Controlled_Component (Typ));
3453       end if;
3454
3455       Maybe_In_Place_OK :=
3456         Comes_From_Source (N)
3457           and then Nkind (Parent (N)) = N_Assignment_Statement
3458           and then not Is_Bit_Packed_Array (Typ)
3459           and then not Has_Controlled_Component (Typ)
3460           and then In_Place_Assign_OK;
3461
3462       if Comes_From_Source (Parent (N))
3463          and then Nkind (Parent (N)) = N_Object_Declaration
3464          and then N = Expression (Parent (N))
3465          and then not Is_Bit_Packed_Array (Typ)
3466          and then not Has_Controlled_Component (Typ)
3467          and then not Has_Address_Clause (Parent (N))
3468       then
3469          Tmp := Defining_Identifier (Parent (N));
3470          Set_No_Initialization (Parent (N));
3471          Set_Expression (Parent (N), Empty);
3472
3473          --  Set the type of the entity, for use in the analysis of the
3474          --  subsequent indexed assignments. If the nominal type is not
3475          --  constrained, build a subtype from the known bounds of the
3476          --  aggregate. If the declaration has a subtype mark, use it,
3477          --  otherwise use the itype of the aggregate.
3478
3479          if not Is_Constrained (Typ) then
3480             Build_Constrained_Type (Positional => False);
3481          elsif Is_Entity_Name (Object_Definition (Parent (N)))
3482            and then Is_Constrained (Entity (Object_Definition (Parent (N))))
3483          then
3484             Set_Etype (Tmp, Entity (Object_Definition (Parent (N))));
3485          else
3486             Set_Size_Known_At_Compile_Time (Typ, False);
3487             Set_Etype (Tmp, Typ);
3488          end if;
3489
3490       elsif Maybe_In_Place_OK
3491         and then Is_Entity_Name (Name (Parent (N)))
3492       then
3493          Tmp := Entity (Name (Parent (N)));
3494
3495          if Etype (Tmp) /= Etype (N) then
3496             Apply_Length_Check (N, Etype (Tmp));
3497          end if;
3498
3499       elsif Maybe_In_Place_OK
3500         and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
3501         and then Is_Entity_Name (Prefix (Name (Parent (N))))
3502       then
3503          Tmp := Name (Parent (N));
3504
3505          if Etype (Tmp) /= Etype (N) then
3506             Apply_Length_Check (N, Etype (Tmp));
3507          end if;
3508
3509       elsif Maybe_In_Place_OK
3510         and then Nkind (Name (Parent (N))) = N_Slice
3511         and then Safe_Slice_Assignment (N)
3512       then
3513          --  Safe_Slice_Assignment rewrites assignment as a loop
3514
3515          return;
3516
3517       else
3518          Maybe_In_Place_OK := False;
3519          Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
3520          Tmp_Decl :=
3521            Make_Object_Declaration
3522              (Loc,
3523               Defining_Identifier => Tmp,
3524               Object_Definition   => New_Occurrence_Of (Typ, Loc));
3525          Set_No_Initialization (Tmp_Decl, True);
3526
3527          --  If we are within a loop, the temporary will be pushed on the
3528          --  stack at each iteration. If the aggregate is the expression for
3529          --  an allocator, it will be immediately copied to the heap and can
3530          --  be reclaimed at once. We create a transient scope around the
3531          --  aggregate for this purpose.
3532
3533          if Ekind (Current_Scope) = E_Loop
3534            and then Nkind (Parent (Parent (N))) = N_Allocator
3535          then
3536             Establish_Transient_Scope (N, False);
3537          end if;
3538
3539          Insert_Action (N, Tmp_Decl);
3540       end if;
3541
3542       --  Construct and insert the aggregate code. We can safely suppress
3543       --  index checks because this code is guaranteed not to raise CE
3544       --  on index checks. However we should *not* suppress all checks.
3545
3546       declare
3547          Target : Node_Id;
3548
3549       begin
3550          if Nkind (Tmp) = N_Defining_Identifier then
3551             Target := New_Reference_To (Tmp, Loc);
3552
3553          else
3554             --  Name in assignment is explicit dereference.
3555
3556             Target := New_Copy (Tmp);
3557          end if;
3558
3559          Aggr_Code :=
3560            Build_Array_Aggr_Code (N,
3561              Index       => First_Index (Typ),
3562              Into        => Target,
3563              Scalar_Comp => Is_Scalar_Type (Ctyp));
3564       end;
3565
3566       if Comes_From_Source (Tmp) then
3567          Insert_Actions_After (Parent (N), Aggr_Code);
3568
3569       else
3570          Insert_Actions (N, Aggr_Code);
3571       end if;
3572
3573       --  If the aggregate has been assigned in place, remove the original
3574       --  assignment.
3575
3576       if Nkind (Parent (N)) = N_Assignment_Statement
3577         and then Maybe_In_Place_OK
3578       then
3579          Rewrite (Parent (N), Make_Null_Statement (Loc));
3580
3581       elsif Nkind (Parent (N)) /= N_Object_Declaration
3582         or else Tmp /= Defining_Identifier (Parent (N))
3583       then
3584          Rewrite (N, New_Occurrence_Of (Tmp, Loc));
3585          Analyze_And_Resolve (N, Typ);
3586       end if;
3587    end Expand_Array_Aggregate;
3588
3589    ------------------------
3590    -- Expand_N_Aggregate --
3591    ------------------------
3592
3593    procedure Expand_N_Aggregate (N : Node_Id) is
3594    begin
3595       if Is_Record_Type (Etype (N)) then
3596          Expand_Record_Aggregate (N);
3597       else
3598          Expand_Array_Aggregate (N);
3599       end if;
3600    end Expand_N_Aggregate;
3601
3602    ----------------------------------
3603    -- Expand_N_Extension_Aggregate --
3604    ----------------------------------
3605
3606    --  If the ancestor part is an expression, add a component association for
3607    --  the parent field. If the type of the ancestor part is not the direct
3608    --  parent of the expected type,  build recursively the needed ancestors.
3609    --  If the ancestor part is a subtype_mark, replace aggregate with a decla-
3610    --  ration for a temporary of the expected type, followed by individual
3611    --  assignments to the given components.
3612
3613    procedure Expand_N_Extension_Aggregate (N : Node_Id) is
3614       Loc : constant Source_Ptr := Sloc  (N);
3615       A   : constant Node_Id    := Ancestor_Part (N);
3616       Typ : constant Entity_Id  := Etype (N);
3617
3618    begin
3619       --  If the ancestor is a subtype mark, an init_proc must be called
3620       --  on the resulting object which thus has to be materialized in
3621       --  the front-end
3622
3623       if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
3624          Convert_To_Assignments (N, Typ);
3625
3626       --  The extension aggregate is transformed into a record aggregate
3627       --  of the following form (c1 and c2 are inherited components)
3628
3629       --   (Exp with c3 => a, c4 => b)
3630       --      ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b)
3631
3632       else
3633          Set_Etype (N, Typ);
3634
3635          --  No tag is needed in the case of Java_VM
3636
3637          if Java_VM then
3638             Expand_Record_Aggregate (N,
3639               Parent_Expr => A);
3640          else
3641             Expand_Record_Aggregate (N,
3642               Orig_Tag    => New_Occurrence_Of (Access_Disp_Table (Typ), Loc),
3643               Parent_Expr => A);
3644          end if;
3645       end if;
3646    end Expand_N_Extension_Aggregate;
3647
3648    -----------------------------
3649    -- Expand_Record_Aggregate --
3650    -----------------------------
3651
3652    procedure Expand_Record_Aggregate
3653      (N           : Node_Id;
3654       Orig_Tag    : Node_Id := Empty;
3655       Parent_Expr : Node_Id := Empty)
3656    is
3657       Loc   : constant Source_Ptr   := Sloc  (N);
3658       Comps : constant List_Id      := Component_Associations (N);
3659       Typ   : constant Entity_Id    := Etype (N);
3660       Base_Typ : constant Entity_Id := Base_Type (Typ);
3661
3662       function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean;
3663       --  Checks the presence of a nested aggregate which needs Late_Expansion
3664       --  or the presence of tagged components which may need tag adjustment.
3665
3666       --------------------------------------------------
3667       -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
3668       --------------------------------------------------
3669
3670       function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is
3671          C     : Node_Id;
3672          Expr_Q : Node_Id;
3673
3674       begin
3675          if No (Comps) then
3676             return False;
3677          end if;
3678
3679          C := First (Comps);
3680          while Present (C) loop
3681
3682             if Nkind (Expression (C)) = N_Qualified_Expression then
3683                Expr_Q := Expression (Expression (C));
3684             else
3685                Expr_Q := Expression (C);
3686             end if;
3687
3688             --  Return true if the aggregate has any associations for
3689             --  tagged components that may require tag adjustment.
3690             --  These are cases where the source expression may have
3691             --  a tag that could differ from the component tag (e.g.,
3692             --  can occur for type conversions and formal parameters).
3693             --  (Tag adjustment is not needed if Java_VM because object
3694             --  tags are implicit in the JVM.)
3695
3696             if Is_Tagged_Type (Etype (Expr_Q))
3697               and then (Nkind (Expr_Q) = N_Type_Conversion
3698                 or else (Is_Entity_Name (Expr_Q)
3699                           and then Ekind (Entity (Expr_Q)) in Formal_Kind))
3700               and then not Java_VM
3701             then
3702                return True;
3703             end if;
3704
3705             if Is_Delayed_Aggregate (Expr_Q) then
3706                return True;
3707             end if;
3708
3709             Next (C);
3710          end loop;
3711
3712          return False;
3713       end  Has_Delayed_Nested_Aggregate_Or_Tagged_Comps;
3714
3715       --  Remaining Expand_Record_Aggregate variables
3716
3717       Tag_Value : Node_Id;
3718       Comp      : Entity_Id;
3719       New_Comp  : Node_Id;
3720
3721    --  Start of processing for Expand_Record_Aggregate
3722
3723    begin
3724       --  Gigi doesn't handle properly temporaries of variable size
3725       --  so we generate it in the front-end
3726
3727       if not Size_Known_At_Compile_Time (Typ) then
3728          Convert_To_Assignments (N, Typ);
3729
3730       --  Temporaries for controlled aggregates need to be attached to a
3731       --  final chain in order to be properly finalized, so it has to
3732       --  be created in the front-end
3733
3734       elsif Is_Controlled (Typ)
3735         or else Has_Controlled_Component (Base_Type (Typ))
3736       then
3737          Convert_To_Assignments (N, Typ);
3738
3739       elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then
3740          Convert_To_Assignments (N, Typ);
3741
3742       --  If an ancestor is private, some components are not inherited and
3743       --  we cannot expand into a record aggregate
3744
3745       elsif Has_Private_Ancestor (Typ) then
3746          Convert_To_Assignments (N, Typ);
3747
3748       --  ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
3749       --  is not able to handle the aggregate for Late_Request.
3750
3751       elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
3752          Convert_To_Assignments (N, Typ);
3753
3754       --  In all other cases we generate a proper aggregate that
3755       --  can be handled by gigi.
3756
3757       else
3758          --  If no discriminants, nothing special to do
3759
3760          if not Has_Discriminants (Typ) then
3761             null;
3762
3763          --  Case of discriminants present
3764
3765          elsif Is_Derived_Type (Typ) then
3766
3767             --  For untagged types,  non-girder discriminants are replaced
3768             --  with girder discriminants, which are the ones that gigi uses
3769             --  to describe the type and its components.
3770
3771             Generate_Aggregate_For_Derived_Type : declare
3772                First_Comp   : Node_Id;
3773                Discriminant : Entity_Id;
3774                Constraints  : List_Id := New_List;
3775                Decl         : Node_Id;
3776                Num_Disc     : Int := 0;
3777                Num_Gird     : Int := 0;
3778
3779                procedure Prepend_Girder_Values (T : Entity_Id);
3780                --  Scan the list of girder discriminants of the type, and
3781                --  add their values to the aggregate being built.
3782
3783                ---------------------------
3784                -- Prepend_Girder_Values --
3785                ---------------------------
3786
3787                procedure Prepend_Girder_Values (T : Entity_Id) is
3788                begin
3789                   Discriminant := First_Girder_Discriminant (T);
3790
3791                   while Present (Discriminant) loop
3792                      New_Comp :=
3793                        Make_Component_Association (Loc,
3794                          Choices    =>
3795                            New_List (New_Occurrence_Of (Discriminant, Loc)),
3796
3797                          Expression =>
3798                            New_Copy_Tree (
3799                              Get_Discriminant_Value (
3800                                  Discriminant,
3801                                  Typ,
3802                                  Discriminant_Constraint (Typ))));
3803
3804                      if No (First_Comp) then
3805                         Prepend_To (Component_Associations (N), New_Comp);
3806                      else
3807                         Insert_After (First_Comp, New_Comp);
3808                      end if;
3809
3810                      First_Comp := New_Comp;
3811                      Next_Girder_Discriminant (Discriminant);
3812                   end loop;
3813                end Prepend_Girder_Values;
3814
3815             --  Start of processing for Generate_Aggregate_For_Derived_Type
3816
3817             begin
3818                --  Remove the associations for the  discriminant of
3819                --  the derived type.
3820
3821                First_Comp := First (Component_Associations (N));
3822
3823                while Present (First_Comp) loop
3824                   Comp := First_Comp;
3825                   Next (First_Comp);
3826
3827                   if Ekind (Entity (First (Choices (Comp)))) =
3828                     E_Discriminant
3829                   then
3830                      Remove (Comp);
3831                      Num_Disc := Num_Disc + 1;
3832                   end if;
3833                end loop;
3834
3835                --  Insert girder discriminant associations in the correct
3836                --  order. If there are more girder discriminants than new
3837                --  discriminants, there is at least one new discriminant
3838                --  that constrains more than one of the girders. In this
3839                --  case we need to construct a proper subtype of the parent
3840                --  type, in order to supply values to all the components.
3841                --  Otherwise there is one-one correspondence between the
3842                --  constraints and the girder discriminants.
3843
3844                First_Comp := Empty;
3845
3846                Discriminant := First_Girder_Discriminant (Base_Type (Typ));
3847
3848                while Present (Discriminant) loop
3849                   Num_Gird := Num_Gird + 1;
3850                   Next_Girder_Discriminant (Discriminant);
3851                end loop;
3852
3853                --  Case of more girder discriminants than new discriminants
3854
3855                if Num_Gird > Num_Disc then
3856
3857                   --  Create a proper subtype of the parent type, which is
3858                   --  the proper implementation type for the aggregate, and
3859                   --  convert it to the intended target type.
3860
3861                   Discriminant := First_Girder_Discriminant (Base_Type (Typ));
3862
3863                   while Present (Discriminant) loop
3864                      New_Comp :=
3865                        New_Copy_Tree (
3866                          Get_Discriminant_Value (
3867                              Discriminant,
3868                              Typ,
3869                              Discriminant_Constraint (Typ)));
3870                      Append (New_Comp, Constraints);
3871                      Next_Girder_Discriminant (Discriminant);
3872                   end loop;
3873
3874                   Decl :=
3875                     Make_Subtype_Declaration (Loc,
3876                       Defining_Identifier =>
3877                          Make_Defining_Identifier (Loc,
3878                             New_Internal_Name ('T')),
3879                       Subtype_Indication =>
3880                         Make_Subtype_Indication (Loc,
3881                           Subtype_Mark =>
3882                             New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
3883                           Constraint =>
3884                             Make_Index_Or_Discriminant_Constraint
3885                               (Loc, Constraints)));
3886
3887                   Insert_Action (N, Decl);
3888                   Prepend_Girder_Values (Base_Type (Typ));
3889
3890                   Set_Etype (N, Defining_Identifier (Decl));
3891                   Set_Analyzed (N);
3892
3893                   Rewrite (N, Unchecked_Convert_To (Typ, N));
3894                   Analyze (N);
3895
3896                --  Case where we do not have fewer new discriminants than
3897                --  girder discriminants, so in this case we can simply
3898                --  use the girder discriminants of the subtype.
3899
3900                else
3901                   Prepend_Girder_Values (Typ);
3902                end if;
3903             end Generate_Aggregate_For_Derived_Type;
3904          end if;
3905
3906          if Is_Tagged_Type (Typ) then
3907
3908             --  The tagged case, _parent and _tag component must be created.
3909
3910             --  Reset null_present unconditionally. tagged records always have
3911             --  at least one field (the tag or the parent)
3912
3913             Set_Null_Record_Present (N, False);
3914
3915             --  When the current aggregate comes from the expansion of an
3916             --  extension aggregate, the parent expr is replaced by an
3917             --  aggregate formed by selected components of this expr
3918
3919             if Present (Parent_Expr)
3920               and then Is_Empty_List (Comps)
3921             then
3922                Comp := First_Entity (Typ);
3923                while Present (Comp) loop
3924
3925                   --  Skip all entities that aren't discriminants or components
3926
3927                   if Ekind (Comp) /= E_Discriminant
3928                     and then Ekind (Comp) /= E_Component
3929                   then
3930                      null;
3931
3932                   --  Skip all expander-generated components
3933
3934                   elsif
3935                     not Comes_From_Source (Original_Record_Component (Comp))
3936                   then
3937                      null;
3938
3939                   else
3940                      New_Comp :=
3941                        Make_Selected_Component (Loc,
3942                          Prefix =>
3943                            Unchecked_Convert_To (Typ,
3944                              Duplicate_Subexpr (Parent_Expr, True)),
3945
3946                          Selector_Name => New_Occurrence_Of (Comp, Loc));
3947
3948                      Append_To (Comps,
3949                        Make_Component_Association (Loc,
3950                          Choices    =>
3951                            New_List (New_Occurrence_Of (Comp, Loc)),
3952                          Expression =>
3953                            New_Comp));
3954
3955                      Analyze_And_Resolve (New_Comp, Etype (Comp));
3956                   end if;
3957
3958                   Next_Entity (Comp);
3959                end loop;
3960             end if;
3961
3962             --  Compute the value for the Tag now, if the type is a root it
3963             --  will be included in the aggregate right away, otherwise it will
3964             --  be propagated to the parent aggregate
3965
3966             if Present (Orig_Tag) then
3967                Tag_Value := Orig_Tag;
3968             elsif Java_VM then
3969                Tag_Value := Empty;
3970             else
3971                Tag_Value := New_Occurrence_Of (Access_Disp_Table (Typ), Loc);
3972             end if;
3973
3974             --  For a derived type, an aggregate for the parent is formed with
3975             --  all the inherited components.
3976
3977             if Is_Derived_Type (Typ) then
3978
3979                declare
3980                   First_Comp   : Node_Id;
3981                   Parent_Comps : List_Id;
3982                   Parent_Aggr  : Node_Id;
3983                   Parent_Name  : Node_Id;
3984
3985                begin
3986                   --  Remove the inherited component association from the
3987                   --  aggregate and store them in the parent aggregate
3988
3989                   First_Comp := First (Component_Associations (N));
3990                   Parent_Comps := New_List;
3991
3992                   while Present (First_Comp)
3993                     and then Scope (Original_Record_Component (
3994                             Entity (First (Choices (First_Comp))))) /= Base_Typ
3995                   loop
3996                      Comp := First_Comp;
3997                      Next (First_Comp);
3998                      Remove (Comp);
3999                      Append (Comp, Parent_Comps);
4000                   end loop;
4001
4002                   Parent_Aggr := Make_Aggregate (Loc,
4003                     Component_Associations => Parent_Comps);
4004                   Set_Etype (Parent_Aggr, Etype (Base_Type (Typ)));
4005
4006                   --  Find the _parent component
4007
4008                   Comp := First_Component (Typ);
4009                   while Chars (Comp) /= Name_uParent loop
4010                      Comp := Next_Component (Comp);
4011                   end loop;
4012
4013                   Parent_Name := New_Occurrence_Of (Comp, Loc);
4014
4015                   --  Insert the parent aggregate
4016
4017                   Prepend_To (Component_Associations (N),
4018                     Make_Component_Association (Loc,
4019                       Choices    => New_List (Parent_Name),
4020                       Expression => Parent_Aggr));
4021
4022                   --  Expand recursively the parent propagating the right Tag
4023
4024                   Expand_Record_Aggregate (
4025                     Parent_Aggr, Tag_Value, Parent_Expr);
4026                end;
4027
4028             --  For a root type, the tag component is added (unless compiling
4029             --  for the Java VM, where tags are implicit).
4030
4031             elsif not Java_VM then
4032                declare
4033                   Tag_Name  : constant Node_Id :=
4034                                 New_Occurrence_Of (Tag_Component (Typ), Loc);
4035                   Typ_Tag   : constant Entity_Id := RTE (RE_Tag);
4036                   Conv_Node : constant Node_Id :=
4037                                 Unchecked_Convert_To (Typ_Tag, Tag_Value);
4038
4039                begin
4040                   Set_Etype (Conv_Node, Typ_Tag);
4041                   Prepend_To (Component_Associations (N),
4042                     Make_Component_Association (Loc,
4043                       Choices    => New_List (Tag_Name),
4044                       Expression => Conv_Node));
4045                end;
4046             end if;
4047          end if;
4048       end if;
4049    end Expand_Record_Aggregate;
4050
4051    --------------------------
4052    -- Is_Delayed_Aggregate --
4053    --------------------------
4054
4055    function Is_Delayed_Aggregate (N : Node_Id) return Boolean is
4056       Node : Node_Id := N;
4057       Kind : Node_Kind := Nkind (Node);
4058    begin
4059       if Kind = N_Qualified_Expression then
4060          Node := Expression (Node);
4061          Kind := Nkind (Node);
4062       end if;
4063
4064       if Kind /= N_Aggregate and then Kind /= N_Extension_Aggregate then
4065          return False;
4066       else
4067          return Expansion_Delayed (Node);
4068       end if;
4069    end Is_Delayed_Aggregate;
4070
4071    --------------------
4072    -- Late_Expansion --
4073    --------------------
4074
4075    function Late_Expansion
4076      (N      : Node_Id;
4077       Typ    : Entity_Id;
4078       Target : Node_Id;
4079       Flist  : Node_Id := Empty;
4080       Obj    : Entity_Id := Empty)
4081
4082       return   List_Id is
4083
4084    begin
4085       if Is_Record_Type (Etype (N)) then
4086          return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj);
4087       else
4088          return
4089            Build_Array_Aggr_Code
4090              (N,
4091               First_Index (Typ),
4092               Target,
4093               Is_Scalar_Type (Component_Type (Typ)),
4094               No_List,
4095               Flist);
4096       end if;
4097    end Late_Expansion;
4098
4099    ----------------------------------
4100    -- Make_OK_Assignment_Statement --
4101    ----------------------------------
4102
4103    function Make_OK_Assignment_Statement
4104      (Sloc       : Source_Ptr;
4105       Name       : Node_Id;
4106       Expression : Node_Id)
4107       return       Node_Id
4108    is
4109    begin
4110       Set_Assignment_OK (Name);
4111       return Make_Assignment_Statement (Sloc, Name, Expression);
4112    end Make_OK_Assignment_Statement;
4113
4114    -----------------------
4115    -- Number_Of_Choices --
4116    -----------------------
4117
4118    function Number_Of_Choices (N : Node_Id) return Nat is
4119       Assoc  : Node_Id;
4120       Choice : Node_Id;
4121
4122       Nb_Choices : Nat := 0;
4123
4124    begin
4125       if Present (Expressions (N)) then
4126          return 0;
4127       end if;
4128
4129       Assoc := First (Component_Associations (N));
4130       while Present (Assoc) loop
4131
4132          Choice := First (Choices (Assoc));
4133          while Present (Choice) loop
4134
4135             if Nkind (Choice) /= N_Others_Choice then
4136                Nb_Choices := Nb_Choices + 1;
4137             end if;
4138
4139             Next (Choice);
4140          end loop;
4141
4142          Next (Assoc);
4143       end loop;
4144
4145       return Nb_Choices;
4146    end Number_Of_Choices;
4147
4148    ------------------------------------
4149    -- Packed_Array_Aggregate_Handled --
4150    ------------------------------------
4151
4152    --  The current version of this procedure will handle at compile time
4153    --  any array aggregate that meets these conditions:
4154
4155    --    One dimensional, bit packed
4156    --    Underlying packed type is modular type
4157    --    Bounds are within 32-bit Int range
4158    --    All bounds and values are static
4159
4160    function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is
4161       Loc  : constant Source_Ptr := Sloc (N);
4162       Typ  : constant Entity_Id  := Etype (N);
4163       Ctyp : constant Entity_Id  := Component_Type (Typ);
4164
4165       Not_Handled : exception;
4166       --  Exception raised if this aggregate cannot be handled
4167
4168    begin
4169       --  For now, handle only one dimensional bit packed arrays
4170
4171       if not Is_Bit_Packed_Array (Typ)
4172         or else Number_Dimensions (Typ) > 1
4173         or else not Is_Modular_Integer_Type (Packed_Array_Type (Typ))
4174       then
4175          return False;
4176       end if;
4177
4178       declare
4179          Csiz  : constant Nat := UI_To_Int (Component_Size (Typ));
4180
4181          Lo : Node_Id;
4182          Hi : Node_Id;
4183          --  Bounds of index type
4184
4185          Lob : Uint;
4186          Hib : Uint;
4187          --  Values of bounds if compile time known
4188
4189          function Get_Component_Val (N : Node_Id) return Uint;
4190          --  Given a expression value N of the component type Ctyp, returns
4191          --  A value of Csiz (component size) bits representing this value.
4192          --  If the value is non-static or any other reason exists why the
4193          --  value cannot be returned, then Not_Handled is raised.
4194
4195          -----------------------
4196          -- Get_Component_Val --
4197          -----------------------
4198
4199          function Get_Component_Val (N : Node_Id) return Uint is
4200             Val  : Uint;
4201
4202          begin
4203             --  We have to analyze the expression here before doing any further
4204             --  processing here. The analysis of such expressions is deferred
4205             --  till expansion to prevent some problems of premature analysis.
4206
4207             Analyze_And_Resolve (N, Ctyp);
4208
4209             --  Must have a compile time value
4210
4211             if not Compile_Time_Known_Value (N) then
4212                raise Not_Handled;
4213             end if;
4214
4215             Val := Expr_Rep_Value (N);
4216
4217             --  Adjust for bias, and strip proper number of bits
4218
4219             if Has_Biased_Representation (Ctyp) then
4220                Val := Val - Expr_Value (Type_Low_Bound (Ctyp));
4221             end if;
4222
4223             return Val mod Uint_2 ** Csiz;
4224          end Get_Component_Val;
4225
4226       --  Here we know we have a one dimensional bit packed array
4227
4228       begin
4229          Get_Index_Bounds (First_Index (Typ), Lo, Hi);
4230
4231          --  Cannot do anything if bounds are dynamic
4232
4233          if not Compile_Time_Known_Value (Lo)
4234               or else
4235             not Compile_Time_Known_Value (Hi)
4236          then
4237             return False;
4238          end if;
4239
4240          --  Or are silly out of range of int bounds
4241
4242          Lob := Expr_Value (Lo);
4243          Hib := Expr_Value (Hi);
4244
4245          if not UI_Is_In_Int_Range (Lob)
4246               or else
4247             not UI_Is_In_Int_Range (Hib)
4248          then
4249             return False;
4250          end if;
4251
4252          --  At this stage we have a suitable aggregate for handling
4253          --  at compile time (the only remaining checks, are that the
4254          --  values of expressions in the aggregate are compile time
4255          --  known (check performed by Get_Component_Val), and that
4256          --  any subtypes or ranges are statically known.
4257
4258          --  If the aggregate is not fully positional at this stage,
4259          --  then convert it to positional form. Either this will fail,
4260          --  in which case we can do nothing, or it will succeed, in
4261          --  which case we have succeeded in handling the aggregate,
4262          --  or it will stay an aggregate, in which case we have failed
4263          --  to handle this case.
4264
4265          if Present (Component_Associations (N)) then
4266             Convert_To_Positional
4267              (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
4268             return Nkind (N) /= N_Aggregate;
4269          end if;
4270
4271          --  Otherwise we are all positional, so convert to proper value
4272
4273          declare
4274             Lov : constant Nat := UI_To_Int (Lob);
4275             Hiv : constant Nat := UI_To_Int (Hib);
4276
4277             Len : constant Nat := Int'Max (0, Hiv - Lov + 1);
4278             --  The length of the array (number of elements)
4279
4280             Aggregate_Val : Uint;
4281             --  Value of aggregate. The value is set in the low order
4282             --  bits of this value. For the little-endian case, the
4283             --  values are stored from low-order to high-order and
4284             --  for the big-endian case the values are stored from
4285             --  high-order to low-order. Note that gigi will take care
4286             --  of the conversions to left justify the value in the big
4287             --  endian case (because of left justified modular type
4288             --  processing), so we do not have to worry about that here.
4289
4290             Lit : Node_Id;
4291             --  Integer literal for resulting constructed value
4292
4293             Shift : Nat;
4294             --  Shift count from low order for next value
4295
4296             Incr : Int;
4297             --  Shift increment for loop
4298
4299             Expr : Node_Id;
4300             --  Next expression from positional parameters of aggregate
4301
4302          begin
4303             --  For little endian, we fill up the low order bits of the
4304             --  target value. For big endian we fill up the high order
4305             --  bits of the target value (which is a left justified
4306             --  modular value).
4307
4308             if Bytes_Big_Endian xor Debug_Flag_8 then
4309                Shift := Csiz * (Len - 1);
4310                Incr  := -Csiz;
4311             else
4312                Shift := 0;
4313                Incr  := +Csiz;
4314             end if;
4315
4316             --  Loop to set the values
4317
4318             Aggregate_Val := Uint_0;
4319             Expr := First (Expressions (N));
4320             for J in 1 .. Len loop
4321                Aggregate_Val :=
4322                  Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
4323                Shift := Shift + Incr;
4324                Next (Expr);
4325             end loop;
4326
4327             --  Now we can rewrite with the proper value
4328
4329             Lit :=
4330               Make_Integer_Literal (Loc,
4331                 Intval => Aggregate_Val);
4332             Set_Print_In_Hex (Lit);
4333
4334             --  Construct the expression using this literal. Note that it is
4335             --  important to qualify the literal with its proper modular type
4336             --  since universal integer does not have the required range and
4337             --  also this is a left justified modular type, which is important
4338             --  in the big-endian case.
4339
4340             Rewrite (N,
4341               Unchecked_Convert_To (Typ,
4342                 Make_Qualified_Expression (Loc,
4343                   Subtype_Mark =>
4344                     New_Occurrence_Of (Packed_Array_Type (Typ), Loc),
4345                   Expression   => Lit)));
4346
4347             Analyze_And_Resolve (N, Typ);
4348             return True;
4349          end;
4350       end;
4351
4352    exception
4353       when Not_Handled =>
4354          return False;
4355    end Packed_Array_Aggregate_Handled;
4356
4357    ------------------------------
4358    -- Initialize_Discriminants --
4359    ------------------------------
4360
4361    procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is
4362       Loc  : constant Source_Ptr := Sloc (N);
4363       Bas  : constant Entity_Id  := Base_Type (Typ);
4364       Par  : constant Entity_Id  := Etype (Bas);
4365       Decl : constant Node_Id    := Parent (Par);
4366       Ref  : Node_Id;
4367
4368    begin
4369       if Is_Tagged_Type (Bas)
4370         and then Is_Derived_Type (Bas)
4371         and then Has_Discriminants (Par)
4372         and then Has_Discriminants (Bas)
4373         and then Number_Discriminants (Bas) /= Number_Discriminants (Par)
4374         and then Nkind (Decl) = N_Full_Type_Declaration
4375         and then Nkind (Type_Definition (Decl)) = N_Record_Definition
4376         and then Present
4377           (Variant_Part (Component_List (Type_Definition (Decl))))
4378         and then Nkind (N) /= N_Extension_Aggregate
4379       then
4380
4381          --   Call init_proc to set discriminants.
4382          --   There should eventually be a special procedure for this ???
4383
4384          Ref := New_Reference_To (Defining_Identifier (N), Loc);
4385          Insert_Actions_After (N,
4386            Build_Initialization_Call (Sloc (N), Ref, Typ));
4387       end if;
4388    end Initialize_Discriminants;
4389
4390    ---------------------------
4391    -- Safe_Slice_Assignment --
4392    ---------------------------
4393
4394    function Safe_Slice_Assignment (N : Node_Id) return Boolean is
4395       Loc        : constant Source_Ptr := Sloc (Parent (N));
4396       Pref       : constant Node_Id    := Prefix (Name (Parent (N)));
4397       Range_Node : constant Node_Id    := Discrete_Range (Name (Parent (N)));
4398       Expr       : Node_Id;
4399       L_J        : Entity_Id;
4400       L_Iter     : Node_Id;
4401       L_Body     : Node_Id;
4402       Stat       : Node_Id;
4403
4404    begin
4405       --  Generate: for J in Range loop Pref (J) := Expr; end loop;
4406
4407       if Comes_From_Source (N)
4408         and then No (Expressions (N))
4409         and then Nkind (First (Choices (First (Component_Associations (N)))))
4410                    = N_Others_Choice
4411       then
4412          Expr :=
4413            Expression (First (Component_Associations (N)));
4414          L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
4415
4416          L_Iter :=
4417            Make_Iteration_Scheme (Loc,
4418              Loop_Parameter_Specification =>
4419                Make_Loop_Parameter_Specification
4420                  (Loc,
4421                   Defining_Identifier         => L_J,
4422                   Discrete_Subtype_Definition => Relocate_Node (Range_Node)));
4423
4424          L_Body :=
4425            Make_Assignment_Statement (Loc,
4426               Name =>
4427                 Make_Indexed_Component (Loc,
4428                   Prefix      => Relocate_Node (Pref),
4429                   Expressions => New_List (New_Occurrence_Of (L_J, Loc))),
4430                Expression => Relocate_Node (Expr));
4431
4432          --  Construct the final loop
4433
4434          Stat :=
4435            Make_Implicit_Loop_Statement
4436              (Node             => Parent (N),
4437               Identifier       => Empty,
4438               Iteration_Scheme => L_Iter,
4439               Statements       => New_List (L_Body));
4440
4441          Rewrite (Parent (N), Stat);
4442          Analyze (Parent (N));
4443          return True;
4444
4445       else
4446          return False;
4447       end if;
4448    end Safe_Slice_Assignment;
4449
4450    ---------------------
4451    -- Sort_Case_Table --
4452    ---------------------
4453
4454    procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
4455       L : Int := Case_Table'First;
4456       U : Int := Case_Table'Last;
4457       K : Int;
4458       J : Int;
4459       T : Case_Bounds;
4460
4461    begin
4462       K := L;
4463
4464       while K /= U loop
4465          T := Case_Table (K + 1);
4466          J := K + 1;
4467
4468          while J /= L
4469            and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
4470                     Expr_Value (T.Choice_Lo)
4471          loop
4472             Case_Table (J) := Case_Table (J - 1);
4473             J := J - 1;
4474          end loop;
4475
4476          Case_Table (J) := T;
4477          K := K + 1;
4478       end loop;
4479    end Sort_Case_Table;
4480
4481 end Exp_Aggr;