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