OSDN Git Service

849a7e9227bedf33c8fe7a35474eb2a936efc14b
[pf3gnuchains/gcc-fork.git] / 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-2012, Free Software Foundation, Inc.         --
10 --                                                                          --
11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
12 -- terms of the  GNU General Public License as published  by the Free Soft- --
13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17 -- for  more details.  You should have  received  a copy of the GNU General --
18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
20 --                                                                          --
21 -- GNAT was originally developed  by the GNAT team at  New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
23 --                                                                          --
24 ------------------------------------------------------------------------------
25
26 with Atree;    use Atree;
27 with Checks;   use Checks;
28 with Debug;    use Debug;
29 with Einfo;    use Einfo;
30 with Elists;   use Elists;
31 with Errout;   use Errout;
32 with Expander; use Expander;
33 with Exp_Util; use Exp_Util;
34 with Exp_Ch3;  use Exp_Ch3;
35 with Exp_Ch6;  use Exp_Ch6;
36 with Exp_Ch7;  use Exp_Ch7;
37 with Exp_Ch9;  use Exp_Ch9;
38 with Exp_Disp; use Exp_Disp;
39 with Exp_Tss;  use Exp_Tss;
40 with Fname;    use Fname;
41 with Freeze;   use Freeze;
42 with Itypes;   use Itypes;
43 with Lib;      use Lib;
44 with Namet;    use Namet;
45 with Nmake;    use Nmake;
46 with Nlists;   use Nlists;
47 with Opt;      use Opt;
48 with Restrict; use Restrict;
49 with Rident;   use Rident;
50 with Rtsfind;  use Rtsfind;
51 with Ttypes;   use Ttypes;
52 with Sem;      use Sem;
53 with Sem_Aggr; use Sem_Aggr;
54 with Sem_Aux;  use Sem_Aux;
55 with Sem_Ch3;  use Sem_Ch3;
56 with Sem_Eval; use Sem_Eval;
57 with Sem_Res;  use Sem_Res;
58 with Sem_Util; use Sem_Util;
59 with Sinfo;    use Sinfo;
60 with Snames;   use Snames;
61 with Stand;    use Stand;
62 with Targparm; use Targparm;
63 with Tbuild;   use Tbuild;
64 with Uintp;    use Uintp;
65
66 package body Exp_Aggr is
67
68    type Case_Bounds is record
69      Choice_Lo   : Node_Id;
70      Choice_Hi   : Node_Id;
71      Choice_Node : Node_Id;
72    end record;
73
74    type Case_Table_Type is array (Nat range <>) of Case_Bounds;
75    --  Table type used by Check_Case_Choices procedure
76
77    function Has_Default_Init_Comps (N : Node_Id) return Boolean;
78    --  N is an aggregate (record or array). Checks the presence of default
79    --  initialization (<>) in any component (Ada 2005: AI-287).
80
81    function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean;
82    --  Returns true if N is an aggregate used to initialize the components
83    --  of an statically allocated dispatch table.
84
85    function Must_Slide
86      (Obj_Type : Entity_Id;
87       Typ      : Entity_Id) return Boolean;
88    --  A static array aggregate in an object declaration can in most cases be
89    --  expanded in place. The one exception is when the aggregate is given
90    --  with component associations that specify different bounds from those of
91    --  the type definition in the object declaration. In this pathological
92    --  case the aggregate must slide, and we must introduce an intermediate
93    --  temporary to hold it.
94    --
95    --  The same holds in an assignment to one-dimensional array of arrays,
96    --  when a component may be given with bounds that differ from those of the
97    --  component type.
98
99    procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
100    --  Sort the Case Table using the Lower Bound of each Choice as the key.
101    --  A simple insertion sort is used since the number of choices in a case
102    --  statement of variant part will usually be small and probably in near
103    --  sorted order.
104
105    ------------------------------------------------------
106    -- Local subprograms for Record Aggregate Expansion --
107    ------------------------------------------------------
108
109    function Build_Record_Aggr_Code
110      (N   : Node_Id;
111       Typ : Entity_Id;
112       Lhs : Node_Id) return List_Id;
113    --  N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
114    --  aggregate. Target is an expression containing the location on which the
115    --  component by component assignments will take place. Returns the list of
116    --  assignments plus all other adjustments needed for tagged and controlled
117    --  types.
118
119    procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
120    --  N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
121    --  aggregate (which can only be a record type, this procedure is only used
122    --  for record types). Transform the given aggregate into a sequence of
123    --  assignments performed component by component.
124
125    procedure Expand_Record_Aggregate
126      (N           : Node_Id;
127       Orig_Tag    : Node_Id := Empty;
128       Parent_Expr : Node_Id := Empty);
129    --  This is the top level procedure for record aggregate expansion.
130    --  Expansion for record aggregates needs expand aggregates for tagged
131    --  record types. Specifically Expand_Record_Aggregate adds the Tag
132    --  field in front of the Component_Association list that was created
133    --  during resolution by Resolve_Record_Aggregate.
134    --
135    --    N is the record aggregate node.
136    --    Orig_Tag is the value of the Tag that has to be provided for this
137    --      specific aggregate. It carries the tag corresponding to the type
138    --      of the outermost aggregate during the recursive expansion
139    --    Parent_Expr is the ancestor part of the original extension
140    --      aggregate
141
142    function Has_Mutable_Components (Typ : Entity_Id) return Boolean;
143    --  Return true if one of the component is of a discriminated type with
144    --  defaults. An aggregate for a type with mutable components must be
145    --  expanded into individual assignments.
146
147    procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);
148    --  If the type of the aggregate is a type extension with renamed discrimi-
149    --  nants, we must initialize the hidden discriminants of the parent.
150    --  Otherwise, the target object must not be initialized. The discriminants
151    --  are initialized by calling the initialization procedure for the type.
152    --  This is incorrect if the initialization of other components has any
153    --  side effects. We restrict this call to the case where the parent type
154    --  has a variant part, because this is the only case where the hidden
155    --  discriminants are accessed, namely when calling discriminant checking
156    --  functions of the parent type, and when applying a stream attribute to
157    --  an object of the derived type.
158
159    -----------------------------------------------------
160    -- Local Subprograms for Array Aggregate Expansion --
161    -----------------------------------------------------
162
163    function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean;
164    --  Very large static aggregates present problems to the back-end, and are
165    --  transformed into assignments and loops. This function verifies that the
166    --  total number of components of an aggregate is acceptable for rewriting
167    --  into a purely positional static form. Aggr_Size_OK must be called before
168    --  calling Flatten.
169    --
170    --  This function also detects and warns about one-component aggregates that
171    --  appear in a non-static context. Even if the component value is static,
172    --  such an aggregate must be expanded into an assignment.
173
174    function Backend_Processing_Possible (N : Node_Id) return Boolean;
175    --  This function checks if array aggregate N can be processed directly
176    --  by the backend. If this is the case True is returned.
177
178    function Build_Array_Aggr_Code
179      (N           : Node_Id;
180       Ctype       : Entity_Id;
181       Index       : Node_Id;
182       Into        : Node_Id;
183       Scalar_Comp : Boolean;
184       Indexes     : List_Id := No_List) return List_Id;
185    --  This recursive routine returns a list of statements containing the
186    --  loops and assignments that are needed for the expansion of the array
187    --  aggregate N.
188    --
189    --    N is the (sub-)aggregate node to be expanded into code. This node has
190    --    been fully analyzed, and its Etype is properly set.
191    --
192    --    Index is the index node corresponding to the array sub-aggregate N
193    --
194    --    Into is the target expression into which we are copying the aggregate.
195    --    Note that this node may not have been analyzed yet, and so the Etype
196    --    field may not be set.
197    --
198    --    Scalar_Comp is True if the component type of the aggregate is scalar
199    --
200    --    Indexes is the current list of expressions used to index the object we
201    --    are writing into.
202
203    procedure Convert_Array_Aggr_In_Allocator
204      (Decl   : Node_Id;
205       Aggr   : Node_Id;
206       Target : Node_Id);
207    --  If the aggregate appears within an allocator and can be expanded in
208    --  place, this routine generates the individual assignments to components
209    --  of the designated object. This is an optimization over the general
210    --  case, where a temporary is first created on the stack and then used to
211    --  construct the allocated object on the heap.
212
213    procedure Convert_To_Positional
214      (N                    : Node_Id;
215       Max_Others_Replicate : Nat     := 5;
216       Handle_Bit_Packed    : Boolean := False);
217    --  If possible, convert named notation to positional notation. This
218    --  conversion is possible only in some static cases. If the conversion is
219    --  possible, then N is rewritten with the analyzed converted aggregate.
220    --  The parameter Max_Others_Replicate controls the maximum number of
221    --  values corresponding to an others choice that will be converted to
222    --  positional notation (the default of 5 is the normal limit, and reflects
223    --  the fact that normally the loop is better than a lot of separate
224    --  assignments). Note that this limit gets overridden in any case if
225    --  either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
226    --  set. The parameter Handle_Bit_Packed is usually set False (since we do
227    --  not expect the back end to handle bit packed arrays, so the normal case
228    --  of conversion is pointless), but in the special case of a call from
229    --  Packed_Array_Aggregate_Handled, we set this parameter to True, since
230    --  these are cases we handle in there.
231
232    --  It would seem worthwhile to have a higher default value for Max_Others_
233    --  replicate, but aggregates in the compiler make this impossible: the
234    --  compiler bootstrap fails if Max_Others_Replicate is greater than 25.
235    --  This is unexpected ???
236
237    procedure Expand_Array_Aggregate (N : Node_Id);
238    --  This is the top-level routine to perform array aggregate expansion.
239    --  N is the N_Aggregate node to be expanded.
240
241    function Late_Expansion
242      (N      : Node_Id;
243       Typ    : Entity_Id;
244       Target : Node_Id) return List_Id;
245    --  This routine implements top-down expansion of nested aggregates. In
246    --  doing so, it avoids the generation of temporaries at each level. N is a
247    --  nested (record or array) aggregate that has been marked with Expansion_
248    --  Delayed. Typ is the expected type of the aggregate. Target is a
249    --  (duplicable) expression that will hold the result of the aggregate
250    --  expansion.
251
252    function Make_OK_Assignment_Statement
253      (Sloc       : Source_Ptr;
254       Name       : Node_Id;
255       Expression : Node_Id) return Node_Id;
256    --  This is like Make_Assignment_Statement, except that Assignment_OK
257    --  is set in the left operand. All assignments built by this unit
258    --  use this routine. This is needed to deal with assignments to
259    --  initialized constants that are done in place.
260
261    function Number_Of_Choices (N : Node_Id) return Nat;
262    --  Returns the number of discrete choices (not including the others choice
263    --  if present) contained in (sub-)aggregate N.
264
265    function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
266    --  Given an array aggregate, this function handles the case of a packed
267    --  array aggregate with all constant values, where the aggregate can be
268    --  evaluated at compile time. If this is possible, then N is rewritten
269    --  to be its proper compile time value with all the components properly
270    --  assembled. The expression is analyzed and resolved and True is
271    --  returned. If this transformation is not possible, N is unchanged
272    --  and False is returned
273
274    function Safe_Slice_Assignment (N : Node_Id) return Boolean;
275    --  If a slice assignment has an aggregate with a single others_choice,
276    --  the assignment can be done in place even if bounds are not static,
277    --  by converting it into a loop over the discrete range of the slice.
278
279    ------------------
280    -- Aggr_Size_OK --
281    ------------------
282
283    function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean is
284       Lo   : Node_Id;
285       Hi   : Node_Id;
286       Indx : Node_Id;
287       Siz  : Int;
288       Lov  : Uint;
289       Hiv  : Uint;
290
291       --  The following constant determines the maximum size of an array
292       --  aggregate produced by converting named to positional notation (e.g.
293       --  from others clauses). This avoids running away with attempts to
294       --  convert huge aggregates, which hit memory limits in the backend.
295
296       --  The normal limit is 5000, but we increase this limit to 2**24 (about
297       --  16 million) if Restrictions (No_Elaboration_Code) or Restrictions
298       --  (No_Implicit_Loops) is specified, since in either case, we are at
299       --  risk of declaring the program illegal because of this limit.
300
301       Max_Aggr_Size : constant Nat :=
302                         5000 + (2 ** 24 - 5000) *
303                           Boolean'Pos
304                             (Restriction_Active (No_Elaboration_Code)
305                               or else
306                              Restriction_Active (No_Implicit_Loops));
307
308       function Component_Count (T : Entity_Id) return Int;
309       --  The limit is applied to the total number of components that the
310       --  aggregate will have, which is the number of static expressions
311       --  that will appear in the flattened array. This requires a recursive
312       --  computation of the number of scalar components of the structure.
313
314       ---------------------
315       -- Component_Count --
316       ---------------------
317
318       function Component_Count (T : Entity_Id) return Int is
319          Res  : Int := 0;
320          Comp : Entity_Id;
321
322       begin
323          if Is_Scalar_Type (T) then
324             return 1;
325
326          elsif Is_Record_Type (T) then
327             Comp := First_Component (T);
328             while Present (Comp) loop
329                Res := Res + Component_Count (Etype (Comp));
330                Next_Component (Comp);
331             end loop;
332
333             return Res;
334
335          elsif Is_Array_Type (T) then
336             declare
337                Lo : constant Node_Id :=
338                       Type_Low_Bound (Etype (First_Index (T)));
339                Hi : constant Node_Id :=
340                       Type_High_Bound (Etype (First_Index (T)));
341
342                Siz  : constant Int := Component_Count (Component_Type (T));
343
344             begin
345                if not Compile_Time_Known_Value (Lo)
346                  or else not Compile_Time_Known_Value (Hi)
347                then
348                   return 0;
349                else
350                   return
351                     Siz * UI_To_Int (Expr_Value (Hi) - Expr_Value (Lo) + 1);
352                end if;
353             end;
354
355          else
356             --  Can only be a null for an access type
357
358             return 1;
359          end if;
360       end Component_Count;
361
362    --  Start of processing for Aggr_Size_OK
363
364    begin
365       Siz  := Component_Count (Component_Type (Typ));
366
367       Indx := First_Index (Typ);
368       while Present (Indx) loop
369          Lo  := Type_Low_Bound (Etype (Indx));
370          Hi  := Type_High_Bound (Etype (Indx));
371
372          --  Bounds need to be known at compile time
373
374          if not Compile_Time_Known_Value (Lo)
375            or else not Compile_Time_Known_Value (Hi)
376          then
377             return False;
378          end if;
379
380          Lov := Expr_Value (Lo);
381          Hiv := Expr_Value (Hi);
382
383          --  A flat array is always safe
384
385          if Hiv < Lov then
386             return True;
387          end if;
388
389          --  One-component aggregates are suspicious, and if the context type
390          --  is an object declaration with non-static bounds it will trip gcc;
391          --  such an aggregate must be expanded into a single assignment.
392
393          if Hiv = Lov
394            and then Nkind (Parent (N)) = N_Object_Declaration
395          then
396             declare
397                Index_Type : constant Entity_Id :=
398                               Etype
399                                 (First_Index
400                                    (Etype (Defining_Identifier (Parent (N)))));
401                Indx       : Node_Id;
402
403             begin
404                if not Compile_Time_Known_Value (Type_Low_Bound (Index_Type))
405                   or else not Compile_Time_Known_Value
406                                 (Type_High_Bound (Index_Type))
407                then
408                   if Present (Component_Associations (N)) then
409                      Indx :=
410                        First (Choices (First (Component_Associations (N))));
411                      if Is_Entity_Name (Indx)
412                        and then not Is_Type (Entity (Indx))
413                      then
414                         Error_Msg_N
415                           ("single component aggregate in non-static context?",
416                             Indx);
417                         Error_Msg_N ("\maybe subtype name was meant?", Indx);
418                      end if;
419                   end if;
420
421                   return False;
422                end if;
423             end;
424          end if;
425
426          declare
427             Rng : constant Uint := Hiv - Lov + 1;
428
429          begin
430             --  Check if size is too large
431
432             if not UI_Is_In_Int_Range (Rng) then
433                return False;
434             end if;
435
436             Siz := Siz * UI_To_Int (Rng);
437          end;
438
439          if Siz <= 0
440            or else Siz > Max_Aggr_Size
441          then
442             return False;
443          end if;
444
445          --  Bounds must be in integer range, for later array construction
446
447          if not UI_Is_In_Int_Range (Lov)
448              or else
449             not UI_Is_In_Int_Range (Hiv)
450          then
451             return False;
452          end if;
453
454          Next_Index (Indx);
455       end loop;
456
457       return True;
458    end Aggr_Size_OK;
459
460    ---------------------------------
461    -- Backend_Processing_Possible --
462    ---------------------------------
463
464    --  Backend processing by Gigi/gcc is possible only if all the following
465    --  conditions are met:
466
467    --    1. N is fully positional
468
469    --    2. N is not a bit-packed array aggregate;
470
471    --    3. The size of N's array type must be known at compile time. Note
472    --       that this implies that the component size is also known
473
474    --    4. The array type of N does not follow the Fortran layout convention
475    --       or if it does it must be 1 dimensional.
476
477    --    5. The array component type may not be tagged (which could necessitate
478    --       reassignment of proper tags).
479
480    --    6. The array component type must not have unaligned bit components
481
482    --    7. None of the components of the aggregate may be bit unaligned
483    --       components.
484
485    --    8. There cannot be delayed components, since we do not know enough
486    --       at this stage to know if back end processing is possible.
487
488    --    9. There cannot be any discriminated record components, since the
489    --       back end cannot handle this complex case.
490
491    --   10. No controlled actions need to be generated for components
492
493    --   11. For a VM back end, the array should have no aliased components
494
495    function Backend_Processing_Possible (N : Node_Id) return Boolean is
496       Typ : constant Entity_Id := Etype (N);
497       --  Typ is the correct constrained array subtype of the aggregate
498
499       function Component_Check (N : Node_Id; Index : Node_Id) return Boolean;
500       --  This routine checks components of aggregate N, enforcing checks
501       --  1, 7, 8, and 9. In the multi-dimensional case, these checks are
502       --  performed on subaggregates. The Index value is the current index
503       --  being checked in the multi-dimensional case.
504
505       ---------------------
506       -- Component_Check --
507       ---------------------
508
509       function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is
510          Expr : Node_Id;
511
512       begin
513          --  Checks 1: (no component associations)
514
515          if Present (Component_Associations (N)) then
516             return False;
517          end if;
518
519          --  Checks on components
520
521          --  Recurse to check subaggregates, which may appear in qualified
522          --  expressions. If delayed, the front-end will have to expand.
523          --  If the component is a discriminated record, treat as non-static,
524          --  as the back-end cannot handle this properly.
525
526          Expr := First (Expressions (N));
527          while Present (Expr) loop
528
529             --  Checks 8: (no delayed components)
530
531             if Is_Delayed_Aggregate (Expr) then
532                return False;
533             end if;
534
535             --  Checks 9: (no discriminated records)
536
537             if Present (Etype (Expr))
538               and then Is_Record_Type (Etype (Expr))
539               and then Has_Discriminants (Etype (Expr))
540             then
541                return False;
542             end if;
543
544             --  Checks 7. Component must not be bit aligned component
545
546             if Possible_Bit_Aligned_Component (Expr) then
547                return False;
548             end if;
549
550             --  Recursion to following indexes for multiple dimension case
551
552             if Present (Next_Index (Index))
553                and then not Component_Check (Expr, Next_Index (Index))
554             then
555                return False;
556             end if;
557
558             --  All checks for that component finished, on to next
559
560             Next (Expr);
561          end loop;
562
563          return True;
564       end Component_Check;
565
566    --  Start of processing for Backend_Processing_Possible
567
568    begin
569       --  Checks 2 (array not bit packed) and 10 (no controlled actions)
570
571       if Is_Bit_Packed_Array (Typ) or else Needs_Finalization (Typ) then
572          return False;
573       end if;
574
575       --  If component is limited, aggregate must be expanded because each
576       --  component assignment must be built in place.
577
578       if Is_Immutably_Limited_Type (Component_Type (Typ)) then
579          return False;
580       end if;
581
582       --  Checks 4 (array must not be multi-dimensional Fortran case)
583
584       if Convention (Typ) = Convention_Fortran
585         and then Number_Dimensions (Typ) > 1
586       then
587          return False;
588       end if;
589
590       --  Checks 3 (size of array must be known at compile time)
591
592       if not Size_Known_At_Compile_Time (Typ) then
593          return False;
594       end if;
595
596       --  Checks on components
597
598       if not Component_Check (N, First_Index (Typ)) then
599          return False;
600       end if;
601
602       --  Checks 5 (if the component type is tagged, then we may need to do
603       --    tag adjustments. Perhaps this should be refined to check for any
604       --    component associations that actually need tag adjustment, similar
605       --    to the test in Component_Not_OK_For_Backend for record aggregates
606       --    with tagged components, but not clear whether it's worthwhile ???;
607       --    in the case of the JVM, object tags are handled implicitly)
608
609       if Is_Tagged_Type (Component_Type (Typ))
610         and then Tagged_Type_Expansion
611       then
612          return False;
613       end if;
614
615       --  Checks 6 (component type must not have bit aligned components)
616
617       if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then
618          return False;
619       end if;
620
621       --  Checks 11: Array aggregates with aliased components are currently
622       --  not well supported by the VM backend; disable temporarily this
623       --  backend processing until it is definitely supported.
624
625       if VM_Target /= No_VM
626         and then Has_Aliased_Components (Base_Type (Typ))
627       then
628          return False;
629       end if;
630
631       --  Backend processing is possible
632
633       Set_Size_Known_At_Compile_Time (Etype (N), True);
634       return True;
635    end Backend_Processing_Possible;
636
637    ---------------------------
638    -- Build_Array_Aggr_Code --
639    ---------------------------
640
641    --  The code that we generate from a one dimensional aggregate is
642
643    --  1. If the sub-aggregate contains discrete choices we
644
645    --     (a) Sort the discrete choices
646
647    --     (b) Otherwise for each discrete choice that specifies a range we
648    --         emit a loop. If a range specifies a maximum of three values, or
649    --         we are dealing with an expression we emit a sequence of
650    --         assignments instead of a loop.
651
652    --     (c) Generate the remaining loops to cover the others choice if any
653
654    --  2. If the aggregate contains positional elements we
655
656    --     (a) translate the positional elements in a series of assignments
657
658    --     (b) Generate a final loop to cover the others choice if any.
659    --         Note that this final loop has to be a while loop since the case
660
661    --             L : Integer := Integer'Last;
662    --             H : Integer := Integer'Last;
663    --             A : array (L .. H) := (1, others =>0);
664
665    --         cannot be handled by a for loop. Thus for the following
666
667    --             array (L .. H) := (.. positional elements.., others =>E);
668
669    --         we always generate something like:
670
671    --             J : Index_Type := Index_Of_Last_Positional_Element;
672    --             while J < H loop
673    --                J := Index_Base'Succ (J)
674    --                Tmp (J) := E;
675    --             end loop;
676
677    function Build_Array_Aggr_Code
678      (N           : Node_Id;
679       Ctype       : Entity_Id;
680       Index       : Node_Id;
681       Into        : Node_Id;
682       Scalar_Comp : Boolean;
683       Indexes     : List_Id := No_List) return List_Id
684    is
685       Loc          : constant Source_Ptr := Sloc (N);
686       Index_Base   : constant Entity_Id  := Base_Type (Etype (Index));
687       Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base);
688       Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);
689
690       function Add (Val : Int; To : Node_Id) return Node_Id;
691       --  Returns an expression where Val is added to expression To, unless
692       --  To+Val is provably out of To's base type range. To must be an
693       --  already analyzed expression.
694
695       function Empty_Range (L, H : Node_Id) return Boolean;
696       --  Returns True if the range defined by L .. H is certainly empty
697
698       function Equal (L, H : Node_Id) return Boolean;
699       --  Returns True if L = H for sure
700
701       function Index_Base_Name return Node_Id;
702       --  Returns a new reference to the index type name
703
704       function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
705       --  Ind must be a side-effect free expression. If the input aggregate
706       --  N to Build_Loop contains no sub-aggregates, then this function
707       --  returns the assignment statement:
708       --
709       --     Into (Indexes, Ind) := Expr;
710       --
711       --  Otherwise we call Build_Code recursively
712       --
713       --  Ada 2005 (AI-287): In case of default initialized component, Expr
714       --  is empty and we generate a call to the corresponding IP subprogram.
715
716       function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
717       --  Nodes L and H must be side-effect free expressions.
718       --  If the input aggregate N to Build_Loop contains no sub-aggregates,
719       --  This routine returns the for loop statement
720       --
721       --     for J in Index_Base'(L) .. Index_Base'(H) loop
722       --        Into (Indexes, J) := Expr;
723       --     end loop;
724       --
725       --  Otherwise we call Build_Code recursively.
726       --  As an optimization if the loop covers 3 or less scalar elements we
727       --  generate a sequence of assignments.
728
729       function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
730       --  Nodes L and H must be side-effect free expressions.
731       --  If the input aggregate N to Build_Loop contains no sub-aggregates,
732       --  This routine returns the while loop statement
733       --
734       --     J : Index_Base := L;
735       --     while J < H loop
736       --        J := Index_Base'Succ (J);
737       --        Into (Indexes, J) := Expr;
738       --     end loop;
739       --
740       --  Otherwise we call Build_Code recursively
741
742       function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
743       function Local_Expr_Value               (E : Node_Id) return Uint;
744       --  These two Local routines are used to replace the corresponding ones
745       --  in sem_eval because while processing the bounds of an aggregate with
746       --  discrete choices whose index type is an enumeration, we build static
747       --  expressions not recognized by Compile_Time_Known_Value as such since
748       --  they have not yet been analyzed and resolved. All the expressions in
749       --  question are things like Index_Base_Name'Val (Const) which we can
750       --  easily recognize as being constant.
751
752       ---------
753       -- Add --
754       ---------
755
756       function Add (Val : Int; To : Node_Id) return Node_Id is
757          Expr_Pos : Node_Id;
758          Expr     : Node_Id;
759          To_Pos   : Node_Id;
760          U_To     : Uint;
761          U_Val    : constant Uint := UI_From_Int (Val);
762
763       begin
764          --  Note: do not try to optimize the case of Val = 0, because
765          --  we need to build a new node with the proper Sloc value anyway.
766
767          --  First test if we can do constant folding
768
769          if Local_Compile_Time_Known_Value (To) then
770             U_To := Local_Expr_Value (To) + Val;
771
772             --  Determine if our constant is outside the range of the index.
773             --  If so return an Empty node. This empty node will be caught
774             --  by Empty_Range below.
775
776             if Compile_Time_Known_Value (Index_Base_L)
777               and then U_To < Expr_Value (Index_Base_L)
778             then
779                return Empty;
780
781             elsif Compile_Time_Known_Value (Index_Base_H)
782               and then U_To > Expr_Value (Index_Base_H)
783             then
784                return Empty;
785             end if;
786
787             Expr_Pos := Make_Integer_Literal (Loc, U_To);
788             Set_Is_Static_Expression (Expr_Pos);
789
790             if not Is_Enumeration_Type (Index_Base) then
791                Expr := Expr_Pos;
792
793             --  If we are dealing with enumeration return
794             --     Index_Base'Val (Expr_Pos)
795
796             else
797                Expr :=
798                  Make_Attribute_Reference
799                    (Loc,
800                     Prefix         => Index_Base_Name,
801                     Attribute_Name => Name_Val,
802                     Expressions    => New_List (Expr_Pos));
803             end if;
804
805             return Expr;
806          end if;
807
808          --  If we are here no constant folding possible
809
810          if not Is_Enumeration_Type (Index_Base) then
811             Expr :=
812               Make_Op_Add (Loc,
813                            Left_Opnd  => Duplicate_Subexpr (To),
814                            Right_Opnd => Make_Integer_Literal (Loc, U_Val));
815
816          --  If we are dealing with enumeration return
817          --    Index_Base'Val (Index_Base'Pos (To) + Val)
818
819          else
820             To_Pos :=
821               Make_Attribute_Reference
822                 (Loc,
823                  Prefix         => Index_Base_Name,
824                  Attribute_Name => Name_Pos,
825                  Expressions    => New_List (Duplicate_Subexpr (To)));
826
827             Expr_Pos :=
828               Make_Op_Add (Loc,
829                            Left_Opnd  => To_Pos,
830                            Right_Opnd => Make_Integer_Literal (Loc, U_Val));
831
832             Expr :=
833               Make_Attribute_Reference
834                 (Loc,
835                  Prefix         => Index_Base_Name,
836                  Attribute_Name => Name_Val,
837                  Expressions    => New_List (Expr_Pos));
838          end if;
839
840          return Expr;
841       end Add;
842
843       -----------------
844       -- Empty_Range --
845       -----------------
846
847       function Empty_Range (L, H : Node_Id) return Boolean is
848          Is_Empty : Boolean := False;
849          Low      : Node_Id;
850          High     : Node_Id;
851
852       begin
853          --  First check if L or H were already detected as overflowing the
854          --  index base range type by function Add above. If this is so Add
855          --  returns the empty node.
856
857          if No (L) or else No (H) then
858             return True;
859          end if;
860
861          for J in 1 .. 3 loop
862             case J is
863
864                --  L > H    range is empty
865
866                when 1 =>
867                   Low  := L;
868                   High := H;
869
870                --  B_L > H  range must be empty
871
872                when 2 =>
873                   Low  := Index_Base_L;
874                   High := H;
875
876                --  L > B_H  range must be empty
877
878                when 3 =>
879                   Low  := L;
880                   High := Index_Base_H;
881             end case;
882
883             if Local_Compile_Time_Known_Value (Low)
884               and then Local_Compile_Time_Known_Value (High)
885             then
886                Is_Empty :=
887                  UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High));
888             end if;
889
890             exit when Is_Empty;
891          end loop;
892
893          return Is_Empty;
894       end Empty_Range;
895
896       -----------
897       -- Equal --
898       -----------
899
900       function Equal (L, H : Node_Id) return Boolean is
901       begin
902          if L = H then
903             return True;
904
905          elsif Local_Compile_Time_Known_Value (L)
906            and then Local_Compile_Time_Known_Value (H)
907          then
908             return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H));
909          end if;
910
911          return False;
912       end Equal;
913
914       ----------------
915       -- Gen_Assign --
916       ----------------
917
918       function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
919          L : constant List_Id := New_List;
920          A : Node_Id;
921
922          New_Indexes  : List_Id;
923          Indexed_Comp : Node_Id;
924          Expr_Q       : Node_Id;
925          Comp_Type    : Entity_Id := Empty;
926
927          function Add_Loop_Actions (Lis : List_Id) return List_Id;
928          --  Collect insert_actions generated in the construction of a
929          --  loop, and prepend them to the sequence of assignments to
930          --  complete the eventual body of the loop.
931
932          ----------------------
933          -- Add_Loop_Actions --
934          ----------------------
935
936          function Add_Loop_Actions (Lis : List_Id) return List_Id is
937             Res : List_Id;
938
939          begin
940             --  Ada 2005 (AI-287): Do nothing else in case of default
941             --  initialized component.
942
943             if No (Expr) then
944                return Lis;
945
946             elsif Nkind (Parent (Expr)) = N_Component_Association
947               and then Present (Loop_Actions (Parent (Expr)))
948             then
949                Append_List (Lis, Loop_Actions (Parent (Expr)));
950                Res := Loop_Actions (Parent (Expr));
951                Set_Loop_Actions (Parent (Expr), No_List);
952                return Res;
953
954             else
955                return Lis;
956             end if;
957          end Add_Loop_Actions;
958
959       --  Start of processing for Gen_Assign
960
961       begin
962          if No (Indexes) then
963             New_Indexes := New_List;
964          else
965             New_Indexes := New_Copy_List_Tree (Indexes);
966          end if;
967
968          Append_To (New_Indexes, Ind);
969
970          if Present (Next_Index (Index)) then
971             return
972               Add_Loop_Actions (
973                 Build_Array_Aggr_Code
974                   (N           => Expr,
975                    Ctype       => Ctype,
976                    Index       => Next_Index (Index),
977                    Into        => Into,
978                    Scalar_Comp => Scalar_Comp,
979                    Indexes     => New_Indexes));
980          end if;
981
982          --  If we get here then we are at a bottom-level (sub-)aggregate
983
984          Indexed_Comp :=
985            Checks_Off
986              (Make_Indexed_Component (Loc,
987                 Prefix      => New_Copy_Tree (Into),
988                 Expressions => New_Indexes));
989
990          Set_Assignment_OK (Indexed_Comp);
991
992          --  Ada 2005 (AI-287): In case of default initialized component, Expr
993          --  is not present (and therefore we also initialize Expr_Q to empty).
994
995          if No (Expr) then
996             Expr_Q := Empty;
997          elsif Nkind (Expr) = N_Qualified_Expression then
998             Expr_Q := Expression (Expr);
999          else
1000             Expr_Q := Expr;
1001          end if;
1002
1003          if Present (Etype (N))
1004            and then Etype (N) /= Any_Composite
1005          then
1006             Comp_Type := Component_Type (Etype (N));
1007             pragma Assert (Comp_Type = Ctype); --  AI-287
1008
1009          elsif Present (Next (First (New_Indexes))) then
1010
1011             --  Ada 2005 (AI-287): Do nothing in case of default initialized
1012             --  component because we have received the component type in
1013             --  the formal parameter Ctype.
1014
1015             --  ??? Some assert pragmas have been added to check if this new
1016             --      formal can be used to replace this code in all cases.
1017
1018             if Present (Expr) then
1019
1020                --  This is a multidimensional array. Recover the component
1021                --  type from the outermost aggregate, because subaggregates
1022                --  do not have an assigned type.
1023
1024                declare
1025                   P : Node_Id;
1026
1027                begin
1028                   P := Parent (Expr);
1029                   while Present (P) loop
1030                      if Nkind (P) = N_Aggregate
1031                        and then Present (Etype (P))
1032                      then
1033                         Comp_Type := Component_Type (Etype (P));
1034                         exit;
1035
1036                      else
1037                         P := Parent (P);
1038                      end if;
1039                   end loop;
1040
1041                   pragma Assert (Comp_Type = Ctype); --  AI-287
1042                end;
1043             end if;
1044          end if;
1045
1046          --  Ada 2005 (AI-287): We only analyze the expression in case of non-
1047          --  default initialized components (otherwise Expr_Q is not present).
1048
1049          if Present (Expr_Q)
1050            and then Nkind_In (Expr_Q, N_Aggregate, N_Extension_Aggregate)
1051          then
1052             --  At this stage the Expression may not have been analyzed yet
1053             --  because the array aggregate code has not been updated to use
1054             --  the Expansion_Delayed flag and avoid analysis altogether to
1055             --  solve the same problem (see Resolve_Aggr_Expr). So let us do
1056             --  the analysis of non-array aggregates now in order to get the
1057             --  value of Expansion_Delayed flag for the inner aggregate ???
1058
1059             if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then
1060                Analyze_And_Resolve (Expr_Q, Comp_Type);
1061             end if;
1062
1063             if Is_Delayed_Aggregate (Expr_Q) then
1064
1065                --  This is either a subaggregate of a multidimensional array,
1066                --  or a component of an array type whose component type is
1067                --  also an array. In the latter case, the expression may have
1068                --  component associations that provide different bounds from
1069                --  those of the component type, and sliding must occur. Instead
1070                --  of decomposing the current aggregate assignment, force the
1071                --  re-analysis of the assignment, so that a temporary will be
1072                --  generated in the usual fashion, and sliding will take place.
1073
1074                if Nkind (Parent (N)) = N_Assignment_Statement
1075                  and then Is_Array_Type (Comp_Type)
1076                  and then Present (Component_Associations (Expr_Q))
1077                  and then Must_Slide (Comp_Type, Etype (Expr_Q))
1078                then
1079                   Set_Expansion_Delayed (Expr_Q, False);
1080                   Set_Analyzed (Expr_Q, False);
1081
1082                else
1083                   return
1084                     Add_Loop_Actions (
1085                       Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp));
1086                end if;
1087             end if;
1088          end if;
1089
1090          --  Ada 2005 (AI-287): In case of default initialized component, call
1091          --  the initialization subprogram associated with the component type.
1092          --  If the component type is an access type, add an explicit null
1093          --  assignment, because for the back-end there is an initialization
1094          --  present for the whole aggregate, and no default initialization
1095          --  will take place.
1096
1097          --  In addition, if the component type is controlled, we must call
1098          --  its Initialize procedure explicitly, because there is no explicit
1099          --  object creation that will invoke it otherwise.
1100
1101          if No (Expr) then
1102             if Present (Base_Init_Proc (Base_Type (Ctype)))
1103               or else Has_Task (Base_Type (Ctype))
1104             then
1105                Append_List_To (L,
1106                  Build_Initialization_Call (Loc,
1107                    Id_Ref            => Indexed_Comp,
1108                    Typ               => Ctype,
1109                    With_Default_Init => True));
1110
1111             elsif Is_Access_Type (Ctype) then
1112                Append_To (L,
1113                   Make_Assignment_Statement (Loc,
1114                      Name => Indexed_Comp,
1115                      Expression => Make_Null (Loc)));
1116             end if;
1117
1118             if Needs_Finalization (Ctype) then
1119                Append_To (L,
1120                  Make_Init_Call (
1121                    Obj_Ref => New_Copy_Tree (Indexed_Comp),
1122                    Typ     => Ctype));
1123             end if;
1124
1125          else
1126             --  Now generate the assignment with no associated controlled
1127             --  actions since the target of the assignment may not have been
1128             --  initialized, it is not possible to Finalize it as expected by
1129             --  normal controlled assignment. The rest of the controlled
1130             --  actions are done manually with the proper finalization list
1131             --  coming from the context.
1132
1133             A :=
1134               Make_OK_Assignment_Statement (Loc,
1135                 Name       => Indexed_Comp,
1136                 Expression => New_Copy_Tree (Expr));
1137
1138             if Present (Comp_Type) and then Needs_Finalization (Comp_Type) then
1139                Set_No_Ctrl_Actions (A);
1140
1141                --  If this is an aggregate for an array of arrays, each
1142                --  sub-aggregate will be expanded as well, and even with
1143                --  No_Ctrl_Actions the assignments of inner components will
1144                --  require attachment in their assignments to temporaries.
1145                --  These temporaries must be finalized for each subaggregate,
1146                --  to prevent multiple attachments of the same temporary
1147                --  location to same finalization chain (and consequently
1148                --  circular lists). To ensure that finalization takes place
1149                --  for each subaggregate we wrap the assignment in a block.
1150
1151                if Is_Array_Type (Comp_Type)
1152                  and then Nkind (Expr) = N_Aggregate
1153                then
1154                   A :=
1155                     Make_Block_Statement (Loc,
1156                       Handled_Statement_Sequence =>
1157                         Make_Handled_Sequence_Of_Statements (Loc,
1158                            Statements => New_List (A)));
1159                end if;
1160             end if;
1161
1162             Append_To (L, A);
1163
1164             --  Adjust the tag if tagged (because of possible view
1165             --  conversions), unless compiling for a VM where
1166             --  tags are implicit.
1167
1168             if Present (Comp_Type)
1169               and then Is_Tagged_Type (Comp_Type)
1170               and then Tagged_Type_Expansion
1171             then
1172                declare
1173                   Full_Typ : constant Entity_Id := Underlying_Type (Comp_Type);
1174
1175                begin
1176                   A :=
1177                     Make_OK_Assignment_Statement (Loc,
1178                       Name =>
1179                         Make_Selected_Component (Loc,
1180                           Prefix =>  New_Copy_Tree (Indexed_Comp),
1181                           Selector_Name =>
1182                             New_Reference_To
1183                               (First_Tag_Component (Full_Typ), Loc)),
1184
1185                       Expression =>
1186                         Unchecked_Convert_To (RTE (RE_Tag),
1187                           New_Reference_To
1188                             (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
1189                              Loc)));
1190
1191                   Append_To (L, A);
1192                end;
1193             end if;
1194
1195             --  Adjust and attach the component to the proper final list, which
1196             --  can be the controller of the outer record object or the final
1197             --  list associated with the scope.
1198
1199             --  If the component is itself an array of controlled types, whose
1200             --  value is given by a sub-aggregate, then the attach calls have
1201             --  been generated when individual subcomponent are assigned, and
1202             --  must not be done again to prevent malformed finalization chains
1203             --  (see comments above, concerning the creation of a block to hold
1204             --  inner finalization actions).
1205
1206             if Present (Comp_Type)
1207               and then Needs_Finalization (Comp_Type)
1208               and then not Is_Limited_Type (Comp_Type)
1209               and then not
1210                 (Is_Array_Type (Comp_Type)
1211                    and then Is_Controlled (Component_Type (Comp_Type))
1212                    and then Nkind (Expr) = N_Aggregate)
1213             then
1214                Append_To (L,
1215                  Make_Adjust_Call (
1216                    Obj_Ref => New_Copy_Tree (Indexed_Comp),
1217                    Typ     => Comp_Type));
1218             end if;
1219          end if;
1220
1221          return Add_Loop_Actions (L);
1222       end Gen_Assign;
1223
1224       --------------
1225       -- Gen_Loop --
1226       --------------
1227
1228       function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
1229          L_J : Node_Id;
1230
1231          L_L : Node_Id;
1232          --  Index_Base'(L)
1233
1234          L_H : Node_Id;
1235          --  Index_Base'(H)
1236
1237          L_Range : Node_Id;
1238          --  Index_Base'(L) .. Index_Base'(H)
1239
1240          L_Iteration_Scheme : Node_Id;
1241          --  L_J in Index_Base'(L) .. Index_Base'(H)
1242
1243          L_Body : List_Id;
1244          --  The statements to execute in the loop
1245
1246          S : constant List_Id := New_List;
1247          --  List of statements
1248
1249          Tcopy : Node_Id;
1250          --  Copy of expression tree, used for checking purposes
1251
1252       begin
1253          --  If loop bounds define an empty range return the null statement
1254
1255          if Empty_Range (L, H) then
1256             Append_To (S, Make_Null_Statement (Loc));
1257
1258             --  Ada 2005 (AI-287): Nothing else need to be done in case of
1259             --  default initialized component.
1260
1261             if No (Expr) then
1262                null;
1263
1264             else
1265                --  The expression must be type-checked even though no component
1266                --  of the aggregate will have this value. This is done only for
1267                --  actual components of the array, not for subaggregates. Do
1268                --  the check on a copy, because the expression may be shared
1269                --  among several choices, some of which might be non-null.
1270
1271                if Present (Etype (N))
1272                  and then Is_Array_Type (Etype (N))
1273                  and then No (Next_Index (Index))
1274                then
1275                   Expander_Mode_Save_And_Set (False);
1276                   Tcopy := New_Copy_Tree (Expr);
1277                   Set_Parent (Tcopy, N);
1278                   Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
1279                   Expander_Mode_Restore;
1280                end if;
1281             end if;
1282
1283             return S;
1284
1285          --  If loop bounds are the same then generate an assignment
1286
1287          elsif Equal (L, H) then
1288             return Gen_Assign (New_Copy_Tree (L), Expr);
1289
1290          --  If H - L <= 2 then generate a sequence of assignments when we are
1291          --  processing the bottom most aggregate and it contains scalar
1292          --  components.
1293
1294          elsif No (Next_Index (Index))
1295            and then Scalar_Comp
1296            and then Local_Compile_Time_Known_Value (L)
1297            and then Local_Compile_Time_Known_Value (H)
1298            and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
1299          then
1300
1301             Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
1302             Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
1303
1304             if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then
1305                Append_List_To (S, Gen_Assign (Add (2, To => L), Expr));
1306             end if;
1307
1308             return S;
1309          end if;
1310
1311          --  Otherwise construct the loop, starting with the loop index L_J
1312
1313          L_J := Make_Temporary (Loc, 'J', L);
1314
1315          --  Construct "L .. H" in Index_Base. We use a qualified expression
1316          --  for the bound to convert to the index base, but we don't need
1317          --  to do that if we already have the base type at hand.
1318
1319          if Etype (L) = Index_Base then
1320             L_L := L;
1321          else
1322             L_L :=
1323               Make_Qualified_Expression (Loc,
1324                 Subtype_Mark => Index_Base_Name,
1325                 Expression   => L);
1326          end if;
1327
1328          if Etype (H) = Index_Base then
1329             L_H := H;
1330          else
1331             L_H :=
1332               Make_Qualified_Expression (Loc,
1333                 Subtype_Mark => Index_Base_Name,
1334                 Expression   => H);
1335          end if;
1336
1337          L_Range :=
1338            Make_Range (Loc,
1339              Low_Bound => L_L,
1340              High_Bound => L_H);
1341
1342          --  Construct "for L_J in Index_Base range L .. H"
1343
1344          L_Iteration_Scheme :=
1345            Make_Iteration_Scheme
1346              (Loc,
1347               Loop_Parameter_Specification =>
1348                 Make_Loop_Parameter_Specification
1349                   (Loc,
1350                    Defining_Identifier         => L_J,
1351                    Discrete_Subtype_Definition => L_Range));
1352
1353          --  Construct the statements to execute in the loop body
1354
1355          L_Body := Gen_Assign (New_Reference_To (L_J, Loc), Expr);
1356
1357          --  Construct the final loop
1358
1359          Append_To (S, Make_Implicit_Loop_Statement
1360                          (Node             => N,
1361                           Identifier       => Empty,
1362                           Iteration_Scheme => L_Iteration_Scheme,
1363                           Statements       => L_Body));
1364
1365          --  A small optimization: if the aggregate is initialized with a box
1366          --  and the component type has no initialization procedure, remove the
1367          --  useless empty loop.
1368
1369          if Nkind (First (S)) = N_Loop_Statement
1370            and then Is_Empty_List (Statements (First (S)))
1371          then
1372             return New_List (Make_Null_Statement (Loc));
1373          else
1374             return S;
1375          end if;
1376       end Gen_Loop;
1377
1378       ---------------
1379       -- Gen_While --
1380       ---------------
1381
1382       --  The code built is
1383
1384       --     W_J : Index_Base := L;
1385       --     while W_J < H loop
1386       --        W_J := Index_Base'Succ (W);
1387       --        L_Body;
1388       --     end loop;
1389
1390       function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is
1391          W_J : Node_Id;
1392
1393          W_Decl : Node_Id;
1394          --  W_J : Base_Type := L;
1395
1396          W_Iteration_Scheme : Node_Id;
1397          --  while W_J < H
1398
1399          W_Index_Succ : Node_Id;
1400          --  Index_Base'Succ (J)
1401
1402          W_Increment : Node_Id;
1403          --  W_J := Index_Base'Succ (W)
1404
1405          W_Body : constant List_Id := New_List;
1406          --  The statements to execute in the loop
1407
1408          S : constant List_Id := New_List;
1409          --  list of statement
1410
1411       begin
1412          --  If loop bounds define an empty range or are equal return null
1413
1414          if Empty_Range (L, H) or else Equal (L, H) then
1415             Append_To (S, Make_Null_Statement (Loc));
1416             return S;
1417          end if;
1418
1419          --  Build the decl of W_J
1420
1421          W_J    := Make_Temporary (Loc, 'J', L);
1422          W_Decl :=
1423            Make_Object_Declaration
1424              (Loc,
1425               Defining_Identifier => W_J,
1426               Object_Definition   => Index_Base_Name,
1427               Expression          => L);
1428
1429          --  Theoretically we should do a New_Copy_Tree (L) here, but we know
1430          --  that in this particular case L is a fresh Expr generated by
1431          --  Add which we are the only ones to use.
1432
1433          Append_To (S, W_Decl);
1434
1435          --  Construct " while W_J < H"
1436
1437          W_Iteration_Scheme :=
1438            Make_Iteration_Scheme
1439              (Loc,
1440               Condition => Make_Op_Lt
1441                              (Loc,
1442                               Left_Opnd  => New_Reference_To (W_J, Loc),
1443                               Right_Opnd => New_Copy_Tree (H)));
1444
1445          --  Construct the statements to execute in the loop body
1446
1447          W_Index_Succ :=
1448            Make_Attribute_Reference
1449              (Loc,
1450               Prefix         => Index_Base_Name,
1451               Attribute_Name => Name_Succ,
1452               Expressions    => New_List (New_Reference_To (W_J, Loc)));
1453
1454          W_Increment  :=
1455            Make_OK_Assignment_Statement
1456              (Loc,
1457               Name       => New_Reference_To (W_J, Loc),
1458               Expression => W_Index_Succ);
1459
1460          Append_To (W_Body, W_Increment);
1461          Append_List_To (W_Body,
1462            Gen_Assign (New_Reference_To (W_J, Loc), Expr));
1463
1464          --  Construct the final loop
1465
1466          Append_To (S, Make_Implicit_Loop_Statement
1467                          (Node             => N,
1468                           Identifier       => Empty,
1469                           Iteration_Scheme => W_Iteration_Scheme,
1470                           Statements       => W_Body));
1471
1472          return S;
1473       end Gen_While;
1474
1475       ---------------------
1476       -- Index_Base_Name --
1477       ---------------------
1478
1479       function Index_Base_Name return Node_Id is
1480       begin
1481          return New_Reference_To (Index_Base, Sloc (N));
1482       end Index_Base_Name;
1483
1484       ------------------------------------
1485       -- Local_Compile_Time_Known_Value --
1486       ------------------------------------
1487
1488       function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is
1489       begin
1490          return Compile_Time_Known_Value (E)
1491            or else
1492              (Nkind (E) = N_Attribute_Reference
1493                and then Attribute_Name (E) = Name_Val
1494                and then Compile_Time_Known_Value (First (Expressions (E))));
1495       end Local_Compile_Time_Known_Value;
1496
1497       ----------------------
1498       -- Local_Expr_Value --
1499       ----------------------
1500
1501       function Local_Expr_Value (E : Node_Id) return Uint is
1502       begin
1503          if Compile_Time_Known_Value (E) then
1504             return Expr_Value (E);
1505          else
1506             return Expr_Value (First (Expressions (E)));
1507          end if;
1508       end Local_Expr_Value;
1509
1510       --  Build_Array_Aggr_Code Variables
1511
1512       Assoc  : Node_Id;
1513       Choice : Node_Id;
1514       Expr   : Node_Id;
1515       Typ    : Entity_Id;
1516
1517       Others_Expr        : Node_Id := Empty;
1518       Others_Box_Present : Boolean := False;
1519
1520       Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
1521       Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
1522       --  The aggregate bounds of this specific sub-aggregate. Note that if
1523       --  the code generated by Build_Array_Aggr_Code is executed then these
1524       --  bounds are OK. Otherwise a Constraint_Error would have been raised.
1525
1526       Aggr_Low  : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L);
1527       Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
1528       --  After Duplicate_Subexpr these are side-effect free
1529
1530       Low        : Node_Id;
1531       High       : Node_Id;
1532
1533       Nb_Choices : Nat := 0;
1534       Table      : Case_Table_Type (1 .. Number_Of_Choices (N));
1535       --  Used to sort all the different choice values
1536
1537       Nb_Elements : Int;
1538       --  Number of elements in the positional aggregate
1539
1540       New_Code : constant List_Id := New_List;
1541
1542    --  Start of processing for Build_Array_Aggr_Code
1543
1544    begin
1545       --  First before we start, a special case. if we have a bit packed
1546       --  array represented as a modular type, then clear the value to
1547       --  zero first, to ensure that unused bits are properly cleared.
1548
1549       Typ := Etype (N);
1550
1551       if Present (Typ)
1552         and then Is_Bit_Packed_Array (Typ)
1553         and then Is_Modular_Integer_Type (Packed_Array_Type (Typ))
1554       then
1555          Append_To (New_Code,
1556            Make_Assignment_Statement (Loc,
1557              Name => New_Copy_Tree (Into),
1558              Expression =>
1559                Unchecked_Convert_To (Typ,
1560                  Make_Integer_Literal (Loc, Uint_0))));
1561       end if;
1562
1563       --  If the component type contains tasks, we need to build a Master
1564       --  entity in the current scope, because it will be needed if build-
1565       --  in-place functions are called in the expanded code.
1566
1567       if Nkind (Parent (N)) = N_Object_Declaration
1568         and then Has_Task (Typ)
1569       then
1570          Build_Master_Entity (Defining_Identifier (Parent (N)));
1571       end if;
1572
1573       --  STEP 1: Process component associations
1574
1575       --  For those associations that may generate a loop, initialize
1576       --  Loop_Actions to collect inserted actions that may be crated.
1577
1578       --  Skip this if no component associations
1579
1580       if No (Expressions (N)) then
1581
1582          --  STEP 1 (a): Sort the discrete choices
1583
1584          Assoc := First (Component_Associations (N));
1585          while Present (Assoc) loop
1586             Choice := First (Choices (Assoc));
1587             while Present (Choice) loop
1588                if Nkind (Choice) = N_Others_Choice then
1589                   Set_Loop_Actions (Assoc, New_List);
1590
1591                   if Box_Present (Assoc) then
1592                      Others_Box_Present := True;
1593                   else
1594                      Others_Expr := Expression (Assoc);
1595                   end if;
1596                   exit;
1597                end if;
1598
1599                Get_Index_Bounds (Choice, Low, High);
1600
1601                if Low /= High then
1602                   Set_Loop_Actions (Assoc, New_List);
1603                end if;
1604
1605                Nb_Choices := Nb_Choices + 1;
1606                if Box_Present (Assoc) then
1607                   Table (Nb_Choices) := (Choice_Lo   => Low,
1608                                          Choice_Hi   => High,
1609                                          Choice_Node => Empty);
1610                else
1611                   Table (Nb_Choices) := (Choice_Lo   => Low,
1612                                          Choice_Hi   => High,
1613                                          Choice_Node => Expression (Assoc));
1614                end if;
1615                Next (Choice);
1616             end loop;
1617
1618             Next (Assoc);
1619          end loop;
1620
1621          --  If there is more than one set of choices these must be static
1622          --  and we can therefore sort them. Remember that Nb_Choices does not
1623          --  account for an others choice.
1624
1625          if Nb_Choices > 1 then
1626             Sort_Case_Table (Table);
1627          end if;
1628
1629          --  STEP 1 (b):  take care of the whole set of discrete choices
1630
1631          for J in 1 .. Nb_Choices loop
1632             Low  := Table (J).Choice_Lo;
1633             High := Table (J).Choice_Hi;
1634             Expr := Table (J).Choice_Node;
1635             Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
1636          end loop;
1637
1638          --  STEP 1 (c): generate the remaining loops to cover others choice
1639          --  We don't need to generate loops over empty gaps, but if there is
1640          --  a single empty range we must analyze the expression for semantics
1641
1642          if Present (Others_Expr) or else Others_Box_Present then
1643             declare
1644                First : Boolean := True;
1645
1646             begin
1647                for J in 0 .. Nb_Choices loop
1648                   if J = 0 then
1649                      Low := Aggr_Low;
1650                   else
1651                      Low := Add (1, To => Table (J).Choice_Hi);
1652                   end if;
1653
1654                   if J = Nb_Choices then
1655                      High := Aggr_High;
1656                   else
1657                      High := Add (-1, To => Table (J + 1).Choice_Lo);
1658                   end if;
1659
1660                   --  If this is an expansion within an init proc, make
1661                   --  sure that discriminant references are replaced by
1662                   --  the corresponding discriminal.
1663
1664                   if Inside_Init_Proc then
1665                      if Is_Entity_Name (Low)
1666                        and then Ekind (Entity (Low)) = E_Discriminant
1667                      then
1668                         Set_Entity (Low, Discriminal (Entity (Low)));
1669                      end if;
1670
1671                      if Is_Entity_Name (High)
1672                        and then Ekind (Entity (High)) = E_Discriminant
1673                      then
1674                         Set_Entity (High, Discriminal (Entity (High)));
1675                      end if;
1676                   end if;
1677
1678                   if First
1679                     or else not Empty_Range (Low, High)
1680                   then
1681                      First := False;
1682                      Append_List
1683                        (Gen_Loop (Low, High, Others_Expr), To => New_Code);
1684                   end if;
1685                end loop;
1686             end;
1687          end if;
1688
1689       --  STEP 2: Process positional components
1690
1691       else
1692          --  STEP 2 (a): Generate the assignments for each positional element
1693          --  Note that here we have to use Aggr_L rather than Aggr_Low because
1694          --  Aggr_L is analyzed and Add wants an analyzed expression.
1695
1696          Expr        := First (Expressions (N));
1697          Nb_Elements := -1;
1698          while Present (Expr) loop
1699             Nb_Elements := Nb_Elements + 1;
1700             Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr),
1701                          To => New_Code);
1702             Next (Expr);
1703          end loop;
1704
1705          --  STEP 2 (b): Generate final loop if an others choice is present
1706          --  Here Nb_Elements gives the offset of the last positional element.
1707
1708          if Present (Component_Associations (N)) then
1709             Assoc := Last (Component_Associations (N));
1710
1711             --  Ada 2005 (AI-287)
1712
1713             if Box_Present (Assoc) then
1714                Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1715                                        Aggr_High,
1716                                        Empty),
1717                             To => New_Code);
1718             else
1719                Expr  := Expression (Assoc);
1720
1721                Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1722                                        Aggr_High,
1723                                        Expr), --  AI-287
1724                             To => New_Code);
1725             end if;
1726          end if;
1727       end if;
1728
1729       return New_Code;
1730    end Build_Array_Aggr_Code;
1731
1732    ----------------------------
1733    -- Build_Record_Aggr_Code --
1734    ----------------------------
1735
1736    function Build_Record_Aggr_Code
1737      (N   : Node_Id;
1738       Typ : Entity_Id;
1739       Lhs : Node_Id) return List_Id
1740    is
1741       Loc     : constant Source_Ptr := Sloc (N);
1742       L       : constant List_Id    := New_List;
1743       N_Typ   : constant Entity_Id  := Etype (N);
1744
1745       Comp      : Node_Id;
1746       Instr     : Node_Id;
1747       Ref       : Node_Id;
1748       Target    : Entity_Id;
1749       Comp_Type : Entity_Id;
1750       Selector  : Entity_Id;
1751       Comp_Expr : Node_Id;
1752       Expr_Q    : Node_Id;
1753
1754       --  If this is an internal aggregate, the External_Final_List is an
1755       --  expression for the controller record of the enclosing type.
1756
1757       --  If the current aggregate has several controlled components, this
1758       --  expression will appear in several calls to attach to the finali-
1759       --  zation list, and it must not be shared.
1760
1761       Ancestor_Is_Expression   : Boolean := False;
1762       Ancestor_Is_Subtype_Mark : Boolean := False;
1763
1764       Init_Typ : Entity_Id := Empty;
1765
1766       Finalization_Done : Boolean := False;
1767       --  True if Generate_Finalization_Actions has already been called; calls
1768       --  after the first do nothing.
1769
1770       function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
1771       --  Returns the value that the given discriminant of an ancestor type
1772       --  should receive (in the absence of a conflict with the value provided
1773       --  by an ancestor part of an extension aggregate).
1774
1775       procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id);
1776       --  Check that each of the discriminant values defined by the ancestor
1777       --  part of an extension aggregate match the corresponding values
1778       --  provided by either an association of the aggregate or by the
1779       --  constraint imposed by a parent type (RM95-4.3.2(8)).
1780
1781       function Compatible_Int_Bounds
1782         (Agg_Bounds : Node_Id;
1783          Typ_Bounds : Node_Id) return Boolean;
1784       --  Return true if Agg_Bounds are equal or within Typ_Bounds. It is
1785       --  assumed that both bounds are integer ranges.
1786
1787       procedure Generate_Finalization_Actions;
1788       --  Deal with the various controlled type data structure initializations
1789       --  (but only if it hasn't been done already).
1790
1791       function Get_Constraint_Association (T : Entity_Id) return Node_Id;
1792       --  Returns the first discriminant association in the constraint
1793       --  associated with T, if any, otherwise returns Empty.
1794
1795       procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id);
1796       --  If Typ is derived, and constrains discriminants of the parent type,
1797       --  these discriminants are not components of the aggregate, and must be
1798       --  initialized. The assignments are appended to List.
1799
1800       function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
1801       --  Check whether Bounds is a range node and its lower and higher bounds
1802       --  are integers literals.
1803
1804       ---------------------------------
1805       -- Ancestor_Discriminant_Value --
1806       ---------------------------------
1807
1808       function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is
1809          Assoc        : Node_Id;
1810          Assoc_Elmt   : Elmt_Id;
1811          Aggr_Comp    : Entity_Id;
1812          Corresp_Disc : Entity_Id;
1813          Current_Typ  : Entity_Id := Base_Type (Typ);
1814          Parent_Typ   : Entity_Id;
1815          Parent_Disc  : Entity_Id;
1816          Save_Assoc   : Node_Id := Empty;
1817
1818       begin
1819          --  First check any discriminant associations to see if any of them
1820          --  provide a value for the discriminant.
1821
1822          if Present (Discriminant_Specifications (Parent (Current_Typ))) then
1823             Assoc := First (Component_Associations (N));
1824             while Present (Assoc) loop
1825                Aggr_Comp := Entity (First (Choices (Assoc)));
1826
1827                if Ekind (Aggr_Comp) = E_Discriminant then
1828                   Save_Assoc := Expression (Assoc);
1829
1830                   Corresp_Disc := Corresponding_Discriminant (Aggr_Comp);
1831                   while Present (Corresp_Disc) loop
1832
1833                      --  If found a corresponding discriminant then return the
1834                      --  value given in the aggregate. (Note: this is not
1835                      --  correct in the presence of side effects. ???)
1836
1837                      if Disc = Corresp_Disc then
1838                         return Duplicate_Subexpr (Expression (Assoc));
1839                      end if;
1840
1841                      Corresp_Disc :=
1842                        Corresponding_Discriminant (Corresp_Disc);
1843                   end loop;
1844                end if;
1845
1846                Next (Assoc);
1847             end loop;
1848          end if;
1849
1850          --  No match found in aggregate, so chain up parent types to find
1851          --  a constraint that defines the value of the discriminant.
1852
1853          Parent_Typ := Etype (Current_Typ);
1854          while Current_Typ /= Parent_Typ loop
1855             if Has_Discriminants (Parent_Typ)
1856               and then not Has_Unknown_Discriminants (Parent_Typ)
1857             then
1858                Parent_Disc := First_Discriminant (Parent_Typ);
1859
1860                --  We either get the association from the subtype indication
1861                --  of the type definition itself, or from the discriminant
1862                --  constraint associated with the type entity (which is
1863                --  preferable, but it's not always present ???)
1864
1865                if Is_Empty_Elmt_List (
1866                  Discriminant_Constraint (Current_Typ))
1867                then
1868                   Assoc := Get_Constraint_Association (Current_Typ);
1869                   Assoc_Elmt := No_Elmt;
1870                else
1871                   Assoc_Elmt :=
1872                     First_Elmt (Discriminant_Constraint (Current_Typ));
1873                   Assoc := Node (Assoc_Elmt);
1874                end if;
1875
1876                --  Traverse the discriminants of the parent type looking
1877                --  for one that corresponds.
1878
1879                while Present (Parent_Disc) and then Present (Assoc) loop
1880                   Corresp_Disc := Parent_Disc;
1881                   while Present (Corresp_Disc)
1882                     and then Disc /= Corresp_Disc
1883                   loop
1884                      Corresp_Disc :=
1885                        Corresponding_Discriminant (Corresp_Disc);
1886                   end loop;
1887
1888                   if Disc = Corresp_Disc then
1889                      if Nkind (Assoc) = N_Discriminant_Association then
1890                         Assoc := Expression (Assoc);
1891                      end if;
1892
1893                      --  If the located association directly denotes a
1894                      --  discriminant, then use the value of a saved
1895                      --  association of the aggregate. This is a kludge to
1896                      --  handle certain cases involving multiple discriminants
1897                      --  mapped to a single discriminant of a descendant. It's
1898                      --  not clear how to locate the appropriate discriminant
1899                      --  value for such cases. ???
1900
1901                      if Is_Entity_Name (Assoc)
1902                        and then Ekind (Entity (Assoc)) = E_Discriminant
1903                      then
1904                         Assoc := Save_Assoc;
1905                      end if;
1906
1907                      return Duplicate_Subexpr (Assoc);
1908                   end if;
1909
1910                   Next_Discriminant (Parent_Disc);
1911
1912                   if No (Assoc_Elmt) then
1913                      Next (Assoc);
1914                   else
1915                      Next_Elmt (Assoc_Elmt);
1916                      if Present (Assoc_Elmt) then
1917                         Assoc := Node (Assoc_Elmt);
1918                      else
1919                         Assoc := Empty;
1920                      end if;
1921                   end if;
1922                end loop;
1923             end if;
1924
1925             Current_Typ := Parent_Typ;
1926             Parent_Typ := Etype (Current_Typ);
1927          end loop;
1928
1929          --  In some cases there's no ancestor value to locate (such as
1930          --  when an ancestor part given by an expression defines the
1931          --  discriminant value).
1932
1933          return Empty;
1934       end Ancestor_Discriminant_Value;
1935
1936       ----------------------------------
1937       -- Check_Ancestor_Discriminants --
1938       ----------------------------------
1939
1940       procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is
1941          Discr      : Entity_Id;
1942          Disc_Value : Node_Id;
1943          Cond       : Node_Id;
1944
1945       begin
1946          Discr := First_Discriminant (Base_Type (Anc_Typ));
1947          while Present (Discr) loop
1948             Disc_Value := Ancestor_Discriminant_Value (Discr);
1949
1950             if Present (Disc_Value) then
1951                Cond := Make_Op_Ne (Loc,
1952                  Left_Opnd =>
1953                    Make_Selected_Component (Loc,
1954                      Prefix        => New_Copy_Tree (Target),
1955                      Selector_Name => New_Occurrence_Of (Discr, Loc)),
1956                  Right_Opnd => Disc_Value);
1957
1958                Append_To (L,
1959                  Make_Raise_Constraint_Error (Loc,
1960                    Condition => Cond,
1961                    Reason    => CE_Discriminant_Check_Failed));
1962             end if;
1963
1964             Next_Discriminant (Discr);
1965          end loop;
1966       end Check_Ancestor_Discriminants;
1967
1968       ---------------------------
1969       -- Compatible_Int_Bounds --
1970       ---------------------------
1971
1972       function Compatible_Int_Bounds
1973         (Agg_Bounds : Node_Id;
1974          Typ_Bounds : Node_Id) return Boolean
1975       is
1976          Agg_Lo : constant Uint := Intval (Low_Bound  (Agg_Bounds));
1977          Agg_Hi : constant Uint := Intval (High_Bound (Agg_Bounds));
1978          Typ_Lo : constant Uint := Intval (Low_Bound  (Typ_Bounds));
1979          Typ_Hi : constant Uint := Intval (High_Bound (Typ_Bounds));
1980       begin
1981          return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi;
1982       end Compatible_Int_Bounds;
1983
1984       --------------------------------
1985       -- Get_Constraint_Association --
1986       --------------------------------
1987
1988       function Get_Constraint_Association (T : Entity_Id) return Node_Id is
1989          Indic : Node_Id;
1990          Typ   : Entity_Id;
1991
1992       begin
1993          Typ := T;
1994
1995          --  Handle private types in instances
1996
1997          if In_Instance
1998            and then Is_Private_Type (Typ)
1999            and then Present (Full_View (Typ))
2000          then
2001             Typ := Full_View (Typ);
2002          end if;
2003
2004          Indic := Subtype_Indication (Type_Definition (Parent (Typ)));
2005
2006          --  ??? Also need to cover case of a type mark denoting a subtype
2007          --  with constraint.
2008
2009          if Nkind (Indic) = N_Subtype_Indication
2010            and then Present (Constraint (Indic))
2011          then
2012             return First (Constraints (Constraint (Indic)));
2013          end if;
2014
2015          return Empty;
2016       end Get_Constraint_Association;
2017
2018       -------------------------------
2019       -- Init_Hidden_Discriminants --
2020       -------------------------------
2021
2022       procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id) is
2023          Btype       : Entity_Id;
2024          Parent_Type : Entity_Id;
2025          Disc        : Entity_Id;
2026          Discr_Val   : Elmt_Id;
2027
2028       begin
2029          Btype := Base_Type (Typ);
2030          while Is_Derived_Type (Btype)
2031            and then Present (Stored_Constraint (Btype))
2032          loop
2033             Parent_Type := Etype (Btype);
2034
2035             Disc := First_Discriminant (Parent_Type);
2036             Discr_Val := First_Elmt (Stored_Constraint (Base_Type (Typ)));
2037             while Present (Discr_Val) loop
2038
2039                --  Only those discriminants of the parent that are not
2040                --  renamed by discriminants of the derived type need to
2041                --  be added explicitly.
2042
2043                if not Is_Entity_Name (Node (Discr_Val))
2044                  or else Ekind (Entity (Node (Discr_Val))) /= E_Discriminant
2045                then
2046                   Comp_Expr :=
2047                     Make_Selected_Component (Loc,
2048                       Prefix        => New_Copy_Tree (Target),
2049                       Selector_Name => New_Occurrence_Of (Disc, Loc));
2050
2051                   Instr :=
2052                     Make_OK_Assignment_Statement (Loc,
2053                       Name       => Comp_Expr,
2054                       Expression => New_Copy_Tree (Node (Discr_Val)));
2055
2056                   Set_No_Ctrl_Actions (Instr);
2057                   Append_To (List, Instr);
2058                end if;
2059
2060                Next_Discriminant (Disc);
2061                Next_Elmt (Discr_Val);
2062             end loop;
2063
2064             Btype := Base_Type (Parent_Type);
2065          end loop;
2066       end Init_Hidden_Discriminants;
2067
2068       -------------------------
2069       -- Is_Int_Range_Bounds --
2070       -------------------------
2071
2072       function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
2073       begin
2074          return Nkind (Bounds) = N_Range
2075            and then Nkind (Low_Bound  (Bounds)) = N_Integer_Literal
2076            and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
2077       end Is_Int_Range_Bounds;
2078
2079       -----------------------------------
2080       -- Generate_Finalization_Actions --
2081       -----------------------------------
2082
2083       procedure Generate_Finalization_Actions is
2084       begin
2085          --  Do the work only the first time this is called
2086
2087          if Finalization_Done then
2088             return;
2089          end if;
2090
2091          Finalization_Done := True;
2092
2093          --  Determine the external finalization list. It is either the
2094          --  finalization list of the outer-scope or the one coming from
2095          --  an outer aggregate. When the target is not a temporary, the
2096          --  proper scope is the scope of the target rather than the
2097          --  potentially transient current scope.
2098
2099          if Is_Controlled (Typ)
2100            and then Ancestor_Is_Subtype_Mark
2101          then
2102             Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2103             Set_Assignment_OK (Ref);
2104
2105             Append_To (L,
2106               Make_Procedure_Call_Statement (Loc,
2107                 Name =>
2108                   New_Reference_To
2109                     (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
2110                 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
2111          end if;
2112       end Generate_Finalization_Actions;
2113
2114       function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result;
2115       --  If default expression of a component mentions a discriminant of the
2116       --  type, it must be rewritten as the discriminant of the target object.
2117
2118       function Replace_Type (Expr : Node_Id) return Traverse_Result;
2119       --  If the aggregate contains a self-reference, traverse each expression
2120       --  to replace a possible self-reference with a reference to the proper
2121       --  component of the target of the assignment.
2122
2123       --------------------------
2124       -- Rewrite_Discriminant --
2125       --------------------------
2126
2127       function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
2128       begin
2129          if Is_Entity_Name (Expr)
2130            and then Present (Entity (Expr))
2131            and then Ekind (Entity (Expr)) = E_In_Parameter
2132            and then Present (Discriminal_Link (Entity (Expr)))
2133            and then Scope (Discriminal_Link (Entity (Expr)))
2134                       = Base_Type (Etype (N))
2135          then
2136             Rewrite (Expr,
2137               Make_Selected_Component (Loc,
2138                 Prefix        => New_Copy_Tree (Lhs),
2139                 Selector_Name => Make_Identifier (Loc, Chars (Expr))));
2140          end if;
2141          return OK;
2142       end Rewrite_Discriminant;
2143
2144       ------------------
2145       -- Replace_Type --
2146       ------------------
2147
2148       function Replace_Type (Expr : Node_Id) return Traverse_Result is
2149       begin
2150          --  Note regarding the Root_Type test below: Aggregate components for
2151          --  self-referential types include attribute references to the current
2152          --  instance, of the form: Typ'access, etc.. These references are
2153          --  rewritten as references to the target of the aggregate: the
2154          --  left-hand side of an assignment, the entity in a declaration,
2155          --  or a temporary. Without this test, we would improperly extended
2156          --  this rewriting to attribute references whose prefix was not the
2157          --  type of the aggregate.
2158
2159          if Nkind (Expr) = N_Attribute_Reference
2160            and then Is_Entity_Name (Prefix (Expr))
2161            and then Is_Type (Entity (Prefix (Expr)))
2162            and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr)))
2163          then
2164             if Is_Entity_Name (Lhs) then
2165                Rewrite (Prefix (Expr),
2166                  New_Occurrence_Of (Entity (Lhs), Loc));
2167
2168             elsif Nkind (Lhs) = N_Selected_Component then
2169                Rewrite (Expr,
2170                  Make_Attribute_Reference (Loc,
2171                    Attribute_Name => Name_Unrestricted_Access,
2172                    Prefix         => New_Copy_Tree (Lhs)));
2173                Set_Analyzed (Parent (Expr), False);
2174
2175             else
2176                Rewrite (Expr,
2177                  Make_Attribute_Reference (Loc,
2178                    Attribute_Name => Name_Unrestricted_Access,
2179                    Prefix         => New_Copy_Tree (Lhs)));
2180                Set_Analyzed (Parent (Expr), False);
2181             end if;
2182          end if;
2183
2184          return OK;
2185       end Replace_Type;
2186
2187       procedure Replace_Self_Reference is
2188         new Traverse_Proc (Replace_Type);
2189
2190       procedure Replace_Discriminants is
2191         new Traverse_Proc (Rewrite_Discriminant);
2192
2193    --  Start of processing for Build_Record_Aggr_Code
2194
2195    begin
2196       if Has_Self_Reference (N) then
2197          Replace_Self_Reference (N);
2198       end if;
2199
2200       --  If the target of the aggregate is class-wide, we must convert it
2201       --  to the actual type of the aggregate, so that the proper components
2202       --  are visible. We know already that the types are compatible.
2203
2204       if Present (Etype (Lhs))
2205         and then Is_Class_Wide_Type (Etype (Lhs))
2206       then
2207          Target := Unchecked_Convert_To (Typ, Lhs);
2208       else
2209          Target := Lhs;
2210       end if;
2211
2212       --  Deal with the ancestor part of extension aggregates or with the
2213       --  discriminants of the root type.
2214
2215       if Nkind (N) = N_Extension_Aggregate then
2216          declare
2217             Ancestor : constant Node_Id := Ancestor_Part (N);
2218             Assign   : List_Id;
2219
2220          begin
2221             --  If the ancestor part is a subtype mark "T", we generate
2222
2223             --     init-proc (T (tmp));  if T is constrained and
2224             --     init-proc (S (tmp));  where S applies an appropriate
2225             --                           constraint if T is unconstrained
2226
2227             if Is_Entity_Name (Ancestor)
2228               and then Is_Type (Entity (Ancestor))
2229             then
2230                Ancestor_Is_Subtype_Mark := True;
2231
2232                if Is_Constrained (Entity (Ancestor)) then
2233                   Init_Typ := Entity (Ancestor);
2234
2235                --  For an ancestor part given by an unconstrained type mark,
2236                --  create a subtype constrained by appropriate corresponding
2237                --  discriminant values coming from either associations of the
2238                --  aggregate or a constraint on a parent type. The subtype will
2239                --  be used to generate the correct default value for the
2240                --  ancestor part.
2241
2242                elsif Has_Discriminants (Entity (Ancestor)) then
2243                   declare
2244                      Anc_Typ    : constant Entity_Id := Entity (Ancestor);
2245                      Anc_Constr : constant List_Id   := New_List;
2246                      Discrim    : Entity_Id;
2247                      Disc_Value : Node_Id;
2248                      New_Indic  : Node_Id;
2249                      Subt_Decl  : Node_Id;
2250
2251                   begin
2252                      Discrim := First_Discriminant (Anc_Typ);
2253                      while Present (Discrim) loop
2254                         Disc_Value := Ancestor_Discriminant_Value (Discrim);
2255                         Append_To (Anc_Constr, Disc_Value);
2256                         Next_Discriminant (Discrim);
2257                      end loop;
2258
2259                      New_Indic :=
2260                        Make_Subtype_Indication (Loc,
2261                          Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc),
2262                          Constraint   =>
2263                            Make_Index_Or_Discriminant_Constraint (Loc,
2264                              Constraints => Anc_Constr));
2265
2266                      Init_Typ := Create_Itype (Ekind (Anc_Typ), N);
2267
2268                      Subt_Decl :=
2269                        Make_Subtype_Declaration (Loc,
2270                          Defining_Identifier => Init_Typ,
2271                          Subtype_Indication  => New_Indic);
2272
2273                      --  Itypes must be analyzed with checks off Declaration
2274                      --  must have a parent for proper handling of subsidiary
2275                      --  actions.
2276
2277                      Set_Parent (Subt_Decl, N);
2278                      Analyze (Subt_Decl, Suppress => All_Checks);
2279                   end;
2280                end if;
2281
2282                Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2283                Set_Assignment_OK (Ref);
2284
2285                if not Is_Interface (Init_Typ) then
2286                   Append_List_To (L,
2287                     Build_Initialization_Call (Loc,
2288                       Id_Ref            => Ref,
2289                       Typ               => Init_Typ,
2290                       In_Init_Proc      => Within_Init_Proc,
2291                       With_Default_Init => Has_Default_Init_Comps (N)
2292                                              or else
2293                                            Has_Task (Base_Type (Init_Typ))));
2294
2295                   if Is_Constrained (Entity (Ancestor))
2296                     and then Has_Discriminants (Entity (Ancestor))
2297                   then
2298                      Check_Ancestor_Discriminants (Entity (Ancestor));
2299                   end if;
2300                end if;
2301
2302             --  Handle calls to C++ constructors
2303
2304             elsif Is_CPP_Constructor_Call (Ancestor) then
2305                Init_Typ := Etype (Ancestor);
2306                Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2307                Set_Assignment_OK (Ref);
2308
2309                Append_List_To (L,
2310                  Build_Initialization_Call (Loc,
2311                    Id_Ref            => Ref,
2312                    Typ               => Init_Typ,
2313                    In_Init_Proc      => Within_Init_Proc,
2314                    With_Default_Init => Has_Default_Init_Comps (N),
2315                    Constructor_Ref   => Ancestor));
2316
2317             --  Ada 2005 (AI-287): If the ancestor part is an aggregate of
2318             --  limited type, a recursive call expands the ancestor. Note that
2319             --  in the limited case, the ancestor part must be either a
2320             --  function call (possibly qualified, or wrapped in an unchecked
2321             --  conversion) or aggregate (definitely qualified).
2322             --  The ancestor part can also be a function call (that may be
2323             --  transformed into an explicit dereference) or a qualification
2324             --  of one such.
2325
2326             elsif Is_Limited_Type (Etype (Ancestor))
2327               and then Nkind_In (Unqualify (Ancestor), N_Aggregate,
2328                                                     N_Extension_Aggregate)
2329             then
2330                Ancestor_Is_Expression := True;
2331
2332                --  Set up  finalization data for enclosing record, because
2333                --  controlled subcomponents of the ancestor part will be
2334                --  attached to it.
2335
2336                Generate_Finalization_Actions;
2337
2338                Append_List_To (L,
2339                   Build_Record_Aggr_Code
2340                     (N   => Unqualify (Ancestor),
2341                      Typ => Etype (Unqualify (Ancestor)),
2342                      Lhs => Target));
2343
2344             --  If the ancestor part is an expression "E", we generate
2345
2346             --     T (tmp) := E;
2347
2348             --  In Ada 2005, this includes the case of a (possibly qualified)
2349             --  limited function call. The assignment will turn into a
2350             --  build-in-place function call (for further details, see
2351             --  Make_Build_In_Place_Call_In_Assignment).
2352
2353             else
2354                Ancestor_Is_Expression := True;
2355                Init_Typ := Etype (Ancestor);
2356
2357                --  If the ancestor part is an aggregate, force its full
2358                --  expansion, which was delayed.
2359
2360                if Nkind_In (Unqualify (Ancestor), N_Aggregate,
2361                                                N_Extension_Aggregate)
2362                then
2363                   Set_Analyzed (Ancestor, False);
2364                   Set_Analyzed (Expression (Ancestor), False);
2365                end if;
2366
2367                Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2368                Set_Assignment_OK (Ref);
2369
2370                --  Make the assignment without usual controlled actions since
2371                --  we only want the post adjust but not the pre finalize here
2372                --  Add manual adjust when necessary.
2373
2374                Assign := New_List (
2375                  Make_OK_Assignment_Statement (Loc,
2376                    Name       => Ref,
2377                    Expression => Ancestor));
2378                Set_No_Ctrl_Actions (First (Assign));
2379
2380                --  Assign the tag now to make sure that the dispatching call in
2381                --  the subsequent deep_adjust works properly (unless VM_Target,
2382                --  where tags are implicit).
2383
2384                if Tagged_Type_Expansion then
2385                   Instr :=
2386                     Make_OK_Assignment_Statement (Loc,
2387                       Name =>
2388                         Make_Selected_Component (Loc,
2389                           Prefix => New_Copy_Tree (Target),
2390                           Selector_Name =>
2391                             New_Reference_To
2392                               (First_Tag_Component (Base_Type (Typ)), Loc)),
2393
2394                       Expression =>
2395                         Unchecked_Convert_To (RTE (RE_Tag),
2396                           New_Reference_To
2397                             (Node (First_Elmt
2398                                (Access_Disp_Table (Base_Type (Typ)))),
2399                              Loc)));
2400
2401                   Set_Assignment_OK (Name (Instr));
2402                   Append_To (Assign, Instr);
2403
2404                   --  Ada 2005 (AI-251): If tagged type has progenitors we must
2405                   --  also initialize tags of the secondary dispatch tables.
2406
2407                   if Has_Interfaces (Base_Type (Typ)) then
2408                      Init_Secondary_Tags
2409                        (Typ        => Base_Type (Typ),
2410                         Target     => Target,
2411                         Stmts_List => Assign);
2412                   end if;
2413                end if;
2414
2415                --  Call Adjust manually
2416
2417                if Needs_Finalization (Etype (Ancestor))
2418                  and then not Is_Limited_Type (Etype (Ancestor))
2419                then
2420                   Append_To (Assign,
2421                     Make_Adjust_Call (
2422                       Obj_Ref => New_Copy_Tree (Ref),
2423                       Typ     => Etype (Ancestor)));
2424                end if;
2425
2426                Append_To (L,
2427                  Make_Unsuppress_Block (Loc, Name_Discriminant_Check, Assign));
2428
2429                if Has_Discriminants (Init_Typ) then
2430                   Check_Ancestor_Discriminants (Init_Typ);
2431                end if;
2432             end if;
2433          end;
2434
2435          --  Generate assignments of hidden assignments. If the base type is an
2436          --  unchecked union, the discriminants are unknown to the back-end and
2437          --  absent from a value of the type, so assignments for them are not
2438          --  emitted.
2439
2440          if Has_Discriminants (Typ)
2441            and then not Is_Unchecked_Union (Base_Type (Typ))
2442          then
2443             Init_Hidden_Discriminants (Typ, L);
2444          end if;
2445
2446       --  Normal case (not an extension aggregate)
2447
2448       else
2449          --  Generate the discriminant expressions, component by component.
2450          --  If the base type is an unchecked union, the discriminants are
2451          --  unknown to the back-end and absent from a value of the type, so
2452          --  assignments for them are not emitted.
2453
2454          if Has_Discriminants (Typ)
2455            and then not Is_Unchecked_Union (Base_Type (Typ))
2456          then
2457             Init_Hidden_Discriminants (Typ, L);
2458
2459             --  Generate discriminant init values for the visible discriminants
2460
2461             declare
2462                Discriminant : Entity_Id;
2463                Discriminant_Value : Node_Id;
2464
2465             begin
2466                Discriminant := First_Stored_Discriminant (Typ);
2467                while Present (Discriminant) loop
2468                   Comp_Expr :=
2469                     Make_Selected_Component (Loc,
2470                       Prefix        => New_Copy_Tree (Target),
2471                       Selector_Name => New_Occurrence_Of (Discriminant, Loc));
2472
2473                   Discriminant_Value :=
2474                     Get_Discriminant_Value (
2475                       Discriminant,
2476                       N_Typ,
2477                       Discriminant_Constraint (N_Typ));
2478
2479                   Instr :=
2480                     Make_OK_Assignment_Statement (Loc,
2481                       Name       => Comp_Expr,
2482                       Expression => New_Copy_Tree (Discriminant_Value));
2483
2484                   Set_No_Ctrl_Actions (Instr);
2485                   Append_To (L, Instr);
2486
2487                   Next_Stored_Discriminant (Discriminant);
2488                end loop;
2489             end;
2490          end if;
2491       end if;
2492
2493       --  For CPP types we generate an implicit call to the C++ default
2494       --  constructor to ensure the proper initialization of the _Tag
2495       --  component.
2496
2497       if Is_CPP_Class (Root_Type (Typ))
2498         and then CPP_Num_Prims (Typ) > 0
2499       then
2500          Invoke_Constructor : declare
2501             CPP_Parent : constant Entity_Id :=
2502                            Enclosing_CPP_Parent (Typ);
2503
2504             procedure Invoke_IC_Proc (T : Entity_Id);
2505             --  Recursive routine used to climb to parents. Required because
2506             --  parents must be initialized before descendants to ensure
2507             --  propagation of inherited C++ slots.
2508
2509             --------------------
2510             -- Invoke_IC_Proc --
2511             --------------------
2512
2513             procedure Invoke_IC_Proc (T : Entity_Id) is
2514             begin
2515                --  Avoid generating extra calls. Initialization required
2516                --  only for types defined from the level of derivation of
2517                --  type of the constructor and the type of the aggregate.
2518
2519                if T = CPP_Parent then
2520                   return;
2521                end if;
2522
2523                Invoke_IC_Proc (Etype (T));
2524
2525                --  Generate call to the IC routine
2526
2527                if Present (CPP_Init_Proc (T)) then
2528                   Append_To (L,
2529                     Make_Procedure_Call_Statement (Loc,
2530                       New_Reference_To (CPP_Init_Proc (T), Loc)));
2531                end if;
2532             end Invoke_IC_Proc;
2533
2534          --  Start of processing for Invoke_Constructor
2535
2536          begin
2537             --  Implicit invocation of the C++ constructor
2538
2539             if Nkind (N) = N_Aggregate then
2540                Append_To (L,
2541                  Make_Procedure_Call_Statement (Loc,
2542                    Name =>
2543                      New_Reference_To
2544                        (Base_Init_Proc (CPP_Parent), Loc),
2545                    Parameter_Associations => New_List (
2546                      Unchecked_Convert_To (CPP_Parent,
2547                        New_Copy_Tree (Lhs)))));
2548             end if;
2549
2550             Invoke_IC_Proc (Typ);
2551          end Invoke_Constructor;
2552       end if;
2553
2554       --  Generate the assignments, component by component
2555
2556       --    tmp.comp1 := Expr1_From_Aggr;
2557       --    tmp.comp2 := Expr2_From_Aggr;
2558       --    ....
2559
2560       Comp := First (Component_Associations (N));
2561       while Present (Comp) loop
2562          Selector := Entity (First (Choices (Comp)));
2563
2564          --  C++ constructors
2565
2566          if Is_CPP_Constructor_Call (Expression (Comp)) then
2567             Append_List_To (L,
2568               Build_Initialization_Call (Loc,
2569                 Id_Ref            => Make_Selected_Component (Loc,
2570                                        Prefix        => New_Copy_Tree (Target),
2571                                        Selector_Name =>
2572                                          New_Occurrence_Of (Selector, Loc)),
2573                 Typ               => Etype (Selector),
2574                 Enclos_Type       => Typ,
2575                 With_Default_Init => True,
2576                 Constructor_Ref   => Expression (Comp)));
2577
2578          --  Ada 2005 (AI-287): For each default-initialized component generate
2579          --  a call to the corresponding IP subprogram if available.
2580
2581          elsif Box_Present (Comp)
2582            and then Has_Non_Null_Base_Init_Proc (Etype (Selector))
2583          then
2584             if Ekind (Selector) /= E_Discriminant then
2585                Generate_Finalization_Actions;
2586             end if;
2587
2588             --  Ada 2005 (AI-287): If the component type has tasks then
2589             --  generate the activation chain and master entities (except
2590             --  in case of an allocator because in that case these entities
2591             --  are generated by Build_Task_Allocate_Block_With_Init_Stmts).
2592
2593             declare
2594                Ctype            : constant Entity_Id := Etype (Selector);
2595                Inside_Allocator : Boolean            := False;
2596                P                : Node_Id            := Parent (N);
2597
2598             begin
2599                if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
2600                   while Present (P) loop
2601                      if Nkind (P) = N_Allocator then
2602                         Inside_Allocator := True;
2603                         exit;
2604                      end if;
2605
2606                      P := Parent (P);
2607                   end loop;
2608
2609                   if not Inside_Init_Proc and not Inside_Allocator then
2610                      Build_Activation_Chain_Entity (N);
2611                   end if;
2612                end if;
2613             end;
2614
2615             Append_List_To (L,
2616               Build_Initialization_Call (Loc,
2617                 Id_Ref            => Make_Selected_Component (Loc,
2618                                        Prefix        => New_Copy_Tree (Target),
2619                                        Selector_Name =>
2620                                          New_Occurrence_Of (Selector, Loc)),
2621                 Typ               => Etype (Selector),
2622                 Enclos_Type       => Typ,
2623                 With_Default_Init => True));
2624
2625          --  Prepare for component assignment
2626
2627          elsif Ekind (Selector) /= E_Discriminant
2628            or else Nkind (N) = N_Extension_Aggregate
2629          then
2630             --  All the discriminants have now been assigned
2631
2632             --  This is now a good moment to initialize and attach all the
2633             --  controllers. Their position may depend on the discriminants.
2634
2635             if Ekind (Selector) /= E_Discriminant then
2636                Generate_Finalization_Actions;
2637             end if;
2638
2639             Comp_Type := Underlying_Type (Etype (Selector));
2640             Comp_Expr :=
2641               Make_Selected_Component (Loc,
2642                 Prefix        => New_Copy_Tree (Target),
2643                 Selector_Name => New_Occurrence_Of (Selector, Loc));
2644
2645             if Nkind (Expression (Comp)) = N_Qualified_Expression then
2646                Expr_Q := Expression (Expression (Comp));
2647             else
2648                Expr_Q := Expression (Comp);
2649             end if;
2650
2651             --  Now either create the assignment or generate the code for the
2652             --  inner aggregate top-down.
2653
2654             if Is_Delayed_Aggregate (Expr_Q) then
2655
2656                --  We have the following case of aggregate nesting inside
2657                --  an object declaration:
2658
2659                --    type Arr_Typ is array (Integer range <>) of ...;
2660
2661                --    type Rec_Typ (...) is record
2662                --       Obj_Arr_Typ : Arr_Typ (A .. B);
2663                --    end record;
2664
2665                --    Obj_Rec_Typ : Rec_Typ := (...,
2666                --      Obj_Arr_Typ => (X => (...), Y => (...)));
2667
2668                --  The length of the ranges of the aggregate and Obj_Add_Typ
2669                --  are equal (B - A = Y - X), but they do not coincide (X /=
2670                --  A and B /= Y). This case requires array sliding which is
2671                --  performed in the following manner:
2672
2673                --    subtype Arr_Sub is Arr_Typ (X .. Y);
2674                --    Temp : Arr_Sub;
2675                --    Temp (X) := (...);
2676                --    ...
2677                --    Temp (Y) := (...);
2678                --    Obj_Rec_Typ.Obj_Arr_Typ := Temp;
2679
2680                if Ekind (Comp_Type) = E_Array_Subtype
2681                  and then Is_Int_Range_Bounds (Aggregate_Bounds (Expr_Q))
2682                  and then Is_Int_Range_Bounds (First_Index (Comp_Type))
2683                  and then not
2684                    Compatible_Int_Bounds
2685                      (Agg_Bounds => Aggregate_Bounds (Expr_Q),
2686                       Typ_Bounds => First_Index (Comp_Type))
2687                then
2688                   --  Create the array subtype with bounds equal to those of
2689                   --  the corresponding aggregate.
2690
2691                   declare
2692                      SubE : constant Entity_Id := Make_Temporary (Loc, 'T');
2693
2694                      SubD : constant Node_Id :=
2695                               Make_Subtype_Declaration (Loc,
2696                                 Defining_Identifier => SubE,
2697                                 Subtype_Indication  =>
2698                                   Make_Subtype_Indication (Loc,
2699                                     Subtype_Mark =>
2700                                       New_Reference_To
2701                                         (Etype (Comp_Type), Loc),
2702                                     Constraint =>
2703                                       Make_Index_Or_Discriminant_Constraint
2704                                         (Loc,
2705                                          Constraints => New_List (
2706                                           New_Copy_Tree
2707                                             (Aggregate_Bounds (Expr_Q))))));
2708
2709                      --  Create a temporary array of the above subtype which
2710                      --  will be used to capture the aggregate assignments.
2711
2712                      TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N);
2713
2714                      TmpD : constant Node_Id :=
2715                               Make_Object_Declaration (Loc,
2716                                 Defining_Identifier => TmpE,
2717                                 Object_Definition   =>
2718                                   New_Reference_To (SubE, Loc));
2719
2720                   begin
2721                      Set_No_Initialization (TmpD);
2722                      Append_To (L, SubD);
2723                      Append_To (L, TmpD);
2724
2725                      --  Expand aggregate into assignments to the temp array
2726
2727                      Append_List_To (L,
2728                        Late_Expansion (Expr_Q, Comp_Type,
2729                          New_Reference_To (TmpE, Loc)));
2730
2731                      --  Slide
2732
2733                      Append_To (L,
2734                        Make_Assignment_Statement (Loc,
2735                          Name       => New_Copy_Tree (Comp_Expr),
2736                          Expression => New_Reference_To (TmpE, Loc)));
2737                   end;
2738
2739                --  Normal case (sliding not required)
2740
2741                else
2742                   Append_List_To (L,
2743                     Late_Expansion (Expr_Q, Comp_Type, Comp_Expr));
2744                end if;
2745
2746             --  Expr_Q is not delayed aggregate
2747
2748             else
2749                if Has_Discriminants (Typ) then
2750                   Replace_Discriminants (Expr_Q);
2751                end if;
2752
2753                Instr :=
2754                  Make_OK_Assignment_Statement (Loc,
2755                    Name       => Comp_Expr,
2756                    Expression => Expr_Q);
2757
2758                Set_No_Ctrl_Actions (Instr);
2759                Append_To (L, Instr);
2760
2761                --  Adjust the tag if tagged (because of possible view
2762                --  conversions), unless compiling for a VM where tags are
2763                --  implicit.
2764
2765                --    tmp.comp._tag := comp_typ'tag;
2766
2767                if Is_Tagged_Type (Comp_Type)
2768                  and then Tagged_Type_Expansion
2769                then
2770                   Instr :=
2771                     Make_OK_Assignment_Statement (Loc,
2772                       Name =>
2773                         Make_Selected_Component (Loc,
2774                           Prefix =>  New_Copy_Tree (Comp_Expr),
2775                           Selector_Name =>
2776                             New_Reference_To
2777                               (First_Tag_Component (Comp_Type), Loc)),
2778
2779                       Expression =>
2780                         Unchecked_Convert_To (RTE (RE_Tag),
2781                           New_Reference_To
2782                             (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
2783                              Loc)));
2784
2785                   Append_To (L, Instr);
2786                end if;
2787
2788                --  Generate:
2789                --    Adjust (tmp.comp);
2790
2791                if Needs_Finalization (Comp_Type)
2792                  and then not Is_Limited_Type (Comp_Type)
2793                then
2794                   Append_To (L,
2795                     Make_Adjust_Call (
2796                       Obj_Ref => New_Copy_Tree (Comp_Expr),
2797                       Typ     => Comp_Type));
2798                end if;
2799             end if;
2800
2801          --  ???
2802
2803          elsif Ekind (Selector) = E_Discriminant
2804            and then Nkind (N) /= N_Extension_Aggregate
2805            and then Nkind (Parent (N)) = N_Component_Association
2806            and then Is_Constrained (Typ)
2807          then
2808             --  We must check that the discriminant value imposed by the
2809             --  context is the same as the value given in the subaggregate,
2810             --  because after the expansion into assignments there is no
2811             --  record on which to perform a regular discriminant check.
2812
2813             declare
2814                D_Val : Elmt_Id;
2815                Disc  : Entity_Id;
2816
2817             begin
2818                D_Val := First_Elmt (Discriminant_Constraint (Typ));
2819                Disc  := First_Discriminant (Typ);
2820                while Chars (Disc) /= Chars (Selector) loop
2821                   Next_Discriminant (Disc);
2822                   Next_Elmt (D_Val);
2823                end loop;
2824
2825                pragma Assert (Present (D_Val));
2826
2827                --  This check cannot performed for components that are
2828                --  constrained by a current instance, because this is not a
2829                --  value that can be compared with the actual constraint.
2830
2831                if Nkind (Node (D_Val)) /= N_Attribute_Reference
2832                  or else not Is_Entity_Name (Prefix (Node (D_Val)))
2833                  or else not Is_Type (Entity (Prefix (Node (D_Val))))
2834                then
2835                   Append_To (L,
2836                   Make_Raise_Constraint_Error (Loc,
2837                     Condition =>
2838                       Make_Op_Ne (Loc,
2839                         Left_Opnd => New_Copy_Tree (Node (D_Val)),
2840                         Right_Opnd => Expression (Comp)),
2841                       Reason => CE_Discriminant_Check_Failed));
2842
2843                else
2844                   --  Find self-reference in previous discriminant assignment,
2845                   --  and replace with proper expression.
2846
2847                   declare
2848                      Ass : Node_Id;
2849
2850                   begin
2851                      Ass := First (L);
2852                      while Present (Ass) loop
2853                         if Nkind (Ass) = N_Assignment_Statement
2854                           and then Nkind (Name (Ass)) = N_Selected_Component
2855                           and then Chars (Selector_Name (Name (Ass))) =
2856                              Chars (Disc)
2857                         then
2858                            Set_Expression
2859                              (Ass, New_Copy_Tree (Expression (Comp)));
2860                            exit;
2861                         end if;
2862                         Next (Ass);
2863                      end loop;
2864                   end;
2865                end if;
2866             end;
2867          end if;
2868
2869          Next (Comp);
2870       end loop;
2871
2872       --  If the type is tagged, the tag needs to be initialized (unless
2873       --  compiling for the Java VM where tags are implicit). It is done
2874       --  late in the initialization process because in some cases, we call
2875       --  the init proc of an ancestor which will not leave out the right tag
2876
2877       if Ancestor_Is_Expression then
2878          null;
2879
2880       --  For CPP types we generated a call to the C++ default constructor
2881       --  before the components have been initialized to ensure the proper
2882       --  initialization of the _Tag component (see above).
2883
2884       elsif Is_CPP_Class (Typ) then
2885          null;
2886
2887       elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
2888          Instr :=
2889            Make_OK_Assignment_Statement (Loc,
2890              Name =>
2891                Make_Selected_Component (Loc,
2892                  Prefix => New_Copy_Tree (Target),
2893                  Selector_Name =>
2894                    New_Reference_To
2895                      (First_Tag_Component (Base_Type (Typ)), Loc)),
2896
2897              Expression =>
2898                Unchecked_Convert_To (RTE (RE_Tag),
2899                  New_Reference_To
2900                    (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))),
2901                     Loc)));
2902
2903          Append_To (L, Instr);
2904
2905          --  Ada 2005 (AI-251): If the tagged type has been derived from
2906          --  abstract interfaces we must also initialize the tags of the
2907          --  secondary dispatch tables.
2908
2909          if Has_Interfaces (Base_Type (Typ)) then
2910             Init_Secondary_Tags
2911               (Typ        => Base_Type (Typ),
2912                Target     => Target,
2913                Stmts_List => L);
2914          end if;
2915       end if;
2916
2917       --  If the controllers have not been initialized yet (by lack of non-
2918       --  discriminant components), let's do it now.
2919
2920       Generate_Finalization_Actions;
2921
2922       return L;
2923    end Build_Record_Aggr_Code;
2924
2925    -------------------------------
2926    -- Convert_Aggr_In_Allocator --
2927    -------------------------------
2928
2929    procedure Convert_Aggr_In_Allocator
2930      (Alloc :  Node_Id;
2931       Decl  :  Node_Id;
2932       Aggr  :  Node_Id)
2933    is
2934       Loc  : constant Source_Ptr := Sloc (Aggr);
2935       Typ  : constant Entity_Id  := Etype (Aggr);
2936       Temp : constant Entity_Id  := Defining_Identifier (Decl);
2937
2938       Occ  : constant Node_Id :=
2939                Unchecked_Convert_To (Typ,
2940                  Make_Explicit_Dereference (Loc,
2941                    New_Reference_To (Temp, Loc)));
2942
2943    begin
2944       if Is_Array_Type (Typ) then
2945          Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ);
2946
2947       elsif Has_Default_Init_Comps (Aggr) then
2948          declare
2949             L          : constant List_Id := New_List;
2950             Init_Stmts : List_Id;
2951
2952          begin
2953             Init_Stmts := Late_Expansion (Aggr, Typ, Occ);
2954
2955             if Has_Task (Typ) then
2956                Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
2957                Insert_Actions (Alloc, L);
2958             else
2959                Insert_Actions (Alloc, Init_Stmts);
2960             end if;
2961          end;
2962
2963       else
2964          Insert_Actions (Alloc, Late_Expansion (Aggr, Typ, Occ));
2965       end if;
2966    end Convert_Aggr_In_Allocator;
2967
2968    --------------------------------
2969    -- Convert_Aggr_In_Assignment --
2970    --------------------------------
2971
2972    procedure Convert_Aggr_In_Assignment (N : Node_Id) is
2973       Aggr : Node_Id            := Expression (N);
2974       Typ  : constant Entity_Id := Etype (Aggr);
2975       Occ  : constant Node_Id   := New_Copy_Tree (Name (N));
2976
2977    begin
2978       if Nkind (Aggr) = N_Qualified_Expression then
2979          Aggr := Expression (Aggr);
2980       end if;
2981
2982       Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
2983    end Convert_Aggr_In_Assignment;
2984
2985    ---------------------------------
2986    -- Convert_Aggr_In_Object_Decl --
2987    ---------------------------------
2988
2989    procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is
2990       Obj  : constant Entity_Id  := Defining_Identifier (N);
2991       Aggr : Node_Id             := Expression (N);
2992       Loc  : constant Source_Ptr := Sloc (Aggr);
2993       Typ  : constant Entity_Id  := Etype (Aggr);
2994       Occ  : constant Node_Id    := New_Occurrence_Of (Obj, Loc);
2995
2996       function Discriminants_Ok return Boolean;
2997       --  If the object type is constrained, the discriminants in the
2998       --  aggregate must be checked against the discriminants of the subtype.
2999       --  This cannot be done using Apply_Discriminant_Checks because after
3000       --  expansion there is no aggregate left to check.
3001
3002       ----------------------
3003       -- Discriminants_Ok --
3004       ----------------------
3005
3006       function Discriminants_Ok return Boolean is
3007          Cond  : Node_Id := Empty;
3008          Check : Node_Id;
3009          D     : Entity_Id;
3010          Disc1 : Elmt_Id;
3011          Disc2 : Elmt_Id;
3012          Val1  : Node_Id;
3013          Val2  : Node_Id;
3014
3015       begin
3016          D := First_Discriminant (Typ);
3017          Disc1 := First_Elmt (Discriminant_Constraint (Typ));
3018          Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj)));
3019          while Present (Disc1) and then Present (Disc2) loop
3020             Val1 := Node (Disc1);
3021             Val2 := Node (Disc2);
3022
3023             if not Is_OK_Static_Expression (Val1)
3024               or else not Is_OK_Static_Expression (Val2)
3025             then
3026                Check := Make_Op_Ne (Loc,
3027                  Left_Opnd  => Duplicate_Subexpr (Val1),
3028                  Right_Opnd => Duplicate_Subexpr (Val2));
3029
3030                if No (Cond) then
3031                   Cond := Check;
3032
3033                else
3034                   Cond := Make_Or_Else (Loc,
3035                     Left_Opnd => Cond,
3036                     Right_Opnd => Check);
3037                end if;
3038
3039             elsif Expr_Value (Val1) /= Expr_Value (Val2) then
3040                Apply_Compile_Time_Constraint_Error (Aggr,
3041                  Msg    => "incorrect value for discriminant&?",
3042                  Reason => CE_Discriminant_Check_Failed,
3043                  Ent    => D);
3044                return False;
3045             end if;
3046
3047             Next_Discriminant (D);
3048             Next_Elmt (Disc1);
3049             Next_Elmt (Disc2);
3050          end loop;
3051
3052          --  If any discriminant constraint is non-static, emit a check
3053
3054          if Present (Cond) then
3055             Insert_Action (N,
3056               Make_Raise_Constraint_Error (Loc,
3057                 Condition => Cond,
3058                 Reason => CE_Discriminant_Check_Failed));
3059          end if;
3060
3061          return True;
3062       end Discriminants_Ok;
3063
3064    --  Start of processing for Convert_Aggr_In_Object_Decl
3065
3066    begin
3067       Set_Assignment_OK (Occ);
3068
3069       if Nkind (Aggr) = N_Qualified_Expression then
3070          Aggr := Expression (Aggr);
3071       end if;
3072
3073       if Has_Discriminants (Typ)
3074         and then Typ /= Etype (Obj)
3075         and then Is_Constrained (Etype (Obj))
3076         and then not Discriminants_Ok
3077       then
3078          return;
3079       end if;
3080
3081       --  If the context is an extended return statement, it has its own
3082       --  finalization machinery (i.e. works like a transient scope) and
3083       --  we do not want to create an additional one, because objects on
3084       --  the finalization list of the return must be moved to the caller's
3085       --  finalization list to complete the return.
3086
3087       --  However, if the aggregate is limited, it is built in place, and the
3088       --  controlled components are not assigned to intermediate temporaries
3089       --  so there is no need for a transient scope in this case either.
3090
3091       if Requires_Transient_Scope (Typ)
3092         and then Ekind (Current_Scope) /= E_Return_Statement
3093         and then not Is_Limited_Type (Typ)
3094       then
3095          Establish_Transient_Scope
3096            (Aggr,
3097             Sec_Stack =>
3098               Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
3099       end if;
3100
3101       Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
3102       Set_No_Initialization (N);
3103       Initialize_Discriminants (N, Typ);
3104    end Convert_Aggr_In_Object_Decl;
3105
3106    -------------------------------------
3107    -- Convert_Array_Aggr_In_Allocator --
3108    -------------------------------------
3109
3110    procedure Convert_Array_Aggr_In_Allocator
3111      (Decl   : Node_Id;
3112       Aggr   : Node_Id;
3113       Target : Node_Id)
3114    is
3115       Aggr_Code : List_Id;
3116       Typ       : constant Entity_Id := Etype (Aggr);
3117       Ctyp      : constant Entity_Id := Component_Type (Typ);
3118
3119    begin
3120       --  The target is an explicit dereference of the allocated object.
3121       --  Generate component assignments to it, as for an aggregate that
3122       --  appears on the right-hand side of an assignment statement.
3123
3124       Aggr_Code :=
3125         Build_Array_Aggr_Code (Aggr,
3126           Ctype       => Ctyp,
3127           Index       => First_Index (Typ),
3128           Into        => Target,
3129           Scalar_Comp => Is_Scalar_Type (Ctyp));
3130
3131       Insert_Actions_After (Decl, Aggr_Code);
3132    end Convert_Array_Aggr_In_Allocator;
3133
3134    ----------------------------
3135    -- Convert_To_Assignments --
3136    ----------------------------
3137
3138    procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
3139       Loc  : constant Source_Ptr := Sloc (N);
3140       T    : Entity_Id;
3141       Temp : Entity_Id;
3142
3143       Instr       : Node_Id;
3144       Target_Expr : Node_Id;
3145       Parent_Kind : Node_Kind;
3146       Unc_Decl    : Boolean := False;
3147       Parent_Node : Node_Id;
3148
3149    begin
3150       pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
3151       pragma Assert (Is_Record_Type (Typ));
3152
3153       Parent_Node := Parent (N);
3154       Parent_Kind := Nkind (Parent_Node);
3155
3156       if Parent_Kind = N_Qualified_Expression then
3157
3158          --  Check if we are in a unconstrained declaration because in this
3159          --  case the current delayed expansion mechanism doesn't work when
3160          --  the declared object size depend on the initializing expr.
3161
3162          begin
3163             Parent_Node := Parent (Parent_Node);
3164             Parent_Kind := Nkind (Parent_Node);
3165
3166             if Parent_Kind = N_Object_Declaration then
3167                Unc_Decl :=
3168                  not Is_Entity_Name (Object_Definition (Parent_Node))
3169                    or else Has_Discriminants
3170                              (Entity (Object_Definition (Parent_Node)))
3171                    or else Is_Class_Wide_Type
3172                              (Entity (Object_Definition (Parent_Node)));
3173             end if;
3174          end;
3175       end if;
3176
3177       --  Just set the Delay flag in the cases where the transformation will be
3178       --  done top down from above.
3179
3180       if False
3181
3182          --  Internal aggregate (transformed when expanding the parent)
3183
3184          or else Parent_Kind = N_Aggregate
3185          or else Parent_Kind = N_Extension_Aggregate
3186          or else Parent_Kind = N_Component_Association
3187
3188          --  Allocator (see Convert_Aggr_In_Allocator)
3189
3190          or else Parent_Kind = N_Allocator
3191
3192          --  Object declaration (see Convert_Aggr_In_Object_Decl)
3193
3194          or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
3195
3196          --  Safe assignment (see Convert_Aggr_Assignments). So far only the
3197          --  assignments in init procs are taken into account.
3198
3199          or else (Parent_Kind = N_Assignment_Statement
3200                    and then Inside_Init_Proc)
3201
3202          --  (Ada 2005) An inherently limited type in a return statement,
3203          --  which will be handled in a build-in-place fashion, and may be
3204          --  rewritten as an extended return and have its own finalization
3205          --  machinery. In the case of a simple return, the aggregate needs
3206          --  to be delayed until the scope for the return statement has been
3207          --  created, so that any finalization chain will be associated with
3208          --  that scope. For extended returns, we delay expansion to avoid the
3209          --  creation of an unwanted transient scope that could result in
3210          --  premature finalization of the return object (which is built in
3211          --  in place within the caller's scope).
3212
3213          or else
3214            (Is_Immutably_Limited_Type (Typ)
3215              and then
3216                (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement
3217                  or else Nkind (Parent_Node) = N_Simple_Return_Statement))
3218       then
3219          Set_Expansion_Delayed (N);
3220          return;
3221       end if;
3222
3223       if Requires_Transient_Scope (Typ) then
3224          Establish_Transient_Scope
3225            (N, Sec_Stack =>
3226                  Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
3227       end if;
3228
3229       --  If the aggregate is non-limited, create a temporary. If it is limited
3230       --  and the context is an assignment, this is a subaggregate for an
3231       --  enclosing aggregate being expanded. It must be built in place, so use
3232       --  the target of the current assignment.
3233
3234       if Is_Limited_Type (Typ)
3235         and then Nkind (Parent (N)) = N_Assignment_Statement
3236       then
3237          Target_Expr := New_Copy_Tree (Name (Parent (N)));
3238          Insert_Actions (Parent (N),
3239            Build_Record_Aggr_Code (N, Typ, Target_Expr));
3240          Rewrite (Parent (N), Make_Null_Statement (Loc));
3241
3242       else
3243          Temp := Make_Temporary (Loc, 'A', N);
3244
3245          --  If the type inherits unknown discriminants, use the view with
3246          --  known discriminants if available.
3247
3248          if Has_Unknown_Discriminants (Typ)
3249             and then Present (Underlying_Record_View (Typ))
3250          then
3251             T := Underlying_Record_View (Typ);
3252          else
3253             T := Typ;
3254          end if;
3255
3256          Instr :=
3257            Make_Object_Declaration (Loc,
3258              Defining_Identifier => Temp,
3259              Object_Definition   => New_Occurrence_Of (T, Loc));
3260
3261          Set_No_Initialization (Instr);
3262          Insert_Action (N, Instr);
3263          Initialize_Discriminants (Instr, T);
3264          Target_Expr := New_Occurrence_Of (Temp, Loc);
3265          Insert_Actions (N, Build_Record_Aggr_Code (N, T, Target_Expr));
3266          Rewrite (N, New_Occurrence_Of (Temp, Loc));
3267          Analyze_And_Resolve (N, T);
3268       end if;
3269    end Convert_To_Assignments;
3270
3271    ---------------------------
3272    -- Convert_To_Positional --
3273    ---------------------------
3274
3275    procedure Convert_To_Positional
3276      (N                    : Node_Id;
3277       Max_Others_Replicate : Nat     := 5;
3278       Handle_Bit_Packed    : Boolean := False)
3279    is
3280       Typ : constant Entity_Id := Etype (N);
3281
3282       Static_Components : Boolean := True;
3283
3284       procedure Check_Static_Components;
3285       --  Check whether all components of the aggregate are compile-time known
3286       --  values, and can be passed as is to the back-end without further
3287       --  expansion.
3288
3289       function Flatten
3290         (N   : Node_Id;
3291          Ix  : Node_Id;
3292          Ixb : Node_Id) return Boolean;
3293       --  Convert the aggregate into a purely positional form if possible. On
3294       --  entry the bounds of all dimensions are known to be static, and the
3295       --  total number of components is safe enough to expand.
3296
3297       function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
3298       --  Return True iff the array N is flat (which is not trivial in the case
3299       --  of multidimensional aggregates).
3300
3301       -----------------------------
3302       -- Check_Static_Components --
3303       -----------------------------
3304
3305       procedure Check_Static_Components is
3306          Expr : Node_Id;
3307
3308       begin
3309          Static_Components := True;
3310
3311          if Nkind (N) = N_String_Literal then
3312             null;
3313
3314          elsif Present (Expressions (N)) then
3315             Expr := First (Expressions (N));
3316             while Present (Expr) loop
3317                if Nkind (Expr) /= N_Aggregate
3318                  or else not Compile_Time_Known_Aggregate (Expr)
3319                  or else Expansion_Delayed (Expr)
3320                then
3321                   Static_Components := False;
3322                   exit;
3323                end if;
3324
3325                Next (Expr);
3326             end loop;
3327          end if;
3328
3329          if Nkind (N) = N_Aggregate
3330            and then  Present (Component_Associations (N))
3331          then
3332             Expr := First (Component_Associations (N));
3333             while Present (Expr) loop
3334                if Nkind_In (Expression (Expr), N_Integer_Literal,
3335                                                N_Real_Literal)
3336                then
3337                   null;
3338
3339                elsif Is_Entity_Name (Expression (Expr))
3340                  and then Present (Entity (Expression (Expr)))
3341                  and then Ekind (Entity (Expression (Expr))) =
3342                    E_Enumeration_Literal
3343                then
3344                   null;
3345
3346                elsif Nkind (Expression (Expr)) /= N_Aggregate
3347                  or else not Compile_Time_Known_Aggregate (Expression (Expr))
3348                  or else Expansion_Delayed (Expression (Expr))
3349                then
3350                   Static_Components := False;
3351                   exit;
3352                end if;
3353
3354                Next (Expr);
3355             end loop;
3356          end if;
3357       end Check_Static_Components;
3358
3359       -------------
3360       -- Flatten --
3361       -------------
3362
3363       function Flatten
3364         (N   : Node_Id;
3365          Ix  : Node_Id;
3366          Ixb : Node_Id) return Boolean
3367       is
3368          Loc : constant Source_Ptr := Sloc (N);
3369          Blo : constant Node_Id    := Type_Low_Bound (Etype (Ixb));
3370          Lo  : constant Node_Id    := Type_Low_Bound (Etype (Ix));
3371          Hi  : constant Node_Id    := Type_High_Bound (Etype (Ix));
3372          Lov : Uint;
3373          Hiv : Uint;
3374
3375          Others_Present : Boolean := False;
3376
3377       begin
3378          if Nkind (Original_Node (N)) = N_String_Literal then
3379             return True;
3380          end if;
3381
3382          if not Compile_Time_Known_Value (Lo)
3383            or else not Compile_Time_Known_Value (Hi)
3384          then
3385             return False;
3386          end if;
3387
3388          Lov := Expr_Value (Lo);
3389          Hiv := Expr_Value (Hi);
3390
3391          --  Check if there is an others choice
3392
3393          if Present (Component_Associations (N)) then
3394             declare
3395                Assoc   : Node_Id;
3396                Choice  : Node_Id;
3397
3398             begin
3399                Assoc := First (Component_Associations (N));
3400                while Present (Assoc) loop
3401
3402                   --  If this is a box association, flattening is in general
3403                   --  not possible because at this point we cannot tell if the
3404                   --  default is static or even exists.
3405
3406                   if Box_Present (Assoc) then
3407                      return False;
3408                   end if;
3409
3410                   Choice := First (Choices (Assoc));
3411
3412                   while Present (Choice) loop
3413                      if Nkind (Choice) = N_Others_Choice then
3414                         Others_Present := True;
3415                      end if;
3416
3417                      Next (Choice);
3418                   end loop;
3419
3420                   Next (Assoc);
3421                end loop;
3422             end;
3423          end if;
3424
3425          --  If the low bound is not known at compile time and others is not
3426          --  present we can proceed since the bounds can be obtained from the
3427          --  aggregate.
3428
3429          --  Note: This case is required in VM platforms since their backends
3430          --  normalize array indexes in the range 0 .. N-1. Hence, if we do
3431          --  not flat an array whose bounds cannot be obtained from the type
3432          --  of the index the backend has no way to properly generate the code.
3433          --  See ACATS c460010 for an example.
3434
3435          if Hiv < Lov
3436            or else (not Compile_Time_Known_Value (Blo)
3437                      and then Others_Present)
3438          then
3439             return False;
3440          end if;
3441
3442          --  Determine if set of alternatives is suitable for conversion and
3443          --  build an array containing the values in sequence.
3444
3445          declare
3446             Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv))
3447                      of Node_Id := (others => Empty);
3448             --  The values in the aggregate sorted appropriately
3449
3450             Vlist : List_Id;
3451             --  Same data as Vals in list form
3452
3453             Rep_Count : Nat;
3454             --  Used to validate Max_Others_Replicate limit
3455
3456             Elmt         : Node_Id;
3457             Num          : Int := UI_To_Int (Lov);
3458             Choice_Index : Int;
3459             Choice       : Node_Id;
3460             Lo, Hi       : Node_Id;
3461
3462          begin
3463             if Present (Expressions (N)) then
3464                Elmt := First (Expressions (N));
3465                while Present (Elmt) loop
3466                   if Nkind (Elmt) = N_Aggregate
3467                     and then Present (Next_Index (Ix))
3468                     and then
3469                       not Flatten (Elmt, Next_Index (Ix), Next_Index (Ixb))
3470                   then
3471                      return False;
3472                   end if;
3473
3474                   Vals (Num) := Relocate_Node (Elmt);
3475                   Num := Num + 1;
3476
3477                   Next (Elmt);
3478                end loop;
3479             end if;
3480
3481             if No (Component_Associations (N)) then
3482                return True;
3483             end if;
3484
3485             Elmt := First (Component_Associations (N));
3486
3487             if Nkind (Expression (Elmt)) = N_Aggregate then
3488                if Present (Next_Index (Ix))
3489                  and then
3490                    not Flatten
3491                         (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb))
3492                then
3493                   return False;
3494                end if;
3495             end if;
3496
3497             Component_Loop : while Present (Elmt) loop
3498                Choice := First (Choices (Elmt));
3499                Choice_Loop : while Present (Choice) loop
3500
3501                   --  If we have an others choice, fill in the missing elements
3502                   --  subject to the limit established by Max_Others_Replicate.
3503
3504                   if Nkind (Choice) = N_Others_Choice then
3505                      Rep_Count := 0;
3506
3507                      for J in Vals'Range loop
3508                         if No (Vals (J)) then
3509                            Vals (J) := New_Copy_Tree (Expression (Elmt));
3510                            Rep_Count := Rep_Count + 1;
3511
3512                            --  Check for maximum others replication. Note that
3513                            --  we skip this test if either of the restrictions
3514                            --  No_Elaboration_Code or No_Implicit_Loops is
3515                            --  active, if this is a preelaborable unit or a
3516                            --  predefined unit. This ensures that predefined
3517                            --  units get the same level of constant folding in
3518                            --  Ada 95 and Ada 2005, where their categorization
3519                            --  has changed.
3520
3521                            declare
3522                               P : constant Entity_Id :=
3523                                     Cunit_Entity (Current_Sem_Unit);
3524
3525                            begin
3526                               --  Check if duplication OK and if so continue
3527                               --  processing.
3528
3529                               if Restriction_Active (No_Elaboration_Code)
3530                                 or else Restriction_Active (No_Implicit_Loops)
3531                                 or else Is_Preelaborated (P)
3532                                 or else (Ekind (P) = E_Package_Body
3533                                           and then
3534                                             Is_Preelaborated (Spec_Entity (P)))
3535                                 or else
3536                                   Is_Predefined_File_Name
3537                                     (Unit_File_Name (Get_Source_Unit (P)))
3538                               then
3539                                  null;
3540
3541                               --  If duplication not OK, then we return False
3542                               --  if the replication count is too high
3543
3544                               elsif Rep_Count > Max_Others_Replicate then
3545                                  return False;
3546
3547                               --  Continue on if duplication not OK, but the
3548                               --  replication count is not excessive.
3549
3550                               else
3551                                  null;
3552                               end if;
3553                            end;
3554                         end if;
3555                      end loop;
3556
3557                      exit Component_Loop;
3558
3559                   --  Case of a subtype mark, identifier or expanded name
3560
3561                   elsif Is_Entity_Name (Choice)
3562                     and then Is_Type (Entity (Choice))
3563                   then
3564                      Lo := Type_Low_Bound  (Etype (Choice));
3565                      Hi := Type_High_Bound (Etype (Choice));
3566
3567                   --  Case of subtype indication
3568
3569                   elsif Nkind (Choice) = N_Subtype_Indication then
3570                      Lo := Low_Bound  (Range_Expression (Constraint (Choice)));
3571                      Hi := High_Bound (Range_Expression (Constraint (Choice)));
3572
3573                   --  Case of a range
3574
3575                   elsif Nkind (Choice) = N_Range then
3576                      Lo := Low_Bound (Choice);
3577                      Hi := High_Bound (Choice);
3578
3579                   --  Normal subexpression case
3580
3581                   else pragma Assert (Nkind (Choice) in N_Subexpr);
3582                      if not Compile_Time_Known_Value (Choice) then
3583                         return False;
3584
3585                      else
3586                         Choice_Index := UI_To_Int (Expr_Value (Choice));
3587                         if Choice_Index in Vals'Range then
3588                            Vals (Choice_Index) :=
3589                              New_Copy_Tree (Expression (Elmt));
3590                            goto Continue;
3591
3592                         else
3593                            --  Choice is statically out-of-range, will be
3594                            --  rewritten to raise Constraint_Error.
3595
3596                            return False;
3597                         end if;
3598                      end if;
3599                   end if;
3600
3601                   --  Range cases merge with Lo,Hi set
3602
3603                   if not Compile_Time_Known_Value (Lo)
3604                        or else
3605                      not Compile_Time_Known_Value (Hi)
3606                   then
3607                      return False;
3608                   else
3609                      for J in UI_To_Int (Expr_Value (Lo)) ..
3610                               UI_To_Int (Expr_Value (Hi))
3611                      loop
3612                         Vals (J) := New_Copy_Tree (Expression (Elmt));
3613                      end loop;
3614                   end if;
3615
3616                <<Continue>>
3617                   Next (Choice);
3618                end loop Choice_Loop;
3619
3620                Next (Elmt);
3621             end loop Component_Loop;
3622
3623             --  If we get here the conversion is possible
3624
3625             Vlist := New_List;
3626             for J in Vals'Range loop
3627                Append (Vals (J), Vlist);
3628             end loop;
3629
3630             Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist));
3631             Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N)));
3632             return True;
3633          end;
3634       end Flatten;
3635
3636       -------------
3637       -- Is_Flat --
3638       -------------
3639
3640       function Is_Flat (N : Node_Id; Dims : Int) return Boolean is
3641          Elmt : Node_Id;
3642
3643       begin
3644          if Dims = 0 then
3645             return True;
3646
3647          elsif Nkind (N) = N_Aggregate then
3648             if Present (Component_Associations (N)) then
3649                return False;
3650
3651             else
3652                Elmt := First (Expressions (N));
3653                while Present (Elmt) loop
3654                   if not Is_Flat (Elmt, Dims - 1) then
3655                      return False;
3656                   end if;
3657
3658                   Next (Elmt);
3659                end loop;
3660
3661                return True;
3662             end if;
3663          else
3664             return True;
3665          end if;
3666       end Is_Flat;
3667
3668    --  Start of processing for Convert_To_Positional
3669