OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [exp_aggr.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
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-2009, 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_Ch7;  use Exp_Ch7;
36
with Exp_Ch9;  use Exp_Ch9;
37
with Exp_Tss;  use Exp_Tss;
38
with Fname;    use Fname;
39
with Freeze;   use Freeze;
40
with Itypes;   use Itypes;
41
with Lib;      use Lib;
42
with Namet;    use Namet;
43
with Nmake;    use Nmake;
44
with Nlists;   use Nlists;
45
with Opt;      use Opt;
46
with Restrict; use Restrict;
47
with Rident;   use Rident;
48
with Rtsfind;  use Rtsfind;
49
with Ttypes;   use Ttypes;
50
with Sem;      use Sem;
51
with Sem_Aux;  use Sem_Aux;
52
with Sem_Ch3;  use Sem_Ch3;
53
with Sem_Eval; use Sem_Eval;
54
with Sem_Res;  use Sem_Res;
55
with Sem_Util; use Sem_Util;
56
with Sinfo;    use Sinfo;
57
with Snames;   use Snames;
58
with Stand;    use Stand;
59
with Targparm; use Targparm;
60
with Tbuild;   use Tbuild;
61
with Uintp;    use Uintp;
62
 
63
package body Exp_Aggr is
64
 
65
   type Case_Bounds is record
66
     Choice_Lo   : Node_Id;
67
     Choice_Hi   : Node_Id;
68
     Choice_Node : Node_Id;
69
   end record;
70
 
71
   type Case_Table_Type is array (Nat range <>) of Case_Bounds;
72
   --  Table type used by Check_Case_Choices procedure
73
 
74
   function Must_Slide
75
     (Obj_Type : Entity_Id;
76
      Typ      : Entity_Id) return Boolean;
77
   --  A static array aggregate in an object declaration can in most cases be
78
   --  expanded in place. The one exception is when the aggregate is given
79
   --  with component associations that specify different bounds from those of
80
   --  the type definition in the object declaration. In this pathological
81
   --  case the aggregate must slide, and we must introduce an intermediate
82
   --  temporary to hold it.
83
   --
84
   --  The same holds in an assignment to one-dimensional array of arrays,
85
   --  when a component may be given with bounds that differ from those of the
86
   --  component type.
87
 
88
   procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
89
   --  Sort the Case Table using the Lower Bound of each Choice as the key.
90
   --  A simple insertion sort is used since the number of choices in a case
91
   --  statement of variant part will usually be small and probably in near
92
   --  sorted order.
93
 
94
   function Has_Default_Init_Comps (N : Node_Id) return Boolean;
95
   --  N is an aggregate (record or array). Checks the presence of default
96
   --  initialization (<>) in any component (Ada 2005: AI-287)
97
 
98
   function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean;
99
   --  Returns true if N is an aggregate used to initialize the components
100
   --  of an statically allocated dispatch table.
101
 
102
   ------------------------------------------------------
103
   -- Local subprograms for Record Aggregate Expansion --
104
   ------------------------------------------------------
105
 
106
   procedure Expand_Record_Aggregate
107
     (N           : Node_Id;
108
      Orig_Tag    : Node_Id := Empty;
109
      Parent_Expr : Node_Id := Empty);
110
   --  This is the top level procedure for record aggregate expansion.
111
   --  Expansion for record aggregates needs expand aggregates for tagged
112
   --  record types. Specifically Expand_Record_Aggregate adds the Tag
113
   --  field in front of the Component_Association list that was created
114
   --  during resolution by Resolve_Record_Aggregate.
115
   --
116
   --    N is the record aggregate node.
117
   --    Orig_Tag is the value of the Tag that has to be provided for this
118
   --      specific aggregate. It carries the tag corresponding to the type
119
   --      of the outermost aggregate during the recursive expansion
120
   --    Parent_Expr is the ancestor part of the original extension
121
   --      aggregate
122
 
123
   procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
124
   --  N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
125
   --  aggregate (which can only be a record type, this procedure is only used
126
   --  for record types). Transform the given aggregate into a sequence of
127
   --  assignments performed component by component.
128
 
129
   function Build_Record_Aggr_Code
130
     (N                             : Node_Id;
131
      Typ                           : Entity_Id;
132
      Lhs                           : Node_Id;
133
      Flist                         : Node_Id   := Empty;
134
      Obj                           : Entity_Id := Empty;
135
      Is_Limited_Ancestor_Expansion : Boolean   := False) return List_Id;
136
   --  N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
137
   --  aggregate. Target is an expression containing the location on which the
138
   --  component by component assignments will take place. Returns the list of
139
   --  assignments plus all other adjustments needed for tagged and controlled
140
   --  types. Flist is an expression representing the finalization list on
141
   --  which to attach the controlled components if any. Obj is present in the
142
   --  object declaration and dynamic allocation cases, it contains an entity
143
   --  that allows to know if the value being created needs to be attached to
144
   --  the final list in case of pragma Finalize_Storage_Only.
145
   --
146
   --  ???
147
   --  The meaning of the Obj formal is extremely unclear. *What* entity
148
   --  should be passed? For the object declaration case we may guess that
149
   --  this is the object being declared, but what about the allocator case?
150
   --
151
   --  Is_Limited_Ancestor_Expansion indicates that the function has been
152
   --  called recursively to expand the limited ancestor to avoid copying it.
153
 
154
   function Has_Mutable_Components (Typ : Entity_Id) return Boolean;
155
   --  Return true if one of the component is of a discriminated type with
156
   --  defaults. An aggregate for a type with mutable components must be
157
   --  expanded into individual assignments.
158
 
159
   procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);
160
   --  If the type of the aggregate is a type extension with renamed discrimi-
161
   --  nants, we must initialize the hidden discriminants of the parent.
162
   --  Otherwise, the target object must not be initialized. The discriminants
163
   --  are initialized by calling the initialization procedure for the type.
164
   --  This is incorrect if the initialization of other components has any
165
   --  side effects. We restrict this call to the case where the parent type
166
   --  has a variant part, because this is the only case where the hidden
167
   --  discriminants are accessed, namely when calling discriminant checking
168
   --  functions of the parent type, and when applying a stream attribute to
169
   --  an object of the derived type.
170
 
171
   -----------------------------------------------------
172
   -- Local Subprograms for Array Aggregate Expansion --
173
   -----------------------------------------------------
174
 
175
   function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean;
176
   --  Very large static aggregates present problems to the back-end, and
177
   --  are transformed into assignments and loops. This function verifies
178
   --  that the total number of components of an aggregate is acceptable
179
   --  for transformation into a purely positional static form. It is called
180
   --  prior to calling Flatten.
181
   --  This function also detects and warns about one-component aggregates
182
   --  that appear in a non-static context. Even if the component value is
183
   --  static, such an aggregate must be expanded into an assignment.
184
 
185
   procedure Convert_Array_Aggr_In_Allocator
186
     (Decl   : Node_Id;
187
      Aggr   : Node_Id;
188
      Target : Node_Id);
189
   --  If the aggregate appears within an allocator and can be expanded in
190
   --  place, this routine generates the individual assignments to components
191
   --  of the designated object. This is an optimization over the general
192
   --  case, where a temporary is first created on the stack and then used to
193
   --  construct the allocated object on the heap.
194
 
195
   procedure Convert_To_Positional
196
     (N                    : Node_Id;
197
      Max_Others_Replicate : Nat     := 5;
198
      Handle_Bit_Packed    : Boolean := False);
199
   --  If possible, convert named notation to positional notation. This
200
   --  conversion is possible only in some static cases. If the conversion is
201
   --  possible, then N is rewritten with the analyzed converted aggregate.
202
   --  The parameter Max_Others_Replicate controls the maximum number of
203
   --  values corresponding to an others choice that will be converted to
204
   --  positional notation (the default of 5 is the normal limit, and reflects
205
   --  the fact that normally the loop is better than a lot of separate
206
   --  assignments). Note that this limit gets overridden in any case if
207
   --  either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
208
   --  set. The parameter Handle_Bit_Packed is usually set False (since we do
209
   --  not expect the back end to handle bit packed arrays, so the normal case
210
   --  of conversion is pointless), but in the special case of a call from
211
   --  Packed_Array_Aggregate_Handled, we set this parameter to True, since
212
   --  these are cases we handle in there.
213
 
214
   procedure Expand_Array_Aggregate (N : Node_Id);
215
   --  This is the top-level routine to perform array aggregate expansion.
216
   --  N is the N_Aggregate node to be expanded.
217
 
218
   function Backend_Processing_Possible (N : Node_Id) return Boolean;
219
   --  This function checks if array aggregate N can be processed directly
220
   --  by the backend. If this is the case True is returned.
221
 
222
   function Build_Array_Aggr_Code
223
     (N           : Node_Id;
224
      Ctype       : Entity_Id;
225
      Index       : Node_Id;
226
      Into        : Node_Id;
227
      Scalar_Comp : Boolean;
228
      Indices     : List_Id := No_List;
229
      Flist       : Node_Id := Empty) return List_Id;
230
   --  This recursive routine returns a list of statements containing the
231
   --  loops and assignments that are needed for the expansion of the array
232
   --  aggregate N.
233
   --
234
   --    N is the (sub-)aggregate node to be expanded into code. This node
235
   --    has been fully analyzed, and its Etype is properly set.
236
   --
237
   --    Index is the index node corresponding to the array sub-aggregate N.
238
   --
239
   --    Into is the target expression into which we are copying the aggregate.
240
   --    Note that this node may not have been analyzed yet, and so the Etype
241
   --    field may not be set.
242
   --
243
   --    Scalar_Comp is True if the component type of the aggregate is scalar.
244
   --
245
   --    Indices is the current list of expressions used to index the
246
   --    object we are writing into.
247
   --
248
   --    Flist is an expression representing the finalization list on which
249
   --    to attach the controlled components if any.
250
 
251
   function Number_Of_Choices (N : Node_Id) return Nat;
252
   --  Returns the number of discrete choices (not including the others choice
253
   --  if present) contained in (sub-)aggregate N.
254
 
255
   function Late_Expansion
256
     (N      : Node_Id;
257
      Typ    : Entity_Id;
258
      Target : Node_Id;
259
      Flist  : Node_Id := Empty;
260
      Obj    : Entity_Id := Empty) return List_Id;
261
   --  N is a nested (record or array) aggregate that has been marked with
262
   --  'Delay_Expansion'. Typ is the expected type of the aggregate and Target
263
   --  is a (duplicable) expression that will hold the result of the aggregate
264
   --  expansion. Flist is the finalization list to be used to attach
265
   --  controlled components. 'Obj' when non empty, carries the original
266
   --  object being initialized in order to know if it needs to be attached to
267
   --  the previous parameter which may not be the case in the case where
268
   --  Finalize_Storage_Only is set. Basically this procedure is used to
269
   --  implement top-down expansions of nested aggregates. This is necessary
270
   --  for avoiding temporaries at each level as well as for propagating the
271
   --  right internal finalization list.
272
 
273
   function Make_OK_Assignment_Statement
274
     (Sloc       : Source_Ptr;
275
      Name       : Node_Id;
276
      Expression : Node_Id) return Node_Id;
277
   --  This is like Make_Assignment_Statement, except that Assignment_OK
278
   --  is set in the left operand. All assignments built by this unit
279
   --  use this routine. This is needed to deal with assignments to
280
   --  initialized constants that are done in place.
281
 
282
   function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
283
   --  Given an array aggregate, this function handles the case of a packed
284
   --  array aggregate with all constant values, where the aggregate can be
285
   --  evaluated at compile time. If this is possible, then N is rewritten
286
   --  to be its proper compile time value with all the components properly
287
   --  assembled. The expression is analyzed and resolved and True is
288
   --  returned. If this transformation is not possible, N is unchanged
289
   --  and False is returned
290
 
291
   function Safe_Slice_Assignment (N : Node_Id) return Boolean;
292
   --  If a slice assignment has an aggregate with a single others_choice,
293
   --  the assignment can be done in place even if bounds are not static,
294
   --  by converting it into a loop over the discrete range of the slice.
295
 
296
   ------------------
297
   -- Aggr_Size_OK --
298
   ------------------
299
 
300
   function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean is
301
      Lo   : Node_Id;
302
      Hi   : Node_Id;
303
      Indx : Node_Id;
304
      Siz  : Int;
305
      Lov  : Uint;
306
      Hiv  : Uint;
307
 
308
      --  The following constant determines the maximum size of an
309
      --  array aggregate produced by converting named to positional
310
      --  notation (e.g. from others clauses). This avoids running
311
      --  away with attempts to convert huge aggregates, which hit
312
      --  memory limits in the backend.
313
 
314
      --  The normal limit is 5000, but we increase this limit to
315
      --  2**24 (about 16 million) if Restrictions (No_Elaboration_Code)
316
      --  or Restrictions (No_Implicit_Loops) is specified, since in
317
      --  either case, we are at risk of declaring the program illegal
318
      --  because of this limit.
319
 
320
      Max_Aggr_Size : constant Nat :=
321
                        5000 + (2 ** 24 - 5000) *
322
                          Boolean'Pos
323
                            (Restriction_Active (No_Elaboration_Code)
324
                               or else
325
                             Restriction_Active (No_Implicit_Loops));
326
 
327
      function Component_Count (T : Entity_Id) return Int;
328
      --  The limit is applied to the total number of components that the
329
      --  aggregate will have, which is the number of static expressions
330
      --  that will appear in the flattened array. This requires a recursive
331
      --  computation of the number of scalar components of the structure.
332
 
333
      ---------------------
334
      -- Component_Count --
335
      ---------------------
336
 
337
      function Component_Count (T : Entity_Id) return Int is
338
         Res  : Int := 0;
339
         Comp : Entity_Id;
340
 
341
      begin
342
         if Is_Scalar_Type (T) then
343
            return 1;
344
 
345
         elsif Is_Record_Type (T) then
346
            Comp := First_Component (T);
347
            while Present (Comp) loop
348
               Res := Res + Component_Count (Etype (Comp));
349
               Next_Component (Comp);
350
            end loop;
351
 
352
            return Res;
353
 
354
         elsif Is_Array_Type (T) then
355
            declare
356
               Lo : constant Node_Id :=
357
                      Type_Low_Bound (Etype (First_Index (T)));
358
               Hi : constant Node_Id :=
359
                      Type_High_Bound (Etype (First_Index (T)));
360
 
361
               Siz  : constant Int := Component_Count (Component_Type (T));
362
 
363
            begin
364
               if not Compile_Time_Known_Value (Lo)
365
                 or else not Compile_Time_Known_Value (Hi)
366
               then
367
                  return 0;
368
               else
369
                  return
370
                    Siz * UI_To_Int (Expr_Value (Hi) - Expr_Value (Lo) + 1);
371
               end if;
372
            end;
373
 
374
         else
375
            --  Can only be a null for an access type
376
 
377
            return 1;
378
         end if;
379
      end Component_Count;
380
 
381
   --  Start of processing for Aggr_Size_OK
382
 
383
   begin
384
      Siz  := Component_Count (Component_Type (Typ));
385
 
386
      Indx := First_Index (Typ);
387
      while Present (Indx) loop
388
         Lo  := Type_Low_Bound (Etype (Indx));
389
         Hi  := Type_High_Bound (Etype (Indx));
390
 
391
         --  Bounds need to be known at compile time
392
 
393
         if not Compile_Time_Known_Value (Lo)
394
           or else not Compile_Time_Known_Value (Hi)
395
         then
396
            return False;
397
         end if;
398
 
399
         Lov := Expr_Value (Lo);
400
         Hiv := Expr_Value (Hi);
401
 
402
         --  A flat array is always safe
403
 
404
         if Hiv < Lov then
405
            return True;
406
         end if;
407
 
408
         --  One-component aggregates are suspicious, and if the context type
409
         --  is an object declaration with non-static bounds it will trip gcc;
410
         --  such an aggregate must be expanded into a single assignment.
411
 
412
         if Hiv = Lov
413
           and then Nkind (Parent (N)) = N_Object_Declaration
414
         then
415
            declare
416
               Index_Type : constant Entity_Id :=
417
                              Etype
418
                                (First_Index
419
                                   (Etype (Defining_Identifier (Parent (N)))));
420
               Indx       : Node_Id;
421
 
422
            begin
423
               if not Compile_Time_Known_Value (Type_Low_Bound (Index_Type))
424
                  or else not Compile_Time_Known_Value
425
                                (Type_High_Bound (Index_Type))
426
               then
427
                  if Present (Component_Associations (N)) then
428
                     Indx :=
429
                       First (Choices (First (Component_Associations (N))));
430
                     if Is_Entity_Name (Indx)
431
                       and then not Is_Type (Entity (Indx))
432
                     then
433
                        Error_Msg_N
434
                          ("single component aggregate in non-static context?",
435
                            Indx);
436
                        Error_Msg_N ("\maybe subtype name was meant?", Indx);
437
                     end if;
438
                  end if;
439
 
440
                  return False;
441
               end if;
442
            end;
443
         end if;
444
 
445
         declare
446
            Rng : constant Uint := Hiv - Lov + 1;
447
 
448
         begin
449
            --  Check if size is too large
450
 
451
            if not UI_Is_In_Int_Range (Rng) then
452
               return False;
453
            end if;
454
 
455
            Siz := Siz * UI_To_Int (Rng);
456
         end;
457
 
458
         if Siz <= 0
459
           or else Siz > Max_Aggr_Size
460
         then
461
            return False;
462
         end if;
463
 
464
         --  Bounds must be in integer range, for later array construction
465
 
466
         if not UI_Is_In_Int_Range (Lov)
467
             or else
468
            not UI_Is_In_Int_Range (Hiv)
469
         then
470
            return False;
471
         end if;
472
 
473
         Next_Index (Indx);
474
      end loop;
475
 
476
      return True;
477
   end Aggr_Size_OK;
478
 
479
   ---------------------------------
480
   -- Backend_Processing_Possible --
481
   ---------------------------------
482
 
483
   --  Backend processing by Gigi/gcc is possible only if all the following
484
   --  conditions are met:
485
 
486
   --    1. N is fully positional
487
 
488
   --    2. N is not a bit-packed array aggregate;
489
 
490
   --    3. The size of N's array type must be known at compile time. Note
491
   --       that this implies that the component size is also known
492
 
493
   --    4. The array type of N does not follow the Fortran layout convention
494
   --       or if it does it must be 1 dimensional.
495
 
496
   --    5. The array component type may not be tagged (which could necessitate
497
   --       reassignment of proper tags).
498
 
499
   --    6. The array component type must not have unaligned bit components
500
 
501
   --    7. None of the components of the aggregate may be bit unaligned
502
   --       components.
503
 
504
   --    8. There cannot be delayed components, since we do not know enough
505
   --       at this stage to know if back end processing is possible.
506
 
507
   --    9. There cannot be any discriminated record components, since the
508
   --       back end cannot handle this complex case.
509
 
510
   --   10. No controlled actions need to be generated for components
511
 
512
   --   11. For a VM back end, the array should have no aliased components
513
 
514
   function Backend_Processing_Possible (N : Node_Id) return Boolean is
515
      Typ : constant Entity_Id := Etype (N);
516
      --  Typ is the correct constrained array subtype of the aggregate
517
 
518
      function Component_Check (N : Node_Id; Index : Node_Id) return Boolean;
519
      --  This routine checks components of aggregate N, enforcing checks
520
      --  1, 7, 8, and 9. In the multi-dimensional case, these checks are
521
      --  performed on subaggregates. The Index value is the current index
522
      --  being checked in the multi-dimensional case.
523
 
524
      ---------------------
525
      -- Component_Check --
526
      ---------------------
527
 
528
      function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is
529
         Expr : Node_Id;
530
 
531
      begin
532
         --  Checks 1: (no component associations)
533
 
534
         if Present (Component_Associations (N)) then
535
            return False;
536
         end if;
537
 
538
         --  Checks on components
539
 
540
         --  Recurse to check subaggregates, which may appear in qualified
541
         --  expressions. If delayed, the front-end will have to expand.
542
         --  If the component is a discriminated record, treat as non-static,
543
         --  as the back-end cannot handle this properly.
544
 
545
         Expr := First (Expressions (N));
546
         while Present (Expr) loop
547
 
548
            --  Checks 8: (no delayed components)
549
 
550
            if Is_Delayed_Aggregate (Expr) then
551
               return False;
552
            end if;
553
 
554
            --  Checks 9: (no discriminated records)
555
 
556
            if Present (Etype (Expr))
557
              and then Is_Record_Type (Etype (Expr))
558
              and then Has_Discriminants (Etype (Expr))
559
            then
560
               return False;
561
            end if;
562
 
563
            --  Checks 7. Component must not be bit aligned component
564
 
565
            if Possible_Bit_Aligned_Component (Expr) then
566
               return False;
567
            end if;
568
 
569
            --  Recursion to following indexes for multiple dimension case
570
 
571
            if Present (Next_Index (Index))
572
               and then not Component_Check (Expr, Next_Index (Index))
573
            then
574
               return False;
575
            end if;
576
 
577
            --  All checks for that component finished, on to next
578
 
579
            Next (Expr);
580
         end loop;
581
 
582
         return True;
583
      end Component_Check;
584
 
585
   --  Start of processing for Backend_Processing_Possible
586
 
587
   begin
588
      --  Checks 2 (array not bit packed) and 10 (no controlled actions)
589
 
590
      if Is_Bit_Packed_Array (Typ) or else Needs_Finalization (Typ) then
591
         return False;
592
      end if;
593
 
594
      --  If component is limited, aggregate must be expanded because each
595
      --  component assignment must be built in place.
596
 
597
      if Is_Inherently_Limited_Type (Component_Type (Typ)) then
598
         return False;
599
      end if;
600
 
601
      --  Checks 4 (array must not be multi-dimensional Fortran case)
602
 
603
      if Convention (Typ) = Convention_Fortran
604
        and then Number_Dimensions (Typ) > 1
605
      then
606
         return False;
607
      end if;
608
 
609
      --  Checks 3 (size of array must be known at compile time)
610
 
611
      if not Size_Known_At_Compile_Time (Typ) then
612
         return False;
613
      end if;
614
 
615
      --  Checks on components
616
 
617
      if not Component_Check (N, First_Index (Typ)) then
618
         return False;
619
      end if;
620
 
621
      --  Checks 5 (if the component type is tagged, then we may need to do
622
      --    tag adjustments. Perhaps this should be refined to check for any
623
      --    component associations that actually need tag adjustment, similar
624
      --    to the test in Component_Not_OK_For_Backend for record aggregates
625
      --    with tagged components, but not clear whether it's worthwhile ???;
626
      --    in the case of the JVM, object tags are handled implicitly)
627
 
628
      if Is_Tagged_Type (Component_Type (Typ))
629
        and then Tagged_Type_Expansion
630
      then
631
         return False;
632
      end if;
633
 
634
      --  Checks 6 (component type must not have bit aligned components)
635
 
636
      if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then
637
         return False;
638
      end if;
639
 
640
      --  Checks 11: Array aggregates with aliased components are currently
641
      --  not well supported by the VM backend; disable temporarily this
642
      --  backend processing until it is definitely supported.
643
 
644
      if VM_Target /= No_VM
645
        and then Has_Aliased_Components (Base_Type (Typ))
646
      then
647
         return False;
648
      end if;
649
 
650
      --  Backend processing is possible
651
 
652
      Set_Size_Known_At_Compile_Time (Etype (N), True);
653
      return True;
654
   end Backend_Processing_Possible;
655
 
656
   ---------------------------
657
   -- Build_Array_Aggr_Code --
658
   ---------------------------
659
 
660
   --  The code that we generate from a one dimensional aggregate is
661
 
662
   --  1. If the sub-aggregate contains discrete choices we
663
 
664
   --     (a) Sort the discrete choices
665
 
666
   --     (b) Otherwise for each discrete choice that specifies a range we
667
   --         emit a loop. If a range specifies a maximum of three values, or
668
   --         we are dealing with an expression we emit a sequence of
669
   --         assignments instead of a loop.
670
 
671
   --     (c) Generate the remaining loops to cover the others choice if any
672
 
673
   --  2. If the aggregate contains positional elements we
674
 
675
   --     (a) translate the positional elements in a series of assignments
676
 
677
   --     (b) Generate a final loop to cover the others choice if any.
678
   --         Note that this final loop has to be a while loop since the case
679
 
680
   --             L : Integer := Integer'Last;
681
   --             H : Integer := Integer'Last;
682
   --             A : array (L .. H) := (1, others =>0);
683
 
684
   --         cannot be handled by a for loop. Thus for the following
685
 
686
   --             array (L .. H) := (.. positional elements.., others =>E);
687
 
688
   --         we always generate something like:
689
 
690
   --             J : Index_Type := Index_Of_Last_Positional_Element;
691
   --             while J < H loop
692
   --                J := Index_Base'Succ (J)
693
   --                Tmp (J) := E;
694
   --             end loop;
695
 
696
   function Build_Array_Aggr_Code
697
     (N           : Node_Id;
698
      Ctype       : Entity_Id;
699
      Index       : Node_Id;
700
      Into        : Node_Id;
701
      Scalar_Comp : Boolean;
702
      Indices     : List_Id := No_List;
703
      Flist       : Node_Id := Empty) return List_Id
704
   is
705
      Loc          : constant Source_Ptr := Sloc (N);
706
      Index_Base   : constant Entity_Id  := Base_Type (Etype (Index));
707
      Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base);
708
      Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);
709
 
710
      function Add (Val : Int; To : Node_Id) return Node_Id;
711
      --  Returns an expression where Val is added to expression To, unless
712
      --  To+Val is provably out of To's base type range. To must be an
713
      --  already analyzed expression.
714
 
715
      function Empty_Range (L, H : Node_Id) return Boolean;
716
      --  Returns True if the range defined by L .. H is certainly empty
717
 
718
      function Equal (L, H : Node_Id) return Boolean;
719
      --  Returns True if L = H for sure
720
 
721
      function Index_Base_Name return Node_Id;
722
      --  Returns a new reference to the index type name
723
 
724
      function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
725
      --  Ind must be a side-effect free expression. If the input aggregate
726
      --  N to Build_Loop contains no sub-aggregates, then this function
727
      --  returns the assignment statement:
728
      --
729
      --     Into (Indices, Ind) := Expr;
730
      --
731
      --  Otherwise we call Build_Code recursively
732
      --
733
      --  Ada 2005 (AI-287): In case of default initialized component, Expr
734
      --  is empty and we generate a call to the corresponding IP subprogram.
735
 
736
      function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
737
      --  Nodes L and H must be side-effect free expressions.
738
      --  If the input aggregate N to Build_Loop contains no sub-aggregates,
739
      --  This routine returns the for loop statement
740
      --
741
      --     for J in Index_Base'(L) .. Index_Base'(H) loop
742
      --        Into (Indices, J) := Expr;
743
      --     end loop;
744
      --
745
      --  Otherwise we call Build_Code recursively.
746
      --  As an optimization if the loop covers 3 or less scalar elements we
747
      --  generate a sequence of assignments.
748
 
749
      function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
750
      --  Nodes L and H must be side-effect free expressions.
751
      --  If the input aggregate N to Build_Loop contains no sub-aggregates,
752
      --  This routine returns the while loop statement
753
      --
754
      --     J : Index_Base := L;
755
      --     while J < H loop
756
      --        J := Index_Base'Succ (J);
757
      --        Into (Indices, J) := Expr;
758
      --     end loop;
759
      --
760
      --  Otherwise we call Build_Code recursively
761
 
762
      function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
763
      function Local_Expr_Value               (E : Node_Id) return Uint;
764
      --  These two Local routines are used to replace the corresponding ones
765
      --  in sem_eval because while processing the bounds of an aggregate with
766
      --  discrete choices whose index type is an enumeration, we build static
767
      --  expressions not recognized by Compile_Time_Known_Value as such since
768
      --  they have not yet been analyzed and resolved. All the expressions in
769
      --  question are things like Index_Base_Name'Val (Const) which we can
770
      --  easily recognize as being constant.
771
 
772
      ---------
773
      -- Add --
774
      ---------
775
 
776
      function Add (Val : Int; To : Node_Id) return Node_Id is
777
         Expr_Pos : Node_Id;
778
         Expr     : Node_Id;
779
         To_Pos   : Node_Id;
780
         U_To     : Uint;
781
         U_Val    : constant Uint := UI_From_Int (Val);
782
 
783
      begin
784
         --  Note: do not try to optimize the case of Val = 0, because
785
         --  we need to build a new node with the proper Sloc value anyway.
786
 
787
         --  First test if we can do constant folding
788
 
789
         if Local_Compile_Time_Known_Value (To) then
790
            U_To := Local_Expr_Value (To) + Val;
791
 
792
            --  Determine if our constant is outside the range of the index.
793
            --  If so return an Empty node. This empty node will be caught
794
            --  by Empty_Range below.
795
 
796
            if Compile_Time_Known_Value (Index_Base_L)
797
              and then U_To < Expr_Value (Index_Base_L)
798
            then
799
               return Empty;
800
 
801
            elsif Compile_Time_Known_Value (Index_Base_H)
802
              and then U_To > Expr_Value (Index_Base_H)
803
            then
804
               return Empty;
805
            end if;
806
 
807
            Expr_Pos := Make_Integer_Literal (Loc, U_To);
808
            Set_Is_Static_Expression (Expr_Pos);
809
 
810
            if not Is_Enumeration_Type (Index_Base) then
811
               Expr := Expr_Pos;
812
 
813
            --  If we are dealing with enumeration return
814
            --     Index_Base'Val (Expr_Pos)
815
 
816
            else
817
               Expr :=
818
                 Make_Attribute_Reference
819
                   (Loc,
820
                    Prefix         => Index_Base_Name,
821
                    Attribute_Name => Name_Val,
822
                    Expressions    => New_List (Expr_Pos));
823
            end if;
824
 
825
            return Expr;
826
         end if;
827
 
828
         --  If we are here no constant folding possible
829
 
830
         if not Is_Enumeration_Type (Index_Base) then
831
            Expr :=
832
              Make_Op_Add (Loc,
833
                           Left_Opnd  => Duplicate_Subexpr (To),
834
                           Right_Opnd => Make_Integer_Literal (Loc, U_Val));
835
 
836
         --  If we are dealing with enumeration return
837
         --    Index_Base'Val (Index_Base'Pos (To) + Val)
838
 
839
         else
840
            To_Pos :=
841
              Make_Attribute_Reference
842
                (Loc,
843
                 Prefix         => Index_Base_Name,
844
                 Attribute_Name => Name_Pos,
845
                 Expressions    => New_List (Duplicate_Subexpr (To)));
846
 
847
            Expr_Pos :=
848
              Make_Op_Add (Loc,
849
                           Left_Opnd  => To_Pos,
850
                           Right_Opnd => Make_Integer_Literal (Loc, U_Val));
851
 
852
            Expr :=
853
              Make_Attribute_Reference
854
                (Loc,
855
                 Prefix         => Index_Base_Name,
856
                 Attribute_Name => Name_Val,
857
                 Expressions    => New_List (Expr_Pos));
858
         end if;
859
 
860
         return Expr;
861
      end Add;
862
 
863
      -----------------
864
      -- Empty_Range --
865
      -----------------
866
 
867
      function Empty_Range (L, H : Node_Id) return Boolean is
868
         Is_Empty : Boolean := False;
869
         Low      : Node_Id;
870
         High     : Node_Id;
871
 
872
      begin
873
         --  First check if L or H were already detected as overflowing the
874
         --  index base range type by function Add above. If this is so Add
875
         --  returns the empty node.
876
 
877
         if No (L) or else No (H) then
878
            return True;
879
         end if;
880
 
881
         for J in 1 .. 3 loop
882
            case J is
883
 
884
               --  L > H    range is empty
885
 
886
               when 1 =>
887
                  Low  := L;
888
                  High := H;
889
 
890
               --  B_L > H  range must be empty
891
 
892
               when 2 =>
893
                  Low  := Index_Base_L;
894
                  High := H;
895
 
896
               --  L > B_H  range must be empty
897
 
898
               when 3 =>
899
                  Low  := L;
900
                  High := Index_Base_H;
901
            end case;
902
 
903
            if Local_Compile_Time_Known_Value (Low)
904
              and then Local_Compile_Time_Known_Value (High)
905
            then
906
               Is_Empty :=
907
                 UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High));
908
            end if;
909
 
910
            exit when Is_Empty;
911
         end loop;
912
 
913
         return Is_Empty;
914
      end Empty_Range;
915
 
916
      -----------
917
      -- Equal --
918
      -----------
919
 
920
      function Equal (L, H : Node_Id) return Boolean is
921
      begin
922
         if L = H then
923
            return True;
924
 
925
         elsif Local_Compile_Time_Known_Value (L)
926
           and then Local_Compile_Time_Known_Value (H)
927
         then
928
            return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H));
929
         end if;
930
 
931
         return False;
932
      end Equal;
933
 
934
      ----------------
935
      -- Gen_Assign --
936
      ----------------
937
 
938
      function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
939
         L : constant List_Id := New_List;
940
         F : Entity_Id;
941
         A : Node_Id;
942
 
943
         New_Indices  : List_Id;
944
         Indexed_Comp : Node_Id;
945
         Expr_Q       : Node_Id;
946
         Comp_Type    : Entity_Id := Empty;
947
 
948
         function Add_Loop_Actions (Lis : List_Id) return List_Id;
949
         --  Collect insert_actions generated in the construction of a
950
         --  loop, and prepend them to the sequence of assignments to
951
         --  complete the eventual body of the loop.
952
 
953
         ----------------------
954
         -- Add_Loop_Actions --
955
         ----------------------
956
 
957
         function Add_Loop_Actions (Lis : List_Id) return List_Id is
958
            Res : List_Id;
959
 
960
         begin
961
            --  Ada 2005 (AI-287): Do nothing else in case of default
962
            --  initialized component.
963
 
964
            if No (Expr) then
965
               return Lis;
966
 
967
            elsif Nkind (Parent (Expr)) = N_Component_Association
968
              and then Present (Loop_Actions (Parent (Expr)))
969
            then
970
               Append_List (Lis, Loop_Actions (Parent (Expr)));
971
               Res := Loop_Actions (Parent (Expr));
972
               Set_Loop_Actions (Parent (Expr), No_List);
973
               return Res;
974
 
975
            else
976
               return Lis;
977
            end if;
978
         end Add_Loop_Actions;
979
 
980
      --  Start of processing for Gen_Assign
981
 
982
      begin
983
         if No (Indices) then
984
            New_Indices := New_List;
985
         else
986
            New_Indices := New_Copy_List_Tree (Indices);
987
         end if;
988
 
989
         Append_To (New_Indices, Ind);
990
 
991
         if Present (Flist) then
992
            F := New_Copy_Tree (Flist);
993
 
994
         elsif Present (Etype (N)) and then Needs_Finalization (Etype (N)) then
995
            if Is_Entity_Name (Into)
996
              and then Present (Scope (Entity (Into)))
997
            then
998
               F := Find_Final_List (Scope (Entity (Into)));
999
            else
1000
               F := Find_Final_List (Current_Scope);
1001
            end if;
1002
         else
1003
            F := Empty;
1004
         end if;
1005
 
1006
         if Present (Next_Index (Index)) then
1007
            return
1008
              Add_Loop_Actions (
1009
                Build_Array_Aggr_Code
1010
                  (N           => Expr,
1011
                   Ctype       => Ctype,
1012
                   Index       => Next_Index (Index),
1013
                   Into        => Into,
1014
                   Scalar_Comp => Scalar_Comp,
1015
                   Indices     => New_Indices,
1016
                   Flist       => F));
1017
         end if;
1018
 
1019
         --  If we get here then we are at a bottom-level (sub-)aggregate
1020
 
1021
         Indexed_Comp :=
1022
           Checks_Off
1023
             (Make_Indexed_Component (Loc,
1024
                Prefix      => New_Copy_Tree (Into),
1025
                Expressions => New_Indices));
1026
 
1027
         Set_Assignment_OK (Indexed_Comp);
1028
 
1029
         --  Ada 2005 (AI-287): In case of default initialized component, Expr
1030
         --  is not present (and therefore we also initialize Expr_Q to empty).
1031
 
1032
         if No (Expr) then
1033
            Expr_Q := Empty;
1034
         elsif Nkind (Expr) = N_Qualified_Expression then
1035
            Expr_Q := Expression (Expr);
1036
         else
1037
            Expr_Q := Expr;
1038
         end if;
1039
 
1040
         if Present (Etype (N))
1041
           and then Etype (N) /= Any_Composite
1042
         then
1043
            Comp_Type := Component_Type (Etype (N));
1044
            pragma Assert (Comp_Type = Ctype); --  AI-287
1045
 
1046
         elsif Present (Next (First (New_Indices))) then
1047
 
1048
            --  Ada 2005 (AI-287): Do nothing in case of default initialized
1049
            --  component because we have received the component type in
1050
            --  the formal parameter Ctype.
1051
 
1052
            --  ??? Some assert pragmas have been added to check if this new
1053
            --      formal can be used to replace this code in all cases.
1054
 
1055
            if Present (Expr) then
1056
 
1057
               --  This is a multidimensional array. Recover the component
1058
               --  type from the outermost aggregate, because subaggregates
1059
               --  do not have an assigned type.
1060
 
1061
               declare
1062
                  P : Node_Id;
1063
 
1064
               begin
1065
                  P := Parent (Expr);
1066
                  while Present (P) loop
1067
                     if Nkind (P) = N_Aggregate
1068
                       and then Present (Etype (P))
1069
                     then
1070
                        Comp_Type := Component_Type (Etype (P));
1071
                        exit;
1072
 
1073
                     else
1074
                        P := Parent (P);
1075
                     end if;
1076
                  end loop;
1077
 
1078
                  pragma Assert (Comp_Type = Ctype); --  AI-287
1079
               end;
1080
            end if;
1081
         end if;
1082
 
1083
         --  Ada 2005 (AI-287): We only analyze the expression in case of non-
1084
         --  default initialized components (otherwise Expr_Q is not present).
1085
 
1086
         if Present (Expr_Q)
1087
           and then Nkind_In (Expr_Q, N_Aggregate, N_Extension_Aggregate)
1088
         then
1089
            --  At this stage the Expression may not have been analyzed yet
1090
            --  because the array aggregate code has not been updated to use
1091
            --  the Expansion_Delayed flag and avoid analysis altogether to
1092
            --  solve the same problem (see Resolve_Aggr_Expr). So let us do
1093
            --  the analysis of non-array aggregates now in order to get the
1094
            --  value of Expansion_Delayed flag for the inner aggregate ???
1095
 
1096
            if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then
1097
               Analyze_And_Resolve (Expr_Q, Comp_Type);
1098
            end if;
1099
 
1100
            if Is_Delayed_Aggregate (Expr_Q) then
1101
 
1102
               --  This is either a subaggregate of a multidimentional array,
1103
               --  or a component of an array type whose component type is
1104
               --  also an array. In the latter case, the expression may have
1105
               --  component associations that provide different bounds from
1106
               --  those of the component type, and sliding must occur. Instead
1107
               --  of decomposing the current aggregate assignment, force the
1108
               --  re-analysis of the assignment, so that a temporary will be
1109
               --  generated in the usual fashion, and sliding will take place.
1110
 
1111
               if Nkind (Parent (N)) = N_Assignment_Statement
1112
                 and then Is_Array_Type (Comp_Type)
1113
                 and then Present (Component_Associations (Expr_Q))
1114
                 and then Must_Slide (Comp_Type, Etype (Expr_Q))
1115
               then
1116
                  Set_Expansion_Delayed (Expr_Q, False);
1117
                  Set_Analyzed (Expr_Q, False);
1118
 
1119
               else
1120
                  return
1121
                    Add_Loop_Actions (
1122
                      Late_Expansion (
1123
                        Expr_Q, Etype (Expr_Q), Indexed_Comp, F));
1124
               end if;
1125
            end if;
1126
         end if;
1127
 
1128
         --  Ada 2005 (AI-287): In case of default initialized component, call
1129
         --  the initialization subprogram associated with the component type.
1130
         --  If the component type is an access type, add an explicit null
1131
         --  assignment, because for the back-end there is an initialization
1132
         --  present for the whole aggregate, and no default initialization
1133
         --  will take place.
1134
 
1135
         --  In addition, if the component type is controlled, we must call
1136
         --  its Initialize procedure explicitly, because there is no explicit
1137
         --  object creation that will invoke it otherwise.
1138
 
1139
         if No (Expr) then
1140
            if Present (Base_Init_Proc (Base_Type (Ctype)))
1141
              or else Has_Task (Base_Type (Ctype))
1142
            then
1143
               Append_List_To (L,
1144
                 Build_Initialization_Call (Loc,
1145
                   Id_Ref            => Indexed_Comp,
1146
                   Typ               => Ctype,
1147
                   With_Default_Init => True));
1148
 
1149
            elsif Is_Access_Type (Ctype) then
1150
               Append_To (L,
1151
                  Make_Assignment_Statement (Loc,
1152
                     Name => Indexed_Comp,
1153
                     Expression => Make_Null (Loc)));
1154
            end if;
1155
 
1156
            if Needs_Finalization (Ctype) then
1157
               Append_List_To (L,
1158
                 Make_Init_Call (
1159
                   Ref         => New_Copy_Tree (Indexed_Comp),
1160
                   Typ         => Ctype,
1161
                   Flist_Ref   => Find_Final_List (Current_Scope),
1162
                   With_Attach => Make_Integer_Literal (Loc, 1)));
1163
            end if;
1164
 
1165
         else
1166
            --  Now generate the assignment with no associated controlled
1167
            --  actions since the target of the assignment may not have been
1168
            --  initialized, it is not possible to Finalize it as expected by
1169
            --  normal controlled assignment. The rest of the controlled
1170
            --  actions are done manually with the proper finalization list
1171
            --  coming from the context.
1172
 
1173
            A :=
1174
              Make_OK_Assignment_Statement (Loc,
1175
                Name       => Indexed_Comp,
1176
                Expression => New_Copy_Tree (Expr));
1177
 
1178
            if Present (Comp_Type) and then Needs_Finalization (Comp_Type) then
1179
               Set_No_Ctrl_Actions (A);
1180
 
1181
               --  If this is an aggregate for an array of arrays, each
1182
               --  sub-aggregate will be expanded as well, and even with
1183
               --  No_Ctrl_Actions the assignments of inner components will
1184
               --  require attachment in their assignments to temporaries.
1185
               --  These temporaries must be finalized for each subaggregate,
1186
               --  to prevent multiple attachments of the same temporary
1187
               --  location to same finalization chain (and consequently
1188
               --  circular lists). To ensure that finalization takes place
1189
               --  for each subaggregate we wrap the assignment in a block.
1190
 
1191
               if Is_Array_Type (Comp_Type)
1192
                 and then Nkind (Expr) = N_Aggregate
1193
               then
1194
                  A :=
1195
                    Make_Block_Statement (Loc,
1196
                      Handled_Statement_Sequence =>
1197
                        Make_Handled_Sequence_Of_Statements (Loc,
1198
                           Statements => New_List (A)));
1199
               end if;
1200
            end if;
1201
 
1202
            Append_To (L, A);
1203
 
1204
            --  Adjust the tag if tagged (because of possible view
1205
            --  conversions), unless compiling for a VM where
1206
            --  tags are implicit.
1207
 
1208
            if Present (Comp_Type)
1209
              and then Is_Tagged_Type (Comp_Type)
1210
              and then Tagged_Type_Expansion
1211
            then
1212
               A :=
1213
                 Make_OK_Assignment_Statement (Loc,
1214
                   Name =>
1215
                     Make_Selected_Component (Loc,
1216
                       Prefix =>  New_Copy_Tree (Indexed_Comp),
1217
                       Selector_Name =>
1218
                         New_Reference_To
1219
                           (First_Tag_Component (Comp_Type), Loc)),
1220
 
1221
                   Expression =>
1222
                     Unchecked_Convert_To (RTE (RE_Tag),
1223
                       New_Reference_To
1224
                         (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
1225
                          Loc)));
1226
 
1227
               Append_To (L, A);
1228
            end if;
1229
 
1230
            --  Adjust and attach the component to the proper final list, which
1231
            --  can be the controller of the outer record object or the final
1232
            --  list associated with the scope.
1233
 
1234
            --  If the component is itself an array of controlled types, whose
1235
            --  value is given by a sub-aggregate, then the attach calls have
1236
            --  been generated when individual subcomponent are assigned, and
1237
            --  must not be done again to prevent malformed finalization chains
1238
            --  (see comments above, concerning the creation of a block to hold
1239
            --  inner finalization actions).
1240
 
1241
            if Present (Comp_Type)
1242
              and then Needs_Finalization (Comp_Type)
1243
              and then not Is_Limited_Type (Comp_Type)
1244
              and then not
1245
                (Is_Array_Type (Comp_Type)
1246
                   and then Is_Controlled (Component_Type (Comp_Type))
1247
                   and then Nkind (Expr) = N_Aggregate)
1248
            then
1249
               Append_List_To (L,
1250
                 Make_Adjust_Call (
1251
                   Ref         => New_Copy_Tree (Indexed_Comp),
1252
                   Typ         => Comp_Type,
1253
                   Flist_Ref   => F,
1254
                   With_Attach => Make_Integer_Literal (Loc, 1)));
1255
            end if;
1256
         end if;
1257
 
1258
         return Add_Loop_Actions (L);
1259
      end Gen_Assign;
1260
 
1261
      --------------
1262
      -- Gen_Loop --
1263
      --------------
1264
 
1265
      function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
1266
         L_J : Node_Id;
1267
 
1268
         L_L : Node_Id;
1269
         --  Index_Base'(L)
1270
 
1271
         L_H : Node_Id;
1272
         --  Index_Base'(H)
1273
 
1274
         L_Range : Node_Id;
1275
         --  Index_Base'(L) .. Index_Base'(H)
1276
 
1277
         L_Iteration_Scheme : Node_Id;
1278
         --  L_J in Index_Base'(L) .. Index_Base'(H)
1279
 
1280
         L_Body : List_Id;
1281
         --  The statements to execute in the loop
1282
 
1283
         S : constant List_Id := New_List;
1284
         --  List of statements
1285
 
1286
         Tcopy : Node_Id;
1287
         --  Copy of expression tree, used for checking purposes
1288
 
1289
      begin
1290
         --  If loop bounds define an empty range return the null statement
1291
 
1292
         if Empty_Range (L, H) then
1293
            Append_To (S, Make_Null_Statement (Loc));
1294
 
1295
            --  Ada 2005 (AI-287): Nothing else need to be done in case of
1296
            --  default initialized component.
1297
 
1298
            if No (Expr) then
1299
               null;
1300
 
1301
            else
1302
               --  The expression must be type-checked even though no component
1303
               --  of the aggregate will have this value. This is done only for
1304
               --  actual components of the array, not for subaggregates. Do
1305
               --  the check on a copy, because the expression may be shared
1306
               --  among several choices, some of which might be non-null.
1307
 
1308
               if Present (Etype (N))
1309
                 and then Is_Array_Type (Etype (N))
1310
                 and then No (Next_Index (Index))
1311
               then
1312
                  Expander_Mode_Save_And_Set (False);
1313
                  Tcopy := New_Copy_Tree (Expr);
1314
                  Set_Parent (Tcopy, N);
1315
                  Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
1316
                  Expander_Mode_Restore;
1317
               end if;
1318
            end if;
1319
 
1320
            return S;
1321
 
1322
         --  If loop bounds are the same then generate an assignment
1323
 
1324
         elsif Equal (L, H) then
1325
            return Gen_Assign (New_Copy_Tree (L), Expr);
1326
 
1327
         --  If H - L <= 2 then generate a sequence of assignments when we are
1328
         --  processing the bottom most aggregate and it contains scalar
1329
         --  components.
1330
 
1331
         elsif No (Next_Index (Index))
1332
           and then Scalar_Comp
1333
           and then Local_Compile_Time_Known_Value (L)
1334
           and then Local_Compile_Time_Known_Value (H)
1335
           and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
1336
         then
1337
 
1338
            Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
1339
            Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
1340
 
1341
            if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then
1342
               Append_List_To (S, Gen_Assign (Add (2, To => L), Expr));
1343
            end if;
1344
 
1345
            return S;
1346
         end if;
1347
 
1348
         --  Otherwise construct the loop, starting with the loop index L_J
1349
 
1350
         L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
1351
 
1352
         --  Construct "L .. H" in Index_Base. We use a qualified expression
1353
         --  for the bound to convert to the index base, but we don't need
1354
         --  to do that if we already have the base type at hand.
1355
 
1356
         if Etype (L) = Index_Base then
1357
            L_L := L;
1358
         else
1359
            L_L :=
1360
              Make_Qualified_Expression (Loc,
1361
                Subtype_Mark => Index_Base_Name,
1362
                Expression   => L);
1363
         end if;
1364
 
1365
         if Etype (H) = Index_Base then
1366
            L_H := H;
1367
         else
1368
            L_H :=
1369
              Make_Qualified_Expression (Loc,
1370
                Subtype_Mark => Index_Base_Name,
1371
                Expression   => H);
1372
         end if;
1373
 
1374
         L_Range :=
1375
           Make_Range (Loc,
1376
             Low_Bound => L_L,
1377
             High_Bound => L_H);
1378
 
1379
         --  Construct "for L_J in Index_Base range L .. H"
1380
 
1381
         L_Iteration_Scheme :=
1382
           Make_Iteration_Scheme
1383
             (Loc,
1384
              Loop_Parameter_Specification =>
1385
                Make_Loop_Parameter_Specification
1386
                  (Loc,
1387
                   Defining_Identifier         => L_J,
1388
                   Discrete_Subtype_Definition => L_Range));
1389
 
1390
         --  Construct the statements to execute in the loop body
1391
 
1392
         L_Body := Gen_Assign (New_Reference_To (L_J, Loc), Expr);
1393
 
1394
         --  Construct the final loop
1395
 
1396
         Append_To (S, Make_Implicit_Loop_Statement
1397
                         (Node             => N,
1398
                          Identifier       => Empty,
1399
                          Iteration_Scheme => L_Iteration_Scheme,
1400
                          Statements       => L_Body));
1401
 
1402
         --  A small optimization: if the aggregate is initialized with a box
1403
         --  and the component type has no initialization procedure, remove the
1404
         --  useless empty loop.
1405
 
1406
         if Nkind (First (S)) = N_Loop_Statement
1407
           and then Is_Empty_List (Statements (First (S)))
1408
         then
1409
            return New_List (Make_Null_Statement (Loc));
1410
         else
1411
            return S;
1412
         end if;
1413
      end Gen_Loop;
1414
 
1415
      ---------------
1416
      -- Gen_While --
1417
      ---------------
1418
 
1419
      --  The code built is
1420
 
1421
      --     W_J : Index_Base := L;
1422
      --     while W_J < H loop
1423
      --        W_J := Index_Base'Succ (W);
1424
      --        L_Body;
1425
      --     end loop;
1426
 
1427
      function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is
1428
         W_J : Node_Id;
1429
 
1430
         W_Decl : Node_Id;
1431
         --  W_J : Base_Type := L;
1432
 
1433
         W_Iteration_Scheme : Node_Id;
1434
         --  while W_J < H
1435
 
1436
         W_Index_Succ : Node_Id;
1437
         --  Index_Base'Succ (J)
1438
 
1439
         W_Increment : Node_Id;
1440
         --  W_J := Index_Base'Succ (W)
1441
 
1442
         W_Body : constant List_Id := New_List;
1443
         --  The statements to execute in the loop
1444
 
1445
         S : constant List_Id := New_List;
1446
         --  list of statement
1447
 
1448
      begin
1449
         --  If loop bounds define an empty range or are equal return null
1450
 
1451
         if Empty_Range (L, H) or else Equal (L, H) then
1452
            Append_To (S, Make_Null_Statement (Loc));
1453
            return S;
1454
         end if;
1455
 
1456
         --  Build the decl of W_J
1457
 
1458
         W_J    := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
1459
         W_Decl :=
1460
           Make_Object_Declaration
1461
             (Loc,
1462
              Defining_Identifier => W_J,
1463
              Object_Definition   => Index_Base_Name,
1464
              Expression          => L);
1465
 
1466
         --  Theoretically we should do a New_Copy_Tree (L) here, but we know
1467
         --  that in this particular case L is a fresh Expr generated by
1468
         --  Add which we are the only ones to use.
1469
 
1470
         Append_To (S, W_Decl);
1471
 
1472
         --  Construct " while W_J < H"
1473
 
1474
         W_Iteration_Scheme :=
1475
           Make_Iteration_Scheme
1476
             (Loc,
1477
              Condition => Make_Op_Lt
1478
                             (Loc,
1479
                              Left_Opnd  => New_Reference_To (W_J, Loc),
1480
                              Right_Opnd => New_Copy_Tree (H)));
1481
 
1482
         --  Construct the statements to execute in the loop body
1483
 
1484
         W_Index_Succ :=
1485
           Make_Attribute_Reference
1486
             (Loc,
1487
              Prefix         => Index_Base_Name,
1488
              Attribute_Name => Name_Succ,
1489
              Expressions    => New_List (New_Reference_To (W_J, Loc)));
1490
 
1491
         W_Increment  :=
1492
           Make_OK_Assignment_Statement
1493
             (Loc,
1494
              Name       => New_Reference_To (W_J, Loc),
1495
              Expression => W_Index_Succ);
1496
 
1497
         Append_To (W_Body, W_Increment);
1498
         Append_List_To (W_Body,
1499
           Gen_Assign (New_Reference_To (W_J, Loc), Expr));
1500
 
1501
         --  Construct the final loop
1502
 
1503
         Append_To (S, Make_Implicit_Loop_Statement
1504
                         (Node             => N,
1505
                          Identifier       => Empty,
1506
                          Iteration_Scheme => W_Iteration_Scheme,
1507
                          Statements       => W_Body));
1508
 
1509
         return S;
1510
      end Gen_While;
1511
 
1512
      ---------------------
1513
      -- Index_Base_Name --
1514
      ---------------------
1515
 
1516
      function Index_Base_Name return Node_Id is
1517
      begin
1518
         return New_Reference_To (Index_Base, Sloc (N));
1519
      end Index_Base_Name;
1520
 
1521
      ------------------------------------
1522
      -- Local_Compile_Time_Known_Value --
1523
      ------------------------------------
1524
 
1525
      function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is
1526
      begin
1527
         return Compile_Time_Known_Value (E)
1528
           or else
1529
             (Nkind (E) = N_Attribute_Reference
1530
               and then Attribute_Name (E) = Name_Val
1531
               and then Compile_Time_Known_Value (First (Expressions (E))));
1532
      end Local_Compile_Time_Known_Value;
1533
 
1534
      ----------------------
1535
      -- Local_Expr_Value --
1536
      ----------------------
1537
 
1538
      function Local_Expr_Value (E : Node_Id) return Uint is
1539
      begin
1540
         if Compile_Time_Known_Value (E) then
1541
            return Expr_Value (E);
1542
         else
1543
            return Expr_Value (First (Expressions (E)));
1544
         end if;
1545
      end Local_Expr_Value;
1546
 
1547
      --  Build_Array_Aggr_Code Variables
1548
 
1549
      Assoc  : Node_Id;
1550
      Choice : Node_Id;
1551
      Expr   : Node_Id;
1552
      Typ    : Entity_Id;
1553
 
1554
      Others_Expr        : Node_Id := Empty;
1555
      Others_Box_Present : Boolean := False;
1556
 
1557
      Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
1558
      Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
1559
      --  The aggregate bounds of this specific sub-aggregate. Note that if
1560
      --  the code generated by Build_Array_Aggr_Code is executed then these
1561
      --  bounds are OK. Otherwise a Constraint_Error would have been raised.
1562
 
1563
      Aggr_Low  : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L);
1564
      Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
1565
      --  After Duplicate_Subexpr these are side-effect free
1566
 
1567
      Low        : Node_Id;
1568
      High       : Node_Id;
1569
 
1570
      Nb_Choices : Nat := 0;
1571
      Table      : Case_Table_Type (1 .. Number_Of_Choices (N));
1572
      --  Used to sort all the different choice values
1573
 
1574
      Nb_Elements : Int;
1575
      --  Number of elements in the positional aggregate
1576
 
1577
      New_Code : constant List_Id := New_List;
1578
 
1579
   --  Start of processing for Build_Array_Aggr_Code
1580
 
1581
   begin
1582
      --  First before we start, a special case. if we have a bit packed
1583
      --  array represented as a modular type, then clear the value to
1584
      --  zero first, to ensure that unused bits are properly cleared.
1585
 
1586
      Typ := Etype (N);
1587
 
1588
      if Present (Typ)
1589
        and then Is_Bit_Packed_Array (Typ)
1590
        and then Is_Modular_Integer_Type (Packed_Array_Type (Typ))
1591
      then
1592
         Append_To (New_Code,
1593
           Make_Assignment_Statement (Loc,
1594
             Name => New_Copy_Tree (Into),
1595
             Expression =>
1596
               Unchecked_Convert_To (Typ,
1597
                 Make_Integer_Literal (Loc, Uint_0))));
1598
      end if;
1599
 
1600
      --  If the component type contains tasks, we need to build a Master
1601
      --  entity in the current scope, because it will be needed if build-
1602
      --  in-place functions are called in the expanded code.
1603
 
1604
      if Nkind (Parent (N)) = N_Object_Declaration
1605
        and then Has_Task (Typ)
1606
      then
1607
         Build_Master_Entity (Defining_Identifier (Parent (N)));
1608
      end if;
1609
 
1610
      --  STEP 1: Process component associations
1611
 
1612
      --  For those associations that may generate a loop, initialize
1613
      --  Loop_Actions to collect inserted actions that may be crated.
1614
 
1615
      --  Skip this if no component associations
1616
 
1617
      if No (Expressions (N)) then
1618
 
1619
         --  STEP 1 (a): Sort the discrete choices
1620
 
1621
         Assoc := First (Component_Associations (N));
1622
         while Present (Assoc) loop
1623
            Choice := First (Choices (Assoc));
1624
            while Present (Choice) loop
1625
               if Nkind (Choice) = N_Others_Choice then
1626
                  Set_Loop_Actions (Assoc, New_List);
1627
 
1628
                  if Box_Present (Assoc) then
1629
                     Others_Box_Present := True;
1630
                  else
1631
                     Others_Expr := Expression (Assoc);
1632
                  end if;
1633
                  exit;
1634
               end if;
1635
 
1636
               Get_Index_Bounds (Choice, Low, High);
1637
 
1638
               if Low /= High then
1639
                  Set_Loop_Actions (Assoc, New_List);
1640
               end if;
1641
 
1642
               Nb_Choices := Nb_Choices + 1;
1643
               if Box_Present (Assoc) then
1644
                  Table (Nb_Choices) := (Choice_Lo   => Low,
1645
                                         Choice_Hi   => High,
1646
                                         Choice_Node => Empty);
1647
               else
1648
                  Table (Nb_Choices) := (Choice_Lo   => Low,
1649
                                         Choice_Hi   => High,
1650
                                         Choice_Node => Expression (Assoc));
1651
               end if;
1652
               Next (Choice);
1653
            end loop;
1654
 
1655
            Next (Assoc);
1656
         end loop;
1657
 
1658
         --  If there is more than one set of choices these must be static
1659
         --  and we can therefore sort them. Remember that Nb_Choices does not
1660
         --  account for an others choice.
1661
 
1662
         if Nb_Choices > 1 then
1663
            Sort_Case_Table (Table);
1664
         end if;
1665
 
1666
         --  STEP 1 (b):  take care of the whole set of discrete choices
1667
 
1668
         for J in 1 .. Nb_Choices loop
1669
            Low  := Table (J).Choice_Lo;
1670
            High := Table (J).Choice_Hi;
1671
            Expr := Table (J).Choice_Node;
1672
            Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
1673
         end loop;
1674
 
1675
         --  STEP 1 (c): generate the remaining loops to cover others choice
1676
         --  We don't need to generate loops over empty gaps, but if there is
1677
         --  a single empty range we must analyze the expression for semantics
1678
 
1679
         if Present (Others_Expr) or else Others_Box_Present then
1680
            declare
1681
               First : Boolean := True;
1682
 
1683
            begin
1684
               for J in 0 .. Nb_Choices loop
1685
                  if J = 0 then
1686
                     Low := Aggr_Low;
1687
                  else
1688
                     Low := Add (1, To => Table (J).Choice_Hi);
1689
                  end if;
1690
 
1691
                  if J = Nb_Choices then
1692
                     High := Aggr_High;
1693
                  else
1694
                     High := Add (-1, To => Table (J + 1).Choice_Lo);
1695
                  end if;
1696
 
1697
                  --  If this is an expansion within an init proc, make
1698
                  --  sure that discriminant references are replaced by
1699
                  --  the corresponding discriminal.
1700
 
1701
                  if Inside_Init_Proc then
1702
                     if Is_Entity_Name (Low)
1703
                       and then Ekind (Entity (Low)) = E_Discriminant
1704
                     then
1705
                        Set_Entity (Low, Discriminal (Entity (Low)));
1706
                     end if;
1707
 
1708
                     if Is_Entity_Name (High)
1709
                       and then Ekind (Entity (High)) = E_Discriminant
1710
                     then
1711
                        Set_Entity (High, Discriminal (Entity (High)));
1712
                     end if;
1713
                  end if;
1714
 
1715
                  if First
1716
                    or else not Empty_Range (Low, High)
1717
                  then
1718
                     First := False;
1719
                     Append_List
1720
                       (Gen_Loop (Low, High, Others_Expr), To => New_Code);
1721
                  end if;
1722
               end loop;
1723
            end;
1724
         end if;
1725
 
1726
      --  STEP 2: Process positional components
1727
 
1728
      else
1729
         --  STEP 2 (a): Generate the assignments for each positional element
1730
         --  Note that here we have to use Aggr_L rather than Aggr_Low because
1731
         --  Aggr_L is analyzed and Add wants an analyzed expression.
1732
 
1733
         Expr        := First (Expressions (N));
1734
         Nb_Elements := -1;
1735
         while Present (Expr) loop
1736
            Nb_Elements := Nb_Elements + 1;
1737
            Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr),
1738
                         To => New_Code);
1739
            Next (Expr);
1740
         end loop;
1741
 
1742
         --  STEP 2 (b): Generate final loop if an others choice is present
1743
         --  Here Nb_Elements gives the offset of the last positional element.
1744
 
1745
         if Present (Component_Associations (N)) then
1746
            Assoc := Last (Component_Associations (N));
1747
 
1748
            --  Ada 2005 (AI-287)
1749
 
1750
            if Box_Present (Assoc) then
1751
               Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1752
                                       Aggr_High,
1753
                                       Empty),
1754
                            To => New_Code);
1755
            else
1756
               Expr  := Expression (Assoc);
1757
 
1758
               Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1759
                                       Aggr_High,
1760
                                       Expr), --  AI-287
1761
                            To => New_Code);
1762
            end if;
1763
         end if;
1764
      end if;
1765
 
1766
      return New_Code;
1767
   end Build_Array_Aggr_Code;
1768
 
1769
   ----------------------------
1770
   -- Build_Record_Aggr_Code --
1771
   ----------------------------
1772
 
1773
   function Build_Record_Aggr_Code
1774
     (N                             : Node_Id;
1775
      Typ                           : Entity_Id;
1776
      Lhs                           : Node_Id;
1777
      Flist                         : Node_Id   := Empty;
1778
      Obj                           : Entity_Id := Empty;
1779
      Is_Limited_Ancestor_Expansion : Boolean   := False) return List_Id
1780
   is
1781
      Loc     : constant Source_Ptr := Sloc (N);
1782
      L       : constant List_Id    := New_List;
1783
      N_Typ   : constant Entity_Id  := Etype (N);
1784
 
1785
      Comp      : Node_Id;
1786
      Instr     : Node_Id;
1787
      Ref       : Node_Id;
1788
      Target    : Entity_Id;
1789
      F         : Node_Id;
1790
      Comp_Type : Entity_Id;
1791
      Selector  : Entity_Id;
1792
      Comp_Expr : Node_Id;
1793
      Expr_Q    : Node_Id;
1794
 
1795
      Internal_Final_List : Node_Id := Empty;
1796
 
1797
      --  If this is an internal aggregate, the External_Final_List is an
1798
      --  expression for the controller record of the enclosing type.
1799
 
1800
      --  If the current aggregate has several controlled components, this
1801
      --  expression will appear in several calls to attach to the finali-
1802
      --  zation list, and it must not be shared.
1803
 
1804
      External_Final_List      : Node_Id;
1805
      Ancestor_Is_Expression   : Boolean := False;
1806
      Ancestor_Is_Subtype_Mark : Boolean := False;
1807
 
1808
      Init_Typ : Entity_Id := Empty;
1809
      Attach   : Node_Id;
1810
 
1811
      Ctrl_Stuff_Done : Boolean := False;
1812
      --  True if Gen_Ctrl_Actions_For_Aggr has already been called; calls
1813
      --  after the first do nothing.
1814
 
1815
      function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
1816
      --  Returns the value that the given discriminant of an ancestor type
1817
      --  should receive (in the absence of a conflict with the value provided
1818
      --  by an ancestor part of an extension aggregate).
1819
 
1820
      procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id);
1821
      --  Check that each of the discriminant values defined by the ancestor
1822
      --  part of an extension aggregate match the corresponding values
1823
      --  provided by either an association of the aggregate or by the
1824
      --  constraint imposed by a parent type (RM95-4.3.2(8)).
1825
 
1826
      function Compatible_Int_Bounds
1827
        (Agg_Bounds : Node_Id;
1828
         Typ_Bounds : Node_Id) return Boolean;
1829
      --  Return true if Agg_Bounds are equal or within Typ_Bounds. It is
1830
      --  assumed that both bounds are integer ranges.
1831
 
1832
      procedure Gen_Ctrl_Actions_For_Aggr;
1833
      --  Deal with the various controlled type data structure initializations
1834
      --  (but only if it hasn't been done already).
1835
 
1836
      function Get_Constraint_Association (T : Entity_Id) return Node_Id;
1837
      --  Returns the first discriminant association in the constraint
1838
      --  associated with T, if any, otherwise returns Empty.
1839
 
1840
      function Init_Controller
1841
        (Target  : Node_Id;
1842
         Typ     : Entity_Id;
1843
         F       : Node_Id;
1844
         Attach  : Node_Id;
1845
         Init_Pr : Boolean) return List_Id;
1846
      --  Returns the list of statements necessary to initialize the internal
1847
      --  controller of the (possible) ancestor typ into target and attach it
1848
      --  to finalization list F. Init_Pr conditions the call to the init proc
1849
      --  since it may already be done due to ancestor initialization.
1850
 
1851
      function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
1852
      --  Check whether Bounds is a range node and its lower and higher bounds
1853
      --  are integers literals.
1854
 
1855
      ---------------------------------
1856
      -- Ancestor_Discriminant_Value --
1857
      ---------------------------------
1858
 
1859
      function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is
1860
         Assoc        : Node_Id;
1861
         Assoc_Elmt   : Elmt_Id;
1862
         Aggr_Comp    : Entity_Id;
1863
         Corresp_Disc : Entity_Id;
1864
         Current_Typ  : Entity_Id := Base_Type (Typ);
1865
         Parent_Typ   : Entity_Id;
1866
         Parent_Disc  : Entity_Id;
1867
         Save_Assoc   : Node_Id := Empty;
1868
 
1869
      begin
1870
         --  First check any discriminant associations to see if any of them
1871
         --  provide a value for the discriminant.
1872
 
1873
         if Present (Discriminant_Specifications (Parent (Current_Typ))) then
1874
            Assoc := First (Component_Associations (N));
1875
            while Present (Assoc) loop
1876
               Aggr_Comp := Entity (First (Choices (Assoc)));
1877
 
1878
               if Ekind (Aggr_Comp) = E_Discriminant then
1879
                  Save_Assoc := Expression (Assoc);
1880
 
1881
                  Corresp_Disc := Corresponding_Discriminant (Aggr_Comp);
1882
                  while Present (Corresp_Disc) loop
1883
 
1884
                     --  If found a corresponding discriminant then return the
1885
                     --  value given in the aggregate. (Note: this is not
1886
                     --  correct in the presence of side effects. ???)
1887
 
1888
                     if Disc = Corresp_Disc then
1889
                        return Duplicate_Subexpr (Expression (Assoc));
1890
                     end if;
1891
 
1892
                     Corresp_Disc :=
1893
                       Corresponding_Discriminant (Corresp_Disc);
1894
                  end loop;
1895
               end if;
1896
 
1897
               Next (Assoc);
1898
            end loop;
1899
         end if;
1900
 
1901
         --  No match found in aggregate, so chain up parent types to find
1902
         --  a constraint that defines the value of the discriminant.
1903
 
1904
         Parent_Typ := Etype (Current_Typ);
1905
         while Current_Typ /= Parent_Typ loop
1906
            if Has_Discriminants (Parent_Typ)
1907
              and then not Has_Unknown_Discriminants (Parent_Typ)
1908
            then
1909
               Parent_Disc := First_Discriminant (Parent_Typ);
1910
 
1911
               --  We either get the association from the subtype indication
1912
               --  of the type definition itself, or from the discriminant
1913
               --  constraint associated with the type entity (which is
1914
               --  preferable, but it's not always present ???)
1915
 
1916
               if Is_Empty_Elmt_List (
1917
                 Discriminant_Constraint (Current_Typ))
1918
               then
1919
                  Assoc := Get_Constraint_Association (Current_Typ);
1920
                  Assoc_Elmt := No_Elmt;
1921
               else
1922
                  Assoc_Elmt :=
1923
                    First_Elmt (Discriminant_Constraint (Current_Typ));
1924
                  Assoc := Node (Assoc_Elmt);
1925
               end if;
1926
 
1927
               --  Traverse the discriminants of the parent type looking
1928
               --  for one that corresponds.
1929
 
1930
               while Present (Parent_Disc) and then Present (Assoc) loop
1931
                  Corresp_Disc := Parent_Disc;
1932
                  while Present (Corresp_Disc)
1933
                    and then Disc /= Corresp_Disc
1934
                  loop
1935
                     Corresp_Disc :=
1936
                       Corresponding_Discriminant (Corresp_Disc);
1937
                  end loop;
1938
 
1939
                  if Disc = Corresp_Disc then
1940
                     if Nkind (Assoc) = N_Discriminant_Association then
1941
                        Assoc := Expression (Assoc);
1942
                     end if;
1943
 
1944
                     --  If the located association directly denotes a
1945
                     --  discriminant, then use the value of a saved
1946
                     --  association of the aggregate. This is a kludge to
1947
                     --  handle certain cases involving multiple discriminants
1948
                     --  mapped to a single discriminant of a descendant. It's
1949
                     --  not clear how to locate the appropriate discriminant
1950
                     --  value for such cases. ???
1951
 
1952
                     if Is_Entity_Name (Assoc)
1953
                       and then Ekind (Entity (Assoc)) = E_Discriminant
1954
                     then
1955
                        Assoc := Save_Assoc;
1956
                     end if;
1957
 
1958
                     return Duplicate_Subexpr (Assoc);
1959
                  end if;
1960
 
1961
                  Next_Discriminant (Parent_Disc);
1962
 
1963
                  if No (Assoc_Elmt) then
1964
                     Next (Assoc);
1965
                  else
1966
                     Next_Elmt (Assoc_Elmt);
1967
                     if Present (Assoc_Elmt) then
1968
                        Assoc := Node (Assoc_Elmt);
1969
                     else
1970
                        Assoc := Empty;
1971
                     end if;
1972
                  end if;
1973
               end loop;
1974
            end if;
1975
 
1976
            Current_Typ := Parent_Typ;
1977
            Parent_Typ := Etype (Current_Typ);
1978
         end loop;
1979
 
1980
         --  In some cases there's no ancestor value to locate (such as
1981
         --  when an ancestor part given by an expression defines the
1982
         --  discriminant value).
1983
 
1984
         return Empty;
1985
      end Ancestor_Discriminant_Value;
1986
 
1987
      ----------------------------------
1988
      -- Check_Ancestor_Discriminants --
1989
      ----------------------------------
1990
 
1991
      procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is
1992
         Discr      : Entity_Id;
1993
         Disc_Value : Node_Id;
1994
         Cond       : Node_Id;
1995
 
1996
      begin
1997
         Discr := First_Discriminant (Base_Type (Anc_Typ));
1998
         while Present (Discr) loop
1999
            Disc_Value := Ancestor_Discriminant_Value (Discr);
2000
 
2001
            if Present (Disc_Value) then
2002
               Cond := Make_Op_Ne (Loc,
2003
                 Left_Opnd =>
2004
                   Make_Selected_Component (Loc,
2005
                     Prefix        => New_Copy_Tree (Target),
2006
                     Selector_Name => New_Occurrence_Of (Discr, Loc)),
2007
                 Right_Opnd => Disc_Value);
2008
 
2009
               Append_To (L,
2010
                 Make_Raise_Constraint_Error (Loc,
2011
                   Condition => Cond,
2012
                   Reason    => CE_Discriminant_Check_Failed));
2013
            end if;
2014
 
2015
            Next_Discriminant (Discr);
2016
         end loop;
2017
      end Check_Ancestor_Discriminants;
2018
 
2019
      ---------------------------
2020
      -- Compatible_Int_Bounds --
2021
      ---------------------------
2022
 
2023
      function Compatible_Int_Bounds
2024
        (Agg_Bounds : Node_Id;
2025
         Typ_Bounds : Node_Id) return Boolean
2026
      is
2027
         Agg_Lo : constant Uint := Intval (Low_Bound  (Agg_Bounds));
2028
         Agg_Hi : constant Uint := Intval (High_Bound (Agg_Bounds));
2029
         Typ_Lo : constant Uint := Intval (Low_Bound  (Typ_Bounds));
2030
         Typ_Hi : constant Uint := Intval (High_Bound (Typ_Bounds));
2031
      begin
2032
         return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi;
2033
      end Compatible_Int_Bounds;
2034
 
2035
      --------------------------------
2036
      -- Get_Constraint_Association --
2037
      --------------------------------
2038
 
2039
      function Get_Constraint_Association (T : Entity_Id) return Node_Id is
2040
         Typ_Def : constant Node_Id := Type_Definition (Parent (T));
2041
         Indic   : constant Node_Id := Subtype_Indication (Typ_Def);
2042
 
2043
      begin
2044
         --  ??? Also need to cover case of a type mark denoting a subtype
2045
         --  with constraint.
2046
 
2047
         if Nkind (Indic) = N_Subtype_Indication
2048
           and then Present (Constraint (Indic))
2049
         then
2050
            return First (Constraints (Constraint (Indic)));
2051
         end if;
2052
 
2053
         return Empty;
2054
      end Get_Constraint_Association;
2055
 
2056
      ---------------------
2057
      -- Init_Controller --
2058
      ---------------------
2059
 
2060
      function Init_Controller
2061
        (Target  : Node_Id;
2062
         Typ     : Entity_Id;
2063
         F       : Node_Id;
2064
         Attach  : Node_Id;
2065
         Init_Pr : Boolean) return List_Id
2066
      is
2067
         L           : constant List_Id := New_List;
2068
         Ref         : Node_Id;
2069
         RC          : RE_Id;
2070
         Target_Type : Entity_Id;
2071
 
2072
      begin
2073
         --  Generate:
2074
         --     init-proc (target._controller);
2075
         --     initialize (target._controller);
2076
         --     Attach_to_Final_List (target._controller, F);
2077
 
2078
         Ref :=
2079
           Make_Selected_Component (Loc,
2080
             Prefix        => Convert_To (Typ, New_Copy_Tree (Target)),
2081
             Selector_Name => Make_Identifier (Loc, Name_uController));
2082
         Set_Assignment_OK (Ref);
2083
 
2084
         --  Ada 2005 (AI-287): Give support to aggregates of limited types.
2085
         --  If the type is intrinsically limited the controller is limited as
2086
         --  well. If it is tagged and limited then so is the controller.
2087
         --  Otherwise an untagged type may have limited components without its
2088
         --  full view being limited, so the controller is not limited.
2089
 
2090
         if Nkind (Target) = N_Identifier then
2091
            Target_Type := Etype (Target);
2092
 
2093
         elsif Nkind (Target) = N_Selected_Component then
2094
            Target_Type := Etype (Selector_Name (Target));
2095
 
2096
         elsif Nkind (Target) = N_Unchecked_Type_Conversion then
2097
            Target_Type := Etype (Target);
2098
 
2099
         elsif Nkind (Target) = N_Unchecked_Expression
2100
           and then Nkind (Expression (Target)) = N_Indexed_Component
2101
         then
2102
            Target_Type := Etype (Prefix (Expression (Target)));
2103
 
2104
         else
2105
            Target_Type := Etype (Target);
2106
         end if;
2107
 
2108
         --  If the target has not been analyzed yet, as will happen with
2109
         --  delayed expansion, use the given type (either the aggregate type
2110
         --  or an ancestor) to determine limitedness.
2111
 
2112
         if No (Target_Type) then
2113
            Target_Type := Typ;
2114
         end if;
2115
 
2116
         if (Is_Tagged_Type (Target_Type))
2117
           and then Is_Limited_Type (Target_Type)
2118
         then
2119
            RC := RE_Limited_Record_Controller;
2120
 
2121
         elsif Is_Inherently_Limited_Type (Target_Type) then
2122
            RC := RE_Limited_Record_Controller;
2123
 
2124
         else
2125
            RC := RE_Record_Controller;
2126
         end if;
2127
 
2128
         if Init_Pr then
2129
            Append_List_To (L,
2130
              Build_Initialization_Call (Loc,
2131
                Id_Ref       => Ref,
2132
                Typ          => RTE (RC),
2133
                In_Init_Proc => Within_Init_Proc));
2134
         end if;
2135
 
2136
         Append_To (L,
2137
           Make_Procedure_Call_Statement (Loc,
2138
             Name =>
2139
               New_Reference_To (
2140
                 Find_Prim_Op (RTE (RC), Name_Initialize), Loc),
2141
             Parameter_Associations =>
2142
               New_List (New_Copy_Tree (Ref))));
2143
 
2144
         Append_To (L,
2145
           Make_Attach_Call (
2146
             Obj_Ref     => New_Copy_Tree (Ref),
2147
             Flist_Ref   => F,
2148
             With_Attach => Attach));
2149
 
2150
         return L;
2151
      end Init_Controller;
2152
 
2153
      -------------------------
2154
      -- Is_Int_Range_Bounds --
2155
      -------------------------
2156
 
2157
      function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
2158
      begin
2159
         return Nkind (Bounds) = N_Range
2160
           and then Nkind (Low_Bound  (Bounds)) = N_Integer_Literal
2161
           and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
2162
      end Is_Int_Range_Bounds;
2163
 
2164
      -------------------------------
2165
      -- Gen_Ctrl_Actions_For_Aggr --
2166
      -------------------------------
2167
 
2168
      procedure Gen_Ctrl_Actions_For_Aggr is
2169
         Alloc : Node_Id := Empty;
2170
 
2171
      begin
2172
         --  Do the work only the first time this is called
2173
 
2174
         if Ctrl_Stuff_Done then
2175
            return;
2176
         end if;
2177
 
2178
         Ctrl_Stuff_Done := True;
2179
 
2180
         if Present (Obj)
2181
           and then Finalize_Storage_Only (Typ)
2182
           and then
2183
             (Is_Library_Level_Entity (Obj)
2184
                or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
2185
                                                          Standard_True)
2186
 
2187
            --  why not Is_True (Expr_Value (RTE (RE_Garbaage_Collected) ???
2188
         then
2189
            Attach := Make_Integer_Literal (Loc, 0);
2190
 
2191
         elsif Nkind (Parent (N)) = N_Qualified_Expression
2192
           and then Nkind (Parent (Parent (N))) = N_Allocator
2193
         then
2194
            Alloc  := Parent (Parent (N));
2195
            Attach := Make_Integer_Literal (Loc, 2);
2196
 
2197
         else
2198
            Attach := Make_Integer_Literal (Loc, 1);
2199
         end if;
2200
 
2201
         --  Determine the external finalization list. It is either the
2202
         --  finalization list of the outer-scope or the one coming from
2203
         --  an outer aggregate.  When the target is not a temporary, the
2204
         --  proper scope is the scope of the target rather than the
2205
         --  potentially transient current scope.
2206
 
2207
         if Needs_Finalization (Typ) then
2208
 
2209
            --  The current aggregate belongs to an allocator which creates
2210
            --  an object through an anonymous access type or acts as the root
2211
            --  of a coextension chain.
2212
 
2213
            if Present (Alloc)
2214
              and then
2215
                (Is_Coextension_Root (Alloc)
2216
                   or else Ekind (Etype (Alloc)) = E_Anonymous_Access_Type)
2217
            then
2218
               if No (Associated_Final_Chain (Etype (Alloc))) then
2219
                  Build_Final_List (Alloc, Etype (Alloc));
2220
               end if;
2221
 
2222
               External_Final_List :=
2223
                 Make_Selected_Component (Loc,
2224
                   Prefix =>
2225
                     New_Reference_To (
2226
                       Associated_Final_Chain (Etype (Alloc)), Loc),
2227
                   Selector_Name =>
2228
                     Make_Identifier (Loc, Name_F));
2229
 
2230
            elsif Present (Flist) then
2231
               External_Final_List := New_Copy_Tree (Flist);
2232
 
2233
            elsif Is_Entity_Name (Target)
2234
              and then Present (Scope (Entity (Target)))
2235
            then
2236
               External_Final_List :=
2237
                 Find_Final_List (Scope (Entity (Target)));
2238
 
2239
            else
2240
               External_Final_List := Find_Final_List (Current_Scope);
2241
            end if;
2242
         else
2243
            External_Final_List := Empty;
2244
         end if;
2245
 
2246
         --  Initialize and attach the outer object in the is_controlled case
2247
 
2248
         if Is_Controlled (Typ) then
2249
            if Ancestor_Is_Subtype_Mark then
2250
               Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2251
               Set_Assignment_OK (Ref);
2252
               Append_To (L,
2253
                 Make_Procedure_Call_Statement (Loc,
2254
                   Name =>
2255
                     New_Reference_To
2256
                       (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
2257
                   Parameter_Associations => New_List (New_Copy_Tree (Ref))));
2258
            end if;
2259
 
2260
            if not Has_Controlled_Component (Typ) then
2261
               Ref := New_Copy_Tree (Target);
2262
               Set_Assignment_OK (Ref);
2263
 
2264
               --  This is an aggregate of a coextension. Do not produce a
2265
               --  finalization call, but rather attach the reference of the
2266
               --  aggregate to its coextension chain.
2267
 
2268
               if Present (Alloc)
2269
                 and then Is_Dynamic_Coextension (Alloc)
2270
               then
2271
                  if No (Coextensions (Alloc)) then
2272
                     Set_Coextensions (Alloc, New_Elmt_List);
2273
                  end if;
2274
 
2275
                  Append_Elmt (Ref, Coextensions (Alloc));
2276
               else
2277
                  Append_To (L,
2278
                    Make_Attach_Call (
2279
                      Obj_Ref     => Ref,
2280
                      Flist_Ref   => New_Copy_Tree (External_Final_List),
2281
                      With_Attach => Attach));
2282
               end if;
2283
            end if;
2284
         end if;
2285
 
2286
         --  In the Has_Controlled component case, all the intermediate
2287
         --  controllers must be initialized.
2288
 
2289
         if Has_Controlled_Component (Typ)
2290
           and not Is_Limited_Ancestor_Expansion
2291
         then
2292
            declare
2293
               Inner_Typ : Entity_Id;
2294
               Outer_Typ : Entity_Id;
2295
               At_Root   : Boolean;
2296
 
2297
            begin
2298
               --  Find outer type with a controller
2299
 
2300
               Outer_Typ := Base_Type (Typ);
2301
               while Outer_Typ /= Init_Typ
2302
                 and then not Has_New_Controlled_Component (Outer_Typ)
2303
               loop
2304
                  Outer_Typ := Etype (Outer_Typ);
2305
               end loop;
2306
 
2307
               --  Attach it to the outer record controller to the external
2308
               --  final list.
2309
 
2310
               if Outer_Typ = Init_Typ then
2311
                  Append_List_To (L,
2312
                    Init_Controller (
2313
                      Target  => Target,
2314
                      Typ     => Outer_Typ,
2315
                      F       => External_Final_List,
2316
                      Attach  => Attach,
2317
                      Init_Pr => False));
2318
 
2319
                  At_Root   := True;
2320
                  Inner_Typ := Init_Typ;
2321
 
2322
               else
2323
                  Append_List_To (L,
2324
                    Init_Controller (
2325
                      Target  => Target,
2326
                      Typ     => Outer_Typ,
2327
                      F       => External_Final_List,
2328
                      Attach  => Attach,
2329
                      Init_Pr => True));
2330
 
2331
                  Inner_Typ := Etype (Outer_Typ);
2332
                  At_Root   :=
2333
                    not Is_Tagged_Type (Typ) or else Inner_Typ = Outer_Typ;
2334
               end if;
2335
 
2336
               --  The outer object has to be attached as well
2337
 
2338
               if Is_Controlled (Typ) then
2339
                  Ref := New_Copy_Tree (Target);
2340
                  Set_Assignment_OK (Ref);
2341
                  Append_To (L,
2342
                    Make_Attach_Call (
2343
                      Obj_Ref     => Ref,
2344
                      Flist_Ref   => New_Copy_Tree (External_Final_List),
2345
                      With_Attach => New_Copy_Tree (Attach)));
2346
               end if;
2347
 
2348
               --  Initialize the internal controllers for tagged types with
2349
               --  more than one controller.
2350
 
2351
               while not At_Root and then Inner_Typ /= Init_Typ loop
2352
                  if Has_New_Controlled_Component (Inner_Typ) then
2353
                     F :=
2354
                       Make_Selected_Component (Loc,
2355
                         Prefix =>
2356
                           Convert_To (Outer_Typ, New_Copy_Tree (Target)),
2357
                         Selector_Name =>
2358
                           Make_Identifier (Loc, Name_uController));
2359
                     F :=
2360
                       Make_Selected_Component (Loc,
2361
                         Prefix => F,
2362
                         Selector_Name => Make_Identifier (Loc, Name_F));
2363
 
2364
                     Append_List_To (L,
2365
                       Init_Controller (
2366
                         Target  => Target,
2367
                         Typ     => Inner_Typ,
2368
                         F       => F,
2369
                         Attach  => Make_Integer_Literal (Loc, 1),
2370
                         Init_Pr => True));
2371
                     Outer_Typ := Inner_Typ;
2372
                  end if;
2373
 
2374
                  --  Stop at the root
2375
 
2376
                  At_Root := Inner_Typ = Etype (Inner_Typ);
2377
                  Inner_Typ := Etype (Inner_Typ);
2378
               end loop;
2379
 
2380
               --  If not done yet attach the controller of the ancestor part
2381
 
2382
               if Outer_Typ /= Init_Typ
2383
                 and then Inner_Typ = Init_Typ
2384
                 and then Has_Controlled_Component (Init_Typ)
2385
               then
2386
                  F :=
2387
                    Make_Selected_Component (Loc,
2388
                      Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
2389
                      Selector_Name =>
2390
                        Make_Identifier (Loc, Name_uController));
2391
                  F :=
2392
                    Make_Selected_Component (Loc,
2393
                      Prefix => F,
2394
                      Selector_Name => Make_Identifier (Loc, Name_F));
2395
 
2396
                  Attach := Make_Integer_Literal (Loc, 1);
2397
                  Append_List_To (L,
2398
                    Init_Controller (
2399
                      Target  => Target,
2400
                      Typ     => Init_Typ,
2401
                      F       => F,
2402
                      Attach  => Attach,
2403
                      Init_Pr => False));
2404
 
2405
                     --  Note: Init_Pr is False because the ancestor part has
2406
                     --  already been initialized either way (by default, if
2407
                     --  given by a type name, otherwise from the expression).
2408
 
2409
               end if;
2410
            end;
2411
         end if;
2412
      end Gen_Ctrl_Actions_For_Aggr;
2413
 
2414
      function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result;
2415
      --  If default expression of a component mentions a discriminant of the
2416
      --  type, it must be rewritten as the discriminant of the target object.
2417
 
2418
      function Replace_Type (Expr : Node_Id) return Traverse_Result;
2419
      --  If the aggregate contains a self-reference, traverse each expression
2420
      --  to replace a possible self-reference with a reference to the proper
2421
      --  component of the target of the assignment.
2422
 
2423
      --------------------------
2424
      -- Rewrite_Discriminant --
2425
      --------------------------
2426
 
2427
      function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
2428
      begin
2429
         if Nkind (Expr) = N_Identifier
2430
           and then Present (Entity (Expr))
2431
           and then Ekind (Entity (Expr)) = E_In_Parameter
2432
           and then Present (Discriminal_Link (Entity (Expr)))
2433
         then
2434
            Rewrite (Expr,
2435
              Make_Selected_Component (Loc,
2436
                Prefix        => New_Occurrence_Of (Obj, Loc),
2437
                Selector_Name => Make_Identifier (Loc, Chars (Expr))));
2438
         end if;
2439
         return OK;
2440
      end Rewrite_Discriminant;
2441
 
2442
      ------------------
2443
      -- Replace_Type --
2444
      ------------------
2445
 
2446
      function Replace_Type (Expr : Node_Id) return Traverse_Result is
2447
      begin
2448
         --  Note regarding the Root_Type test below: Aggregate components for
2449
         --  self-referential types include attribute references to the current
2450
         --  instance, of the form: Typ'access, etc.. These references are
2451
         --  rewritten as references to the target of the aggregate: the
2452
         --  left-hand side of an assignment, the entity in a declaration,
2453
         --  or a temporary. Without this test, we would improperly extended
2454
         --  this rewriting to attribute references whose prefix was not the
2455
         --  type of the aggregate.
2456
 
2457
         if Nkind (Expr) = N_Attribute_Reference
2458
           and then Is_Entity_Name (Prefix (Expr))
2459
           and then Is_Type (Entity (Prefix (Expr)))
2460
           and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr)))
2461
         then
2462
            if Is_Entity_Name (Lhs) then
2463
               Rewrite (Prefix (Expr),
2464
                 New_Occurrence_Of (Entity (Lhs), Loc));
2465
 
2466
            elsif Nkind (Lhs) = N_Selected_Component then
2467
               Rewrite (Expr,
2468
                 Make_Attribute_Reference (Loc,
2469
                   Attribute_Name => Name_Unrestricted_Access,
2470
                   Prefix         => New_Copy_Tree (Prefix (Lhs))));
2471
               Set_Analyzed (Parent (Expr), False);
2472
 
2473
            else
2474
               Rewrite (Expr,
2475
                 Make_Attribute_Reference (Loc,
2476
                   Attribute_Name => Name_Unrestricted_Access,
2477
                   Prefix         => New_Copy_Tree (Lhs)));
2478
               Set_Analyzed (Parent (Expr), False);
2479
            end if;
2480
         end if;
2481
 
2482
         return OK;
2483
      end Replace_Type;
2484
 
2485
      procedure Replace_Self_Reference is
2486
        new Traverse_Proc (Replace_Type);
2487
 
2488
      procedure Replace_Discriminants is
2489
        new Traverse_Proc (Rewrite_Discriminant);
2490
 
2491
   --  Start of processing for Build_Record_Aggr_Code
2492
 
2493
   begin
2494
      if Has_Self_Reference (N) then
2495
         Replace_Self_Reference (N);
2496
      end if;
2497
 
2498
      --  If the target of the aggregate is class-wide, we must convert it
2499
      --  to the actual type of the aggregate, so that the proper components
2500
      --  are visible. We know already that the types are compatible.
2501
 
2502
      if Present (Etype (Lhs))
2503
        and then Is_Class_Wide_Type (Etype (Lhs))
2504
      then
2505
         Target := Unchecked_Convert_To (Typ, Lhs);
2506
      else
2507
         Target := Lhs;
2508
      end if;
2509
 
2510
      --  Deal with the ancestor part of extension aggregates or with the
2511
      --  discriminants of the root type.
2512
 
2513
      if Nkind (N) = N_Extension_Aggregate then
2514
         declare
2515
            A      : constant Node_Id := Ancestor_Part (N);
2516
            Assign : List_Id;
2517
 
2518
         begin
2519
            --  If the ancestor part is a subtype mark "T", we generate
2520
 
2521
            --     init-proc (T(tmp));  if T is constrained and
2522
            --     init-proc (S(tmp));  where S applies an appropriate
2523
            --                          constraint if T is unconstrained
2524
 
2525
            if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
2526
               Ancestor_Is_Subtype_Mark := True;
2527
 
2528
               if Is_Constrained (Entity (A)) then
2529
                  Init_Typ := Entity (A);
2530
 
2531
               --  For an ancestor part given by an unconstrained type mark,
2532
               --  create a subtype constrained by appropriate corresponding
2533
               --  discriminant values coming from either associations of the
2534
               --  aggregate or a constraint on a parent type. The subtype will
2535
               --  be used to generate the correct default value for the
2536
               --  ancestor part.
2537
 
2538
               elsif Has_Discriminants (Entity (A)) then
2539
                  declare
2540
                     Anc_Typ    : constant Entity_Id := Entity (A);
2541
                     Anc_Constr : constant List_Id   := New_List;
2542
                     Discrim    : Entity_Id;
2543
                     Disc_Value : Node_Id;
2544
                     New_Indic  : Node_Id;
2545
                     Subt_Decl  : Node_Id;
2546
 
2547
                  begin
2548
                     Discrim := First_Discriminant (Anc_Typ);
2549
                     while Present (Discrim) loop
2550
                        Disc_Value := Ancestor_Discriminant_Value (Discrim);
2551
                        Append_To (Anc_Constr, Disc_Value);
2552
                        Next_Discriminant (Discrim);
2553
                     end loop;
2554
 
2555
                     New_Indic :=
2556
                       Make_Subtype_Indication (Loc,
2557
                         Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc),
2558
                         Constraint   =>
2559
                           Make_Index_Or_Discriminant_Constraint (Loc,
2560
                             Constraints => Anc_Constr));
2561
 
2562
                     Init_Typ := Create_Itype (Ekind (Anc_Typ), N);
2563
 
2564
                     Subt_Decl :=
2565
                       Make_Subtype_Declaration (Loc,
2566
                         Defining_Identifier => Init_Typ,
2567
                         Subtype_Indication  => New_Indic);
2568
 
2569
                     --  Itypes must be analyzed with checks off Declaration
2570
                     --  must have a parent for proper handling of subsidiary
2571
                     --  actions.
2572
 
2573
                     Set_Parent (Subt_Decl, N);
2574
                     Analyze (Subt_Decl, Suppress => All_Checks);
2575
                  end;
2576
               end if;
2577
 
2578
               Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2579
               Set_Assignment_OK (Ref);
2580
 
2581
               if not Is_Interface (Init_Typ) then
2582
                  Append_List_To (L,
2583
                    Build_Initialization_Call (Loc,
2584
                      Id_Ref            => Ref,
2585
                      Typ               => Init_Typ,
2586
                      In_Init_Proc      => Within_Init_Proc,
2587
                      With_Default_Init => Has_Default_Init_Comps (N)
2588
                                             or else
2589
                                           Has_Task (Base_Type (Init_Typ))));
2590
 
2591
                  if Is_Constrained (Entity (A))
2592
                    and then Has_Discriminants (Entity (A))
2593
                  then
2594
                     Check_Ancestor_Discriminants (Entity (A));
2595
                  end if;
2596
               end if;
2597
 
2598
            --  Handle calls to C++ constructors
2599
 
2600
            elsif Is_CPP_Constructor_Call (A) then
2601
               Init_Typ := Etype (A);
2602
               Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2603
               Set_Assignment_OK (Ref);
2604
 
2605
               Append_List_To (L,
2606
                 Build_Initialization_Call (Loc,
2607
                   Id_Ref            => Ref,
2608
                   Typ               => Init_Typ,
2609
                   In_Init_Proc      => Within_Init_Proc,
2610
                   With_Default_Init => Has_Default_Init_Comps (N),
2611
                   Constructor_Ref   => A));
2612
 
2613
            --  Ada 2005 (AI-287): If the ancestor part is an aggregate of
2614
            --  limited type, a recursive call expands the ancestor. Note that
2615
            --  in the limited case, the ancestor part must be either a
2616
            --  function call (possibly qualified, or wrapped in an unchecked
2617
            --  conversion) or aggregate (definitely qualified).
2618
            --  The ancestor part can also be a function call (that may be
2619
            --  transformed into an explicit dereference) or a qualification
2620
            --  of one such.
2621
 
2622
            elsif Is_Limited_Type (Etype (A))
2623
              and then Nkind_In (Unqualify (A), N_Aggregate,
2624
                                                N_Extension_Aggregate)
2625
            then
2626
               Ancestor_Is_Expression := True;
2627
 
2628
               --  Set up  finalization data for enclosing record, because
2629
               --  controlled subcomponents of the ancestor part will be
2630
               --  attached to it.
2631
 
2632
               Gen_Ctrl_Actions_For_Aggr;
2633
 
2634
               Append_List_To (L,
2635
                  Build_Record_Aggr_Code (
2636
                    N                             => Unqualify (A),
2637
                    Typ                           => Etype (Unqualify (A)),
2638
                    Lhs                           => Target,
2639
                    Flist                         => Flist,
2640
                    Obj                           => Obj,
2641
                    Is_Limited_Ancestor_Expansion => True));
2642
 
2643
            --  If the ancestor part is an expression "E", we generate
2644
 
2645
            --     T(tmp) := E;
2646
 
2647
            --  In Ada 2005, this includes the case of a (possibly qualified)
2648
            --  limited function call. The assignment will turn into a
2649
            --  build-in-place function call (for further details, see
2650
            --  Make_Build_In_Place_Call_In_Assignment).
2651
 
2652
            else
2653
               Ancestor_Is_Expression := True;
2654
               Init_Typ := Etype (A);
2655
 
2656
               --  If the ancestor part is an aggregate, force its full
2657
               --  expansion, which was delayed.
2658
 
2659
               if Nkind_In (Unqualify (A), N_Aggregate,
2660
                                           N_Extension_Aggregate)
2661
               then
2662
                  Set_Analyzed (A, False);
2663
                  Set_Analyzed (Expression (A), False);
2664
               end if;
2665
 
2666
               Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2667
               Set_Assignment_OK (Ref);
2668
 
2669
               --  Make the assignment without usual controlled actions since
2670
               --  we only want the post adjust but not the pre finalize here
2671
               --  Add manual adjust when necessary.
2672
 
2673
               Assign := New_List (
2674
                 Make_OK_Assignment_Statement (Loc,
2675
                   Name       => Ref,
2676
                   Expression => A));
2677
               Set_No_Ctrl_Actions (First (Assign));
2678
 
2679
               --  Assign the tag now to make sure that the dispatching call in
2680
               --  the subsequent deep_adjust works properly (unless VM_Target,
2681
               --  where tags are implicit).
2682
 
2683
               if Tagged_Type_Expansion then
2684
                  Instr :=
2685
                    Make_OK_Assignment_Statement (Loc,
2686
                      Name =>
2687
                        Make_Selected_Component (Loc,
2688
                          Prefix => New_Copy_Tree (Target),
2689
                          Selector_Name =>
2690
                            New_Reference_To
2691
                              (First_Tag_Component (Base_Type (Typ)), Loc)),
2692
 
2693
                      Expression =>
2694
                        Unchecked_Convert_To (RTE (RE_Tag),
2695
                          New_Reference_To
2696
                            (Node (First_Elmt
2697
                               (Access_Disp_Table (Base_Type (Typ)))),
2698
                             Loc)));
2699
 
2700
                  Set_Assignment_OK (Name (Instr));
2701
                  Append_To (Assign, Instr);
2702
 
2703
                  --  Ada 2005 (AI-251): If tagged type has progenitors we must
2704
                  --  also initialize tags of the secondary dispatch tables.
2705
 
2706
                  if Has_Interfaces (Base_Type (Typ)) then
2707
                     Init_Secondary_Tags
2708
                       (Typ        => Base_Type (Typ),
2709
                        Target     => Target,
2710
                        Stmts_List => Assign);
2711
                  end if;
2712
               end if;
2713
 
2714
               --  Call Adjust manually
2715
 
2716
               if Needs_Finalization (Etype (A))
2717
                 and then not Is_Limited_Type (Etype (A))
2718
               then
2719
                  Append_List_To (Assign,
2720
                    Make_Adjust_Call (
2721
                      Ref         => New_Copy_Tree (Ref),
2722
                      Typ         => Etype (A),
2723
                      Flist_Ref   => New_Reference_To (
2724
                        RTE (RE_Global_Final_List), Loc),
2725
                      With_Attach => Make_Integer_Literal (Loc, 0)));
2726
               end if;
2727
 
2728
               Append_To (L,
2729
                 Make_Unsuppress_Block (Loc, Name_Discriminant_Check, Assign));
2730
 
2731
               if Has_Discriminants (Init_Typ) then
2732
                  Check_Ancestor_Discriminants (Init_Typ);
2733
               end if;
2734
            end if;
2735
         end;
2736
 
2737
      --  Normal case (not an extension aggregate)
2738
 
2739
      else
2740
         --  Generate the discriminant expressions, component by component.
2741
         --  If the base type is an unchecked union, the discriminants are
2742
         --  unknown to the back-end and absent from a value of the type, so
2743
         --  assignments for them are not emitted.
2744
 
2745
         if Has_Discriminants (Typ)
2746
           and then not Is_Unchecked_Union (Base_Type (Typ))
2747
         then
2748
            --  If the type is derived, and constrains discriminants of the
2749
            --  parent type, these discriminants are not components of the
2750
            --  aggregate, and must be initialized explicitly. They are not
2751
            --  visible components of the object, but can become visible with
2752
            --  a view conversion to the ancestor.
2753
 
2754
            declare
2755
               Btype      : Entity_Id;
2756
               Parent_Type : Entity_Id;
2757
               Disc        : Entity_Id;
2758
               Discr_Val   : Elmt_Id;
2759
 
2760
            begin
2761
               Btype := Base_Type (Typ);
2762
               while Is_Derived_Type (Btype)
2763
                  and then Present (Stored_Constraint (Btype))
2764
               loop
2765
                  Parent_Type := Etype (Btype);
2766
 
2767
                  Disc := First_Discriminant (Parent_Type);
2768
                  Discr_Val :=
2769
                    First_Elmt (Stored_Constraint (Base_Type (Typ)));
2770
                  while Present (Discr_Val) loop
2771
 
2772
                     --  Only those discriminants of the parent that are not
2773
                     --  renamed by discriminants of the derived type need to
2774
                     --  be added explicitly.
2775
 
2776
                     if not Is_Entity_Name (Node (Discr_Val))
2777
                       or else
2778
                         Ekind (Entity (Node (Discr_Val))) /= E_Discriminant
2779
                     then
2780
                        Comp_Expr :=
2781
                          Make_Selected_Component (Loc,
2782
                            Prefix        => New_Copy_Tree (Target),
2783
                            Selector_Name => New_Occurrence_Of (Disc, Loc));
2784
 
2785
                        Instr :=
2786
                          Make_OK_Assignment_Statement (Loc,
2787
                            Name       => Comp_Expr,
2788
                            Expression => New_Copy_Tree (Node (Discr_Val)));
2789
 
2790
                        Set_No_Ctrl_Actions (Instr);
2791
                        Append_To (L, Instr);
2792
                     end if;
2793
 
2794
                     Next_Discriminant (Disc);
2795
                     Next_Elmt (Discr_Val);
2796
                  end loop;
2797
 
2798
                  Btype := Base_Type (Parent_Type);
2799
               end loop;
2800
            end;
2801
 
2802
            --  Generate discriminant init values for the visible discriminants
2803
 
2804
            declare
2805
               Discriminant : Entity_Id;
2806
               Discriminant_Value : Node_Id;
2807
 
2808
            begin
2809
               Discriminant := First_Stored_Discriminant (Typ);
2810
               while Present (Discriminant) loop
2811
                  Comp_Expr :=
2812
                    Make_Selected_Component (Loc,
2813
                      Prefix        => New_Copy_Tree (Target),
2814
                      Selector_Name => New_Occurrence_Of (Discriminant, Loc));
2815
 
2816
                  Discriminant_Value :=
2817
                    Get_Discriminant_Value (
2818
                      Discriminant,
2819
                      N_Typ,
2820
                      Discriminant_Constraint (N_Typ));
2821
 
2822
                  Instr :=
2823
                    Make_OK_Assignment_Statement (Loc,
2824
                      Name       => Comp_Expr,
2825
                      Expression => New_Copy_Tree (Discriminant_Value));
2826
 
2827
                  Set_No_Ctrl_Actions (Instr);
2828
                  Append_To (L, Instr);
2829
 
2830
                  Next_Stored_Discriminant (Discriminant);
2831
               end loop;
2832
            end;
2833
         end if;
2834
      end if;
2835
 
2836
      --  For CPP types we generate an implicit call to the C++ default
2837
      --  constructor to ensure the proper initialization of the _Tag
2838
      --  component.
2839
 
2840
      if Is_CPP_Class (Typ) then
2841
         pragma Assert (Present (Base_Init_Proc (Typ)));
2842
         Append_List_To (L,
2843
           Build_Initialization_Call (Loc,
2844
             Id_Ref => Lhs,
2845
             Typ    => Typ));
2846
      end if;
2847
 
2848
      --  Generate the assignments, component by component
2849
 
2850
      --    tmp.comp1 := Expr1_From_Aggr;
2851
      --    tmp.comp2 := Expr2_From_Aggr;
2852
      --    ....
2853
 
2854
      Comp := First (Component_Associations (N));
2855
      while Present (Comp) loop
2856
         Selector := Entity (First (Choices (Comp)));
2857
 
2858
         --  C++ constructors
2859
 
2860
         if Is_CPP_Constructor_Call (Expression (Comp)) then
2861
            Append_List_To (L,
2862
              Build_Initialization_Call (Loc,
2863
                Id_Ref => Make_Selected_Component (Loc,
2864
                            Prefix => New_Copy_Tree (Target),
2865
                            Selector_Name => New_Occurrence_Of (Selector,
2866
                                                                   Loc)),
2867
                Typ    => Etype (Selector),
2868
                Enclos_Type => Typ,
2869
                With_Default_Init => True,
2870
                Constructor_Ref => Expression (Comp)));
2871
 
2872
         --  Ada 2005 (AI-287): For each default-initialized component generate
2873
         --  a call to the corresponding IP subprogram if available.
2874
 
2875
         elsif Box_Present (Comp)
2876
           and then Has_Non_Null_Base_Init_Proc (Etype (Selector))
2877
         then
2878
            if Ekind (Selector) /= E_Discriminant then
2879
               Gen_Ctrl_Actions_For_Aggr;
2880
            end if;
2881
 
2882
            --  Ada 2005 (AI-287): If the component type has tasks then
2883
            --  generate the activation chain and master entities (except
2884
            --  in case of an allocator because in that case these entities
2885
            --  are generated by Build_Task_Allocate_Block_With_Init_Stmts).
2886
 
2887
            declare
2888
               Ctype            : constant Entity_Id := Etype (Selector);
2889
               Inside_Allocator : Boolean   := False;
2890
               P                : Node_Id   := Parent (N);
2891
 
2892
            begin
2893
               if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
2894
                  while Present (P) loop
2895
                     if Nkind (P) = N_Allocator then
2896
                        Inside_Allocator := True;
2897
                        exit;
2898
                     end if;
2899
 
2900
                     P := Parent (P);
2901
                  end loop;
2902
 
2903
                  if not Inside_Init_Proc and not Inside_Allocator then
2904
                     Build_Activation_Chain_Entity (N);
2905
                  end if;
2906
               end if;
2907
            end;
2908
 
2909
            Append_List_To (L,
2910
              Build_Initialization_Call (Loc,
2911
                Id_Ref => Make_Selected_Component (Loc,
2912
                            Prefix => New_Copy_Tree (Target),
2913
                            Selector_Name => New_Occurrence_Of (Selector,
2914
                                                                   Loc)),
2915
                Typ    => Etype (Selector),
2916
                Enclos_Type => Typ,
2917
                With_Default_Init => True));
2918
 
2919
         --  Prepare for component assignment
2920
 
2921
         elsif Ekind (Selector) /= E_Discriminant
2922
           or else Nkind (N) = N_Extension_Aggregate
2923
         then
2924
            --  All the discriminants have now been assigned
2925
 
2926
            --  This is now a good moment to initialize and attach all the
2927
            --  controllers. Their position may depend on the discriminants.
2928
 
2929
            if Ekind (Selector) /= E_Discriminant then
2930
               Gen_Ctrl_Actions_For_Aggr;
2931
            end if;
2932
 
2933
            Comp_Type := Etype (Selector);
2934
            Comp_Expr :=
2935
              Make_Selected_Component (Loc,
2936
                Prefix        => New_Copy_Tree (Target),
2937
                Selector_Name => New_Occurrence_Of (Selector, Loc));
2938
 
2939
            if Nkind (Expression (Comp)) = N_Qualified_Expression then
2940
               Expr_Q := Expression (Expression (Comp));
2941
            else
2942
               Expr_Q := Expression (Comp);
2943
            end if;
2944
 
2945
            --  The controller is the one of the parent type defining the
2946
            --  component (in case of inherited components).
2947
 
2948
            if Needs_Finalization (Comp_Type) then
2949
               Internal_Final_List :=
2950
                 Make_Selected_Component (Loc,
2951
                   Prefix => Convert_To (
2952
                     Scope (Original_Record_Component (Selector)),
2953
                     New_Copy_Tree (Target)),
2954
                   Selector_Name =>
2955
                     Make_Identifier (Loc, Name_uController));
2956
 
2957
               Internal_Final_List :=
2958
                 Make_Selected_Component (Loc,
2959
                   Prefix => Internal_Final_List,
2960
                   Selector_Name => Make_Identifier (Loc, Name_F));
2961
 
2962
               --  The internal final list can be part of a constant object
2963
 
2964
               Set_Assignment_OK (Internal_Final_List);
2965
 
2966
            else
2967
               Internal_Final_List := Empty;
2968
            end if;
2969
 
2970
            --  Now either create the assignment or generate the code for the
2971
            --  inner aggregate top-down.
2972
 
2973
            if Is_Delayed_Aggregate (Expr_Q) then
2974
 
2975
               --  We have the following case of aggregate nesting inside
2976
               --  an object declaration:
2977
 
2978
               --    type Arr_Typ is array (Integer range <>) of ...;
2979
 
2980
               --    type Rec_Typ (...) is record
2981
               --       Obj_Arr_Typ : Arr_Typ (A .. B);
2982
               --    end record;
2983
 
2984
               --    Obj_Rec_Typ : Rec_Typ := (...,
2985
               --      Obj_Arr_Typ => (X => (...), Y => (...)));
2986
 
2987
               --  The length of the ranges of the aggregate and Obj_Add_Typ
2988
               --  are equal (B - A = Y - X), but they do not coincide (X /=
2989
               --  A and B /= Y). This case requires array sliding which is
2990
               --  performed in the following manner:
2991
 
2992
               --    subtype Arr_Sub is Arr_Typ (X .. Y);
2993
               --    Temp : Arr_Sub;
2994
               --    Temp (X) := (...);
2995
               --    ...
2996
               --    Temp (Y) := (...);
2997
               --    Obj_Rec_Typ.Obj_Arr_Typ := Temp;
2998
 
2999
               if Ekind (Comp_Type) = E_Array_Subtype
3000
                 and then Is_Int_Range_Bounds (Aggregate_Bounds (Expr_Q))
3001
                 and then Is_Int_Range_Bounds (First_Index (Comp_Type))
3002
                 and then not
3003
                   Compatible_Int_Bounds
3004
                     (Agg_Bounds => Aggregate_Bounds (Expr_Q),
3005
                      Typ_Bounds => First_Index (Comp_Type))
3006
               then
3007
                  --  Create the array subtype with bounds equal to those of
3008
                  --  the corresponding aggregate.
3009
 
3010
                  declare
3011
                     SubE : constant Entity_Id :=
3012
                              Make_Defining_Identifier (Loc,
3013
                                Chars => New_Internal_Name ('T'));
3014
 
3015
                     SubD : constant Node_Id :=
3016
                              Make_Subtype_Declaration (Loc,
3017
                                Defining_Identifier => SubE,
3018
                                Subtype_Indication  =>
3019
                                  Make_Subtype_Indication (Loc,
3020
                                    Subtype_Mark =>
3021
                                      New_Reference_To
3022
                                        (Etype (Comp_Type), Loc),
3023
                                    Constraint =>
3024
                                      Make_Index_Or_Discriminant_Constraint
3025
                                        (Loc,
3026
                                         Constraints => New_List (
3027
                                          New_Copy_Tree
3028
                                            (Aggregate_Bounds (Expr_Q))))));
3029
 
3030
                     --  Create a temporary array of the above subtype which
3031
                     --  will be used to capture the aggregate assignments.
3032
 
3033
                     TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N);
3034
 
3035
                     TmpD : constant Node_Id :=
3036
                              Make_Object_Declaration (Loc,
3037
                                Defining_Identifier => TmpE,
3038
                                Object_Definition   =>
3039
                                  New_Reference_To (SubE, Loc));
3040
 
3041
                  begin
3042
                     Set_No_Initialization (TmpD);
3043
                     Append_To (L, SubD);
3044
                     Append_To (L, TmpD);
3045
 
3046
                     --  Expand aggregate into assignments to the temp array
3047
 
3048
                     Append_List_To (L,
3049
                       Late_Expansion (Expr_Q, Comp_Type,
3050
                         New_Reference_To (TmpE, Loc), Internal_Final_List));
3051
 
3052
                     --  Slide
3053
 
3054
                     Append_To (L,
3055
                       Make_Assignment_Statement (Loc,
3056
                         Name       => New_Copy_Tree (Comp_Expr),
3057
                         Expression => New_Reference_To (TmpE, Loc)));
3058
 
3059
                     --  Do not pass the original aggregate to Gigi as is,
3060
                     --  since it will potentially clobber the front or the end
3061
                     --  of the array. Setting the expression to empty is safe
3062
                     --  since all aggregates are expanded into assignments.
3063
 
3064
                     if Present (Obj) then
3065
                        Set_Expression (Parent (Obj), Empty);
3066
                     end if;
3067
                  end;
3068
 
3069
               --  Normal case (sliding not required)
3070
 
3071
               else
3072
                  Append_List_To (L,
3073
                    Late_Expansion (Expr_Q, Comp_Type, Comp_Expr,
3074
                      Internal_Final_List));
3075
               end if;
3076
 
3077
            --  Expr_Q is not delayed aggregate
3078
 
3079
            else
3080
               if Has_Discriminants (Typ) then
3081
                  Replace_Discriminants (Expr_Q);
3082
               end if;
3083
 
3084
               Instr :=
3085
                 Make_OK_Assignment_Statement (Loc,
3086
                   Name       => Comp_Expr,
3087
                   Expression => Expr_Q);
3088
 
3089
               Set_No_Ctrl_Actions (Instr);
3090
               Append_To (L, Instr);
3091
 
3092
               --  Adjust the tag if tagged (because of possible view
3093
               --  conversions), unless compiling for a VM where tags are
3094
               --  implicit.
3095
 
3096
               --    tmp.comp._tag := comp_typ'tag;
3097
 
3098
               if Is_Tagged_Type (Comp_Type)
3099
                 and then Tagged_Type_Expansion
3100
               then
3101
                  Instr :=
3102
                    Make_OK_Assignment_Statement (Loc,
3103
                      Name =>
3104
                        Make_Selected_Component (Loc,
3105
                          Prefix =>  New_Copy_Tree (Comp_Expr),
3106
                          Selector_Name =>
3107
                            New_Reference_To
3108
                              (First_Tag_Component (Comp_Type), Loc)),
3109
 
3110
                      Expression =>
3111
                        Unchecked_Convert_To (RTE (RE_Tag),
3112
                          New_Reference_To
3113
                            (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
3114
                             Loc)));
3115
 
3116
                  Append_To (L, Instr);
3117
               end if;
3118
 
3119
               --  Adjust and Attach the component to the proper controller
3120
 
3121
               --     Adjust (tmp.comp);
3122
               --     Attach_To_Final_List (tmp.comp,
3123
               --       comp_typ (tmp)._record_controller.f)
3124
 
3125
               if Needs_Finalization (Comp_Type)
3126
                 and then not Is_Limited_Type (Comp_Type)
3127
               then
3128
                  Append_List_To (L,
3129
                    Make_Adjust_Call (
3130
                      Ref         => New_Copy_Tree (Comp_Expr),
3131
                      Typ         => Comp_Type,
3132
                      Flist_Ref   => Internal_Final_List,
3133
                      With_Attach => Make_Integer_Literal (Loc, 1)));
3134
               end if;
3135
            end if;
3136
 
3137
         --  ???
3138
 
3139
         elsif Ekind (Selector) = E_Discriminant
3140
           and then Nkind (N) /= N_Extension_Aggregate
3141
           and then Nkind (Parent (N)) = N_Component_Association
3142
           and then Is_Constrained (Typ)
3143
         then
3144
            --  We must check that the discriminant value imposed by the
3145
            --  context is the same as the value given in the subaggregate,
3146
            --  because after the expansion into assignments there is no
3147
            --  record on which to perform a regular discriminant check.
3148
 
3149
            declare
3150
               D_Val : Elmt_Id;
3151
               Disc  : Entity_Id;
3152
 
3153
            begin
3154
               D_Val := First_Elmt (Discriminant_Constraint (Typ));
3155
               Disc  := First_Discriminant (Typ);
3156
               while Chars (Disc) /= Chars (Selector) loop
3157
                  Next_Discriminant (Disc);
3158
                  Next_Elmt (D_Val);
3159
               end loop;
3160
 
3161
               pragma Assert (Present (D_Val));
3162
 
3163
               --  This check cannot performed for components that are
3164
               --  constrained by a current instance, because this is not a
3165
               --  value that can be compared with the actual constraint.
3166
 
3167
               if Nkind (Node (D_Val)) /= N_Attribute_Reference
3168
                 or else not Is_Entity_Name (Prefix (Node (D_Val)))
3169
                 or else not Is_Type (Entity (Prefix (Node (D_Val))))
3170
               then
3171
                  Append_To (L,
3172
                  Make_Raise_Constraint_Error (Loc,
3173
                    Condition =>
3174
                      Make_Op_Ne (Loc,
3175
                        Left_Opnd => New_Copy_Tree (Node (D_Val)),
3176
                        Right_Opnd => Expression (Comp)),
3177
                      Reason => CE_Discriminant_Check_Failed));
3178
 
3179
               else
3180
                  --  Find self-reference in previous discriminant assignment,
3181
                  --  and replace with proper expression.
3182
 
3183
                  declare
3184
                     Ass : Node_Id;
3185
 
3186
                  begin
3187
                     Ass := First (L);
3188
                     while Present (Ass) loop
3189
                        if Nkind (Ass) = N_Assignment_Statement
3190
                          and then Nkind (Name (Ass)) = N_Selected_Component
3191
                          and then Chars (Selector_Name (Name (Ass))) =
3192
                             Chars (Disc)
3193
                        then
3194
                           Set_Expression
3195
                             (Ass, New_Copy_Tree (Expression (Comp)));
3196
                           exit;
3197
                        end if;
3198
                        Next (Ass);
3199
                     end loop;
3200
                  end;
3201
               end if;
3202
            end;
3203
         end if;
3204
 
3205
         Next (Comp);
3206
      end loop;
3207
 
3208
      --  If the type is tagged, the tag needs to be initialized (unless
3209
      --  compiling for the Java VM where tags are implicit). It is done
3210
      --  late in the initialization process because in some cases, we call
3211
      --  the init proc of an ancestor which will not leave out the right tag
3212
 
3213
      if Ancestor_Is_Expression then
3214
         null;
3215
 
3216
      --  For CPP types we generated a call to the C++ default constructor
3217
      --  before the components have been initialized to ensure the proper
3218
      --  initialization of the _Tag component (see above).
3219
 
3220
      elsif Is_CPP_Class (Typ) then
3221
         null;
3222
 
3223
      elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
3224
         Instr :=
3225
           Make_OK_Assignment_Statement (Loc,
3226
             Name =>
3227
               Make_Selected_Component (Loc,
3228
                 Prefix => New_Copy_Tree (Target),
3229
                 Selector_Name =>
3230
                   New_Reference_To
3231
                     (First_Tag_Component (Base_Type (Typ)), Loc)),
3232
 
3233
             Expression =>
3234
               Unchecked_Convert_To (RTE (RE_Tag),
3235
                 New_Reference_To
3236
                   (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))),
3237
                    Loc)));
3238
 
3239
         Append_To (L, Instr);
3240
 
3241
         --  Ada 2005 (AI-251): If the tagged type has been derived from
3242
         --  abstract interfaces we must also initialize the tags of the
3243
         --  secondary dispatch tables.
3244
 
3245
         if Has_Interfaces (Base_Type (Typ)) then
3246
            Init_Secondary_Tags
3247
              (Typ        => Base_Type (Typ),
3248
               Target     => Target,
3249
               Stmts_List => L);
3250
         end if;
3251
      end if;
3252
 
3253
      --  If the controllers have not been initialized yet (by lack of non-
3254
      --  discriminant components), let's do it now.
3255
 
3256
      Gen_Ctrl_Actions_For_Aggr;
3257
 
3258
      return L;
3259
   end Build_Record_Aggr_Code;
3260
 
3261
   -------------------------------
3262
   -- Convert_Aggr_In_Allocator --
3263
   -------------------------------
3264
 
3265
   procedure Convert_Aggr_In_Allocator
3266
     (Alloc :  Node_Id;
3267
      Decl  :  Node_Id;
3268
      Aggr  :  Node_Id)
3269
   is
3270
      Loc  : constant Source_Ptr := Sloc (Aggr);
3271
      Typ  : constant Entity_Id  := Etype (Aggr);
3272
      Temp : constant Entity_Id  := Defining_Identifier (Decl);
3273
 
3274
      Occ  : constant Node_Id :=
3275
               Unchecked_Convert_To (Typ,
3276
                 Make_Explicit_Dereference (Loc,
3277
                   New_Reference_To (Temp, Loc)));
3278
 
3279
      Access_Type : constant Entity_Id := Etype (Temp);
3280
      Flist       : Entity_Id;
3281
 
3282
   begin
3283
      --  If the allocator is for an access discriminant, there is no
3284
      --  finalization list for the anonymous access type, and the eventual
3285
      --  finalization of the object is handled through the coextension
3286
      --  mechanism. If the enclosing object is not dynamically allocated,
3287
      --  the access discriminant is itself placed on the stack. Otherwise,
3288
      --  some other finalization list is used (see exp_ch4.adb).
3289
 
3290
      --  Decl has been inserted in the code ahead of the allocator, using
3291
      --  Insert_Actions. We use Insert_Actions below as well, to ensure that
3292
      --  subsequent insertions are done in the proper order. Using (for
3293
      --  example) Insert_Actions_After to place the expanded aggregate
3294
      --  immediately after Decl may lead to out-of-order references if the
3295
      --  allocator has generated a finalization list, as when the designated
3296
      --  object is controlled and there is an open transient scope.
3297
 
3298
      if Ekind (Access_Type) = E_Anonymous_Access_Type
3299
        and then Nkind (Associated_Node_For_Itype (Access_Type)) =
3300
                                              N_Discriminant_Specification
3301
      then
3302
         Flist := Empty;
3303
 
3304
      elsif Needs_Finalization (Typ) then
3305
         Flist := Find_Final_List (Access_Type);
3306
 
3307
      --  Otherwise there are no controlled actions to be performed.
3308
 
3309
      else
3310
         Flist := Empty;
3311
      end if;
3312
 
3313
      if Is_Array_Type (Typ) then
3314
         Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ);
3315
 
3316
      elsif Has_Default_Init_Comps (Aggr) then
3317
         declare
3318
            L          : constant List_Id := New_List;
3319
            Init_Stmts : List_Id;
3320
 
3321
         begin
3322
            Init_Stmts :=
3323
              Late_Expansion
3324
                (Aggr, Typ, Occ,
3325
                 Flist,
3326
                 Associated_Final_Chain (Base_Type (Access_Type)));
3327
 
3328
            --  ??? Dubious actual for Obj: expect 'the original object being
3329
            --  initialized'
3330
 
3331
            if Has_Task (Typ) then
3332
               Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
3333
               Insert_Actions (Alloc, L);
3334
            else
3335
               Insert_Actions (Alloc, Init_Stmts);
3336
            end if;
3337
         end;
3338
 
3339
      else
3340
         Insert_Actions (Alloc,
3341
           Late_Expansion
3342
             (Aggr, Typ, Occ, Flist,
3343
              Associated_Final_Chain (Base_Type (Access_Type))));
3344
 
3345
         --  ??? Dubious actual for Obj: expect 'the original object being
3346
         --  initialized'
3347
 
3348
      end if;
3349
   end Convert_Aggr_In_Allocator;
3350
 
3351
   --------------------------------
3352
   -- Convert_Aggr_In_Assignment --
3353
   --------------------------------
3354
 
3355
   procedure Convert_Aggr_In_Assignment (N : Node_Id) is
3356
      Aggr : Node_Id            := Expression (N);
3357
      Typ  : constant Entity_Id := Etype (Aggr);
3358
      Occ  : constant Node_Id   := New_Copy_Tree (Name (N));
3359
 
3360
   begin
3361
      if Nkind (Aggr) = N_Qualified_Expression then
3362
         Aggr := Expression (Aggr);
3363
      end if;
3364
 
3365
      Insert_Actions_After (N,
3366
        Late_Expansion
3367
          (Aggr, Typ, Occ,
3368
           Find_Final_List (Typ, New_Copy_Tree (Occ))));
3369
   end Convert_Aggr_In_Assignment;
3370
 
3371
   ---------------------------------
3372
   -- Convert_Aggr_In_Object_Decl --
3373
   ---------------------------------
3374
 
3375
   procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is
3376
      Obj  : constant Entity_Id  := Defining_Identifier (N);
3377
      Aggr : Node_Id             := Expression (N);
3378
      Loc  : constant Source_Ptr := Sloc (Aggr);
3379
      Typ  : constant Entity_Id  := Etype (Aggr);
3380
      Occ  : constant Node_Id    := New_Occurrence_Of (Obj, Loc);
3381
 
3382
      function Discriminants_Ok return Boolean;
3383
      --  If the object type is constrained, the discriminants in the
3384
      --  aggregate must be checked against the discriminants of the subtype.
3385
      --  This cannot be done using Apply_Discriminant_Checks because after
3386
      --  expansion there is no aggregate left to check.
3387
 
3388
      ----------------------
3389
      -- Discriminants_Ok --
3390
      ----------------------
3391
 
3392
      function Discriminants_Ok return Boolean is
3393
         Cond  : Node_Id := Empty;
3394
         Check : Node_Id;
3395
         D     : Entity_Id;
3396
         Disc1 : Elmt_Id;
3397
         Disc2 : Elmt_Id;
3398
         Val1  : Node_Id;
3399
         Val2  : Node_Id;
3400
 
3401
      begin
3402
         D := First_Discriminant (Typ);
3403
         Disc1 := First_Elmt (Discriminant_Constraint (Typ));
3404
         Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj)));
3405
         while Present (Disc1) and then Present (Disc2) loop
3406
            Val1 := Node (Disc1);
3407
            Val2 := Node (Disc2);
3408
 
3409
            if not Is_OK_Static_Expression (Val1)
3410
              or else not Is_OK_Static_Expression (Val2)
3411
            then
3412
               Check := Make_Op_Ne (Loc,
3413
                 Left_Opnd  => Duplicate_Subexpr (Val1),
3414
                 Right_Opnd => Duplicate_Subexpr (Val2));
3415
 
3416
               if No (Cond) then
3417
                  Cond := Check;
3418
 
3419
               else
3420
                  Cond := Make_Or_Else (Loc,
3421
                    Left_Opnd => Cond,
3422
                    Right_Opnd => Check);
3423
               end if;
3424
 
3425
            elsif Expr_Value (Val1) /= Expr_Value (Val2) then
3426
               Apply_Compile_Time_Constraint_Error (Aggr,
3427
                 Msg    => "incorrect value for discriminant&?",
3428
                 Reason => CE_Discriminant_Check_Failed,
3429
                 Ent    => D);
3430
               return False;
3431
            end if;
3432
 
3433
            Next_Discriminant (D);
3434
            Next_Elmt (Disc1);
3435
            Next_Elmt (Disc2);
3436
         end loop;
3437
 
3438
         --  If any discriminant constraint is non-static, emit a check
3439
 
3440
         if Present (Cond) then
3441
            Insert_Action (N,
3442
              Make_Raise_Constraint_Error (Loc,
3443
                Condition => Cond,
3444
                Reason => CE_Discriminant_Check_Failed));
3445
         end if;
3446
 
3447
         return True;
3448
      end Discriminants_Ok;
3449
 
3450
   --  Start of processing for Convert_Aggr_In_Object_Decl
3451
 
3452
   begin
3453
      Set_Assignment_OK (Occ);
3454
 
3455
      if Nkind (Aggr) = N_Qualified_Expression then
3456
         Aggr := Expression (Aggr);
3457
      end if;
3458
 
3459
      if Has_Discriminants (Typ)
3460
        and then Typ /= Etype (Obj)
3461
        and then Is_Constrained (Etype (Obj))
3462
        and then not Discriminants_Ok
3463
      then
3464
         return;
3465
      end if;
3466
 
3467
      --  If the context is an extended return statement, it has its own
3468
      --  finalization machinery (i.e. works like a transient scope) and
3469
      --  we do not want to create an additional one, because objects on
3470
      --  the finalization list of the return must be moved to the caller's
3471
      --  finalization list to complete the return.
3472
 
3473
      --  However, if the aggregate is limited, it is built in place, and the
3474
      --  controlled components are not assigned to intermediate temporaries
3475
      --  so there is no need for a transient scope in this case either.
3476
 
3477
      if Requires_Transient_Scope (Typ)
3478
        and then Ekind (Current_Scope) /= E_Return_Statement
3479
        and then not Is_Limited_Type (Typ)
3480
      then
3481
         Establish_Transient_Scope
3482
           (Aggr,
3483
            Sec_Stack =>
3484
              Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
3485
      end if;
3486
 
3487
      Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj));
3488
      Set_No_Initialization (N);
3489
      Initialize_Discriminants (N, Typ);
3490
   end Convert_Aggr_In_Object_Decl;
3491
 
3492
   -------------------------------------
3493
   -- Convert_Array_Aggr_In_Allocator --
3494
   -------------------------------------
3495
 
3496
   procedure Convert_Array_Aggr_In_Allocator
3497
     (Decl   : Node_Id;
3498
      Aggr   : Node_Id;
3499
      Target : Node_Id)
3500
   is
3501
      Aggr_Code : List_Id;
3502
      Typ       : constant Entity_Id := Etype (Aggr);
3503
      Ctyp      : constant Entity_Id := Component_Type (Typ);
3504
 
3505
   begin
3506
      --  The target is an explicit dereference of the allocated object.
3507
      --  Generate component assignments to it, as for an aggregate that
3508
      --  appears on the right-hand side of an assignment statement.
3509
 
3510
      Aggr_Code :=
3511
        Build_Array_Aggr_Code (Aggr,
3512
          Ctype       => Ctyp,
3513
          Index       => First_Index (Typ),
3514
          Into        => Target,
3515
          Scalar_Comp => Is_Scalar_Type (Ctyp));
3516
 
3517
      Insert_Actions_After (Decl, Aggr_Code);
3518
   end Convert_Array_Aggr_In_Allocator;
3519
 
3520
   ----------------------------
3521
   -- Convert_To_Assignments --
3522
   ----------------------------
3523
 
3524
   procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
3525
      Loc  : constant Source_Ptr := Sloc (N);
3526
      T    : Entity_Id;
3527
      Temp : Entity_Id;
3528
 
3529
      Instr       : Node_Id;
3530
      Target_Expr : Node_Id;
3531
      Parent_Kind : Node_Kind;
3532
      Unc_Decl    : Boolean := False;
3533
      Parent_Node : Node_Id;
3534
 
3535
   begin
3536
      pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
3537
      pragma Assert (Is_Record_Type (Typ));
3538
 
3539
      Parent_Node := Parent (N);
3540
      Parent_Kind := Nkind (Parent_Node);
3541
 
3542
      if Parent_Kind = N_Qualified_Expression then
3543
 
3544
         --  Check if we are in a unconstrained declaration because in this
3545
         --  case the current delayed expansion mechanism doesn't work when
3546
         --  the declared object size depend on the initializing expr.
3547
 
3548
         begin
3549
            Parent_Node := Parent (Parent_Node);
3550
            Parent_Kind := Nkind (Parent_Node);
3551
 
3552
            if Parent_Kind = N_Object_Declaration then
3553
               Unc_Decl :=
3554
                 not Is_Entity_Name (Object_Definition (Parent_Node))
3555
                   or else Has_Discriminants
3556
                             (Entity (Object_Definition (Parent_Node)))
3557
                   or else Is_Class_Wide_Type
3558
                             (Entity (Object_Definition (Parent_Node)));
3559
            end if;
3560
         end;
3561
      end if;
3562
 
3563
      --  Just set the Delay flag in the cases where the transformation will be
3564
      --  done top down from above.
3565
 
3566
      if False
3567
 
3568
         --  Internal aggregate (transformed when expanding the parent)
3569
 
3570
         or else Parent_Kind = N_Aggregate
3571
         or else Parent_Kind = N_Extension_Aggregate
3572
         or else Parent_Kind = N_Component_Association
3573
 
3574
         --  Allocator (see Convert_Aggr_In_Allocator)
3575
 
3576
         or else Parent_Kind = N_Allocator
3577
 
3578
         --  Object declaration (see Convert_Aggr_In_Object_Decl)
3579
 
3580
         or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
3581
 
3582
         --  Safe assignment (see Convert_Aggr_Assignments). So far only the
3583
         --  assignments in init procs are taken into account.
3584
 
3585
         or else (Parent_Kind = N_Assignment_Statement
3586
                   and then Inside_Init_Proc)
3587
 
3588
         --  (Ada 2005) An inherently limited type in a return statement,
3589
         --  which will be handled in a build-in-place fashion, and may be
3590
         --  rewritten as an extended return and have its own finalization
3591
         --  machinery. In the case of a simple return, the aggregate needs
3592
         --  to be delayed until the scope for the return statement has been
3593
         --  created, so that any finalization chain will be associated with
3594
         --  that scope. For extended returns, we delay expansion to avoid the
3595
         --  creation of an unwanted transient scope that could result in
3596
         --  premature finalization of the return object (which is built in
3597
         --  in place within the caller's scope).
3598
 
3599
         or else
3600
           (Is_Inherently_Limited_Type (Typ)
3601
             and then
3602
               (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement
3603
                 or else Nkind (Parent_Node) = N_Simple_Return_Statement))
3604
      then
3605
         Set_Expansion_Delayed (N);
3606
         return;
3607
      end if;
3608
 
3609
      if Requires_Transient_Scope (Typ) then
3610
         Establish_Transient_Scope
3611
           (N, Sec_Stack =>
3612
                 Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
3613
      end if;
3614
 
3615
      --  If the aggregate is non-limited, create a temporary. If it is limited
3616
      --  and the context is an assignment, this is a subaggregate for an
3617
      --  enclosing aggregate being expanded. It must be built in place, so use
3618
      --  the target of the current assignment.
3619
 
3620
      if Is_Limited_Type (Typ)
3621
        and then Nkind (Parent (N)) = N_Assignment_Statement
3622
      then
3623
         Target_Expr := New_Copy_Tree (Name (Parent (N)));
3624
         Insert_Actions
3625
           (Parent (N), Build_Record_Aggr_Code (N, Typ, Target_Expr));
3626
         Rewrite (Parent (N), Make_Null_Statement (Loc));
3627
 
3628
      else
3629
         Temp := Make_Temporary (Loc, 'A', N);
3630
 
3631
         --  If the type inherits unknown discriminants, use the view with
3632
         --  known discriminants if available.
3633
 
3634
         if Has_Unknown_Discriminants (Typ)
3635
            and then Present (Underlying_Record_View (Typ))
3636
         then
3637
            T := Underlying_Record_View (Typ);
3638
         else
3639
            T := Typ;
3640
         end if;
3641
 
3642
         Instr :=
3643
           Make_Object_Declaration (Loc,
3644
             Defining_Identifier => Temp,
3645
             Object_Definition   => New_Occurrence_Of (T, Loc));
3646
 
3647
         Set_No_Initialization (Instr);
3648
         Insert_Action (N, Instr);
3649
         Initialize_Discriminants (Instr, T);
3650
         Target_Expr := New_Occurrence_Of (Temp, Loc);
3651
         Insert_Actions (N, Build_Record_Aggr_Code (N, T, Target_Expr));
3652
         Rewrite (N, New_Occurrence_Of (Temp, Loc));
3653
         Analyze_And_Resolve (N, T);
3654
      end if;
3655
   end Convert_To_Assignments;
3656
 
3657
   ---------------------------
3658
   -- Convert_To_Positional --
3659
   ---------------------------
3660
 
3661
   procedure Convert_To_Positional
3662
     (N                    : Node_Id;
3663
      Max_Others_Replicate : Nat     := 5;
3664
      Handle_Bit_Packed    : Boolean := False)
3665
   is
3666
      Typ : constant Entity_Id := Etype (N);
3667
 
3668
      Static_Components : Boolean := True;
3669
 
3670
      procedure Check_Static_Components;
3671
      --  Check whether all components of the aggregate are compile-time known
3672
      --  values, and can be passed as is to the back-end without further
3673
      --  expansion.
3674
 
3675
      function Flatten
3676
        (N   : Node_Id;
3677
         Ix  : Node_Id;
3678
         Ixb : Node_Id) return Boolean;
3679
      --  Convert the aggregate into a purely positional form if possible. On
3680
      --  entry the bounds of all dimensions are known to be static, and the
3681
      --  total number of components is safe enough to expand.
3682
 
3683
      function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
3684
      --  Return True iff the array N is flat (which is not trivial in the case
3685
      --  of multidimensionsl aggregates).
3686
 
3687
      -----------------------------
3688
      -- Check_Static_Components --
3689
      -----------------------------
3690
 
3691
      procedure Check_Static_Components is
3692
         Expr : Node_Id;
3693
 
3694
      begin
3695
         Static_Components := True;
3696
 
3697
         if Nkind (N) = N_String_Literal then
3698
            null;
3699
 
3700
         elsif Present (Expressions (N)) then
3701
            Expr := First (Expressions (N));
3702
            while Present (Expr) loop
3703
               if Nkind (Expr) /= N_Aggregate
3704
                 or else not Compile_Time_Known_Aggregate (Expr)
3705
                 or else Expansion_Delayed (Expr)
3706
               then
3707
                  Static_Components := False;
3708
                  exit;
3709
               end if;
3710
 
3711
               Next (Expr);
3712
            end loop;
3713
         end if;
3714
 
3715
         if Nkind (N) = N_Aggregate
3716
           and then  Present (Component_Associations (N))
3717
         then
3718
            Expr := First (Component_Associations (N));
3719
            while Present (Expr) loop
3720
               if Nkind (Expression (Expr)) = N_Integer_Literal then
3721
                  null;
3722
 
3723
               elsif Nkind (Expression (Expr)) /= N_Aggregate
3724
                 or else
3725
                   not Compile_Time_Known_Aggregate (Expression (Expr))
3726
                 or else Expansion_Delayed (Expression (Expr))
3727
               then
3728
                  Static_Components := False;
3729
                  exit;
3730
               end if;
3731
 
3732
               Next (Expr);
3733
            end loop;
3734
         end if;
3735
      end Check_Static_Components;
3736
 
3737
      -------------
3738
      -- Flatten --
3739
      -------------
3740
 
3741
      function Flatten
3742
        (N   : Node_Id;
3743
         Ix  : Node_Id;
3744
         Ixb : Node_Id) return Boolean
3745
      is
3746
         Loc : constant Source_Ptr := Sloc (N);
3747
         Blo : constant Node_Id    := Type_Low_Bound (Etype (Ixb));
3748
         Lo  : constant Node_Id    := Type_Low_Bound (Etype (Ix));
3749
         Hi  : constant Node_Id    := Type_High_Bound (Etype (Ix));
3750
         Lov : Uint;
3751
         Hiv : Uint;
3752
 
3753
      begin
3754
         if Nkind (Original_Node (N)) = N_String_Literal then
3755
            return True;
3756
         end if;
3757
 
3758
         if not Compile_Time_Known_Value (Lo)
3759
           or else not Compile_Time_Known_Value (Hi)
3760
         then
3761
            return False;
3762
         end if;
3763
 
3764
         Lov := Expr_Value (Lo);
3765
         Hiv := Expr_Value (Hi);
3766
 
3767
         if Hiv < Lov
3768
           or else not Compile_Time_Known_Value (Blo)
3769
         then
3770
            return False;
3771
         end if;
3772
 
3773
         --  Determine if set of alternatives is suitable for conversion and
3774
         --  build an array containing the values in sequence.
3775
 
3776
         declare
3777
            Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv))
3778
                     of Node_Id := (others => Empty);
3779
            --  The values in the aggregate sorted appropriately
3780
 
3781
            Vlist : List_Id;
3782
            --  Same data as Vals in list form
3783
 
3784
            Rep_Count : Nat;
3785
            --  Used to validate Max_Others_Replicate limit
3786
 
3787
            Elmt   : Node_Id;
3788
            Num    : Int := UI_To_Int (Lov);
3789
            Choice : Node_Id;
3790
            Lo, Hi : Node_Id;
3791
 
3792
         begin
3793
            if Present (Expressions (N)) then
3794
               Elmt := First (Expressions (N));
3795
               while Present (Elmt) loop
3796
                  if Nkind (Elmt) = N_Aggregate
3797
                    and then Present (Next_Index (Ix))
3798
                    and then
3799
                      not Flatten (Elmt, Next_Index (Ix), Next_Index (Ixb))
3800
                  then
3801
                     return False;
3802
                  end if;
3803
 
3804
                  Vals (Num) := Relocate_Node (Elmt);
3805
                  Num := Num + 1;
3806
 
3807
                  Next (Elmt);
3808
               end loop;
3809
            end if;
3810
 
3811
            if No (Component_Associations (N)) then
3812
               return True;
3813
            end if;
3814
 
3815
            Elmt := First (Component_Associations (N));
3816
 
3817
            if Nkind (Expression (Elmt)) = N_Aggregate then
3818
               if Present (Next_Index (Ix))
3819
                 and then
3820
                   not Flatten
3821
                        (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb))
3822
               then
3823
                  return False;
3824
               end if;
3825
            end if;
3826
 
3827
            Component_Loop : while Present (Elmt) loop
3828
               Choice := First (Choices (Elmt));
3829
               Choice_Loop : while Present (Choice) loop
3830
 
3831
                  --  If we have an others choice, fill in the missing elements
3832
                  --  subject to the limit established by Max_Others_Replicate.
3833
 
3834
                  if Nkind (Choice) = N_Others_Choice then
3835
                     Rep_Count := 0;
3836
 
3837
                     for J in Vals'Range loop
3838
                        if No (Vals (J)) then
3839
                           Vals (J) := New_Copy_Tree (Expression (Elmt));
3840
                           Rep_Count := Rep_Count + 1;
3841
 
3842
                           --  Check for maximum others replication. Note that
3843
                           --  we skip this test if either of the restrictions
3844
                           --  No_Elaboration_Code or No_Implicit_Loops is
3845
                           --  active, if this is a preelaborable unit or a
3846
                           --  predefined unit. This ensures that predefined
3847
                           --  units get the same level of constant folding in
3848
                           --  Ada 95 and Ada 05, where their categorization
3849
                           --  has changed.
3850
 
3851
                           declare
3852
                              P : constant Entity_Id :=
3853
                                    Cunit_Entity (Current_Sem_Unit);
3854
 
3855
                           begin
3856
                              --  Check if duplication OK and if so continue
3857
                              --  processing.
3858
 
3859
                              if Restriction_Active (No_Elaboration_Code)
3860
                                or else Restriction_Active (No_Implicit_Loops)
3861
                                or else Is_Preelaborated (P)
3862
                                or else (Ekind (P) = E_Package_Body
3863
                                          and then
3864
                                            Is_Preelaborated (Spec_Entity (P)))
3865
                                or else
3866
                                  Is_Predefined_File_Name
3867
                                    (Unit_File_Name (Get_Source_Unit (P)))
3868
                              then
3869
                                 null;
3870
 
3871
                              --  If duplication not OK, then we return False
3872
                              --  if the replication count is too high
3873
 
3874
                              elsif Rep_Count > Max_Others_Replicate then
3875
                                 return False;
3876
 
3877
                              --  Continue on if duplication not OK, but the
3878
                              --  replication count is not excessive.
3879
 
3880
                              else
3881
                                 null;
3882
                              end if;
3883
                           end;
3884
                        end if;
3885
                     end loop;
3886
 
3887
                     exit Component_Loop;
3888
 
3889
                  --  Case of a subtype mark
3890
 
3891
                  elsif Nkind (Choice) = N_Identifier
3892
                    and then Is_Type (Entity (Choice))
3893
                  then
3894
                     Lo := Type_Low_Bound  (Etype (Choice));
3895
                     Hi := Type_High_Bound (Etype (Choice));
3896
 
3897
                  --  Case of subtype indication
3898
 
3899
                  elsif Nkind (Choice) = N_Subtype_Indication then
3900
                     Lo := Low_Bound  (Range_Expression (Constraint (Choice)));
3901
                     Hi := High_Bound (Range_Expression (Constraint (Choice)));
3902
 
3903
                  --  Case of a range
3904
 
3905
                  elsif Nkind (Choice) = N_Range then
3906
                     Lo := Low_Bound (Choice);
3907
                     Hi := High_Bound (Choice);
3908
 
3909
                  --  Normal subexpression case
3910
 
3911
                  else pragma Assert (Nkind (Choice) in N_Subexpr);
3912
                     if not Compile_Time_Known_Value (Choice) then
3913
                        return False;
3914
 
3915
                     else
3916
                        Vals (UI_To_Int (Expr_Value (Choice))) :=
3917
                          New_Copy_Tree (Expression (Elmt));
3918
                        goto Continue;
3919
                     end if;
3920
                  end if;
3921
 
3922
                  --  Range cases merge with Lo,Hi set
3923
 
3924
                  if not Compile_Time_Known_Value (Lo)
3925
                       or else
3926
                     not Compile_Time_Known_Value (Hi)
3927
                  then
3928
                     return False;
3929
                  else
3930
                     for J in UI_To_Int (Expr_Value (Lo)) ..
3931
                              UI_To_Int (Expr_Value (Hi))
3932
                     loop
3933
                        Vals (J) := New_Copy_Tree (Expression (Elmt));
3934
                     end loop;
3935
                  end if;
3936
 
3937
               <<Continue>>
3938
                  Next (Choice);
3939
               end loop Choice_Loop;
3940
 
3941
               Next (Elmt);
3942
            end loop Component_Loop;
3943
 
3944
            --  If we get here the conversion is possible
3945
 
3946
            Vlist := New_List;
3947
            for J in Vals'Range loop
3948
               Append (Vals (J), Vlist);
3949
            end loop;
3950
 
3951
            Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist));
3952
            Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N)));
3953
            return True;
3954
         end;
3955
      end Flatten;
3956
 
3957
      -------------
3958
      -- Is_Flat --
3959
      -------------
3960
 
3961
      function Is_Flat (N : Node_Id; Dims : Int) return Boolean is
3962
         Elmt : Node_Id;
3963
 
3964
      begin
3965
         if Dims = 0 then
3966
            return True;
3967
 
3968
         elsif Nkind (N) = N_Aggregate then
3969
            if Present (Component_Associations (N)) then
3970
               return False;
3971
 
3972
            else
3973
               Elmt := First (Expressions (N));
3974
               while Present (Elmt) loop
3975
                  if not Is_Flat (Elmt, Dims - 1) then
3976
                     return False;
3977
                  end if;
3978
 
3979
                  Next (Elmt);
3980
               end loop;
3981
 
3982
               return True;
3983
            end if;
3984
         else
3985
            return True;
3986
         end if;
3987
      end Is_Flat;
3988
 
3989
   --  Start of processing for Convert_To_Positional
3990
 
3991
   begin
3992
      --  Ada 2005 (AI-287): Do not convert in case of default initialized
3993
      --  components because in this case will need to call the corresponding
3994
      --  IP procedure.
3995
 
3996
      if Has_Default_Init_Comps (N) then
3997
         return;
3998
      end if;
3999
 
4000
      if Is_Flat (N, Number_Dimensions (Typ)) then
4001
         return;
4002
      end if;
4003
 
4004
      if Is_Bit_Packed_Array (Typ)
4005
        and then not Handle_Bit_Packed
4006
      then
4007
         return;
4008
      end if;
4009
 
4010
      --  Do not convert to positional if controlled components are involved
4011
      --  since these require special processing
4012
 
4013
      if Has_Controlled_Component (Typ) then
4014
         return;
4015
      end if;
4016
 
4017
      Check_Static_Components;
4018
 
4019
      --  If the size is known, or all the components are static, try to
4020
      --  build a fully positional aggregate.
4021
 
4022
      --  The size of the type  may not be known for an aggregate with
4023
      --  discriminated array components, but if the components are static
4024
      --  it is still possible to verify statically that the length is
4025
      --  compatible with the upper bound of the type, and therefore it is
4026
      --  worth flattening such aggregates as well.
4027
 
4028
      --  For now the back-end expands these aggregates into individual
4029
      --  assignments to the target anyway, but it is conceivable that
4030
      --  it will eventually be able to treat such aggregates statically???
4031
 
4032
      if Aggr_Size_OK (N, Typ)
4033
        and then Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ)))
4034
      then
4035
         if Static_Components then
4036
            Set_Compile_Time_Known_Aggregate (N);
4037
            Set_Expansion_Delayed (N, False);
4038
         end if;
4039
 
4040
         Analyze_And_Resolve (N, Typ);
4041
      end if;
4042
   end Convert_To_Positional;
4043
 
4044
   ----------------------------
4045
   -- Expand_Array_Aggregate --
4046
   ----------------------------
4047
 
4048
   --  Array aggregate expansion proceeds as follows:
4049
 
4050
   --  1. If requested we generate code to perform all the array aggregate
4051
   --     bound checks, specifically
4052
 
4053
   --         (a) Check that the index range defined by aggregate bounds is
4054
   --             compatible with corresponding index subtype.
4055
 
4056
   --         (b) If an others choice is present check that no aggregate
4057
   --             index is outside the bounds of the index constraint.
4058
 
4059
   --         (c) For multidimensional arrays make sure that all subaggregates
4060
   --             corresponding to the same dimension have the same bounds.
4061
 
4062
   --  2. Check for packed array aggregate which can be converted to a
4063
   --     constant so that the aggregate disappeares completely.
4064
 
4065
   --  3. Check case of nested aggregate. Generally nested aggregates are
4066
   --     handled during the processing of the parent aggregate.
4067
 
4068
   --  4. Check if the aggregate can be statically processed. If this is the
4069
   --     case pass it as is to Gigi. Note that a necessary condition for
4070
   --     static processing is that the aggregate be fully positional.
4071
 
4072
   --  5. If in place aggregate expansion is possible (i.e. no need to create
4073
   --     a temporary) then mark the aggregate as such and return. Otherwise
4074
   --     create a new temporary and generate the appropriate initialization
4075
   --     code.
4076
 
4077
   procedure Expand_Array_Aggregate (N : Node_Id) is
4078
      Loc : constant Source_Ptr := Sloc (N);
4079
 
4080
      Typ  : constant Entity_Id := Etype (N);
4081
      Ctyp : constant Entity_Id := Component_Type (Typ);
4082
      --  Typ is the correct constrained array subtype of the aggregate
4083
      --  Ctyp is the corresponding component type.
4084
 
4085
      Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
4086
      --  Number of aggregate index dimensions
4087
 
4088
      Aggr_Low  : array (1 .. Aggr_Dimension) of Node_Id;
4089
      Aggr_High : array (1 .. Aggr_Dimension) of Node_Id;
4090
      --  Low and High bounds of the constraint for each aggregate index
4091
 
4092
      Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
4093
      --  The type of each index
4094
 
4095
      Maybe_In_Place_OK : Boolean;
4096
      --  If the type is neither controlled nor packed and the aggregate
4097
      --  is the expression in an assignment, assignment in place may be
4098
      --  possible, provided other conditions are met on the LHS.
4099
 
4100
      Others_Present : array (1 .. Aggr_Dimension) of Boolean :=
4101
                         (others => False);
4102
      --  If Others_Present (J) is True, then there is an others choice
4103
      --  in one of the sub-aggregates of N at dimension J.
4104
 
4105
      procedure Build_Constrained_Type (Positional : Boolean);
4106
      --  If the subtype is not static or unconstrained, build a constrained
4107
      --  type using the computable sizes of the aggregate and its sub-
4108
      --  aggregates.
4109
 
4110
      procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id);
4111
      --  Checks that the bounds of Aggr_Bounds are within the bounds defined
4112
      --  by Index_Bounds.
4113
 
4114
      procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos);
4115
      --  Checks that in a multi-dimensional array aggregate all subaggregates
4116
      --  corresponding to the same dimension have the same bounds.
4117
      --  Sub_Aggr is an array sub-aggregate. Dim is the dimension
4118
      --  corresponding to the sub-aggregate.
4119
 
4120
      procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos);
4121
      --  Computes the values of array Others_Present. Sub_Aggr is the
4122
      --  array sub-aggregate we start the computation from. Dim is the
4123
      --  dimension corresponding to the sub-aggregate.
4124
 
4125
      function Has_Address_Clause (D : Node_Id) return Boolean;
4126
      --  If the aggregate is the expression in an object declaration, it
4127
      --  cannot be expanded in place. This function does a lookahead in the
4128
      --  current declarative part to find an address clause for the object
4129
      --  being declared.
4130
 
4131
      function In_Place_Assign_OK return Boolean;
4132
      --  Simple predicate to determine whether an aggregate assignment can
4133
      --  be done in place, because none of the new values can depend on the
4134
      --  components of the target of the assignment.
4135
 
4136
      procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
4137
      --  Checks that if an others choice is present in any sub-aggregate no
4138
      --  aggregate index is outside the bounds of the index constraint.
4139
      --  Sub_Aggr is an array sub-aggregate. Dim is the dimension
4140
      --  corresponding to the sub-aggregate.
4141
 
4142
      ----------------------------
4143
      -- Build_Constrained_Type --
4144
      ----------------------------
4145
 
4146
      procedure Build_Constrained_Type (Positional : Boolean) is
4147
         Loc      : constant Source_Ptr := Sloc (N);
4148
         Agg_Type : Entity_Id;
4149
         Comp     : Node_Id;
4150
         Decl     : Node_Id;
4151
         Typ      : constant Entity_Id := Etype (N);
4152
         Indices  : constant List_Id   := New_List;
4153
         Num      : Int;
4154
         Sub_Agg  : Node_Id;
4155
 
4156
      begin
4157
         Agg_Type :=
4158
           Make_Defining_Identifier (
4159
             Loc, New_Internal_Name ('A'));
4160
 
4161
         --  If the aggregate is purely positional, all its subaggregates
4162
         --  have the same size. We collect the dimensions from the first
4163
         --  subaggregate at each level.
4164
 
4165
         if Positional then
4166
            Sub_Agg := N;
4167
 
4168
            for D in 1 .. Number_Dimensions (Typ) loop
4169
               Sub_Agg := First (Expressions (Sub_Agg));
4170
 
4171
               Comp := Sub_Agg;
4172
               Num := 0;
4173
               while Present (Comp) loop
4174
                  Num := Num + 1;
4175
                  Next (Comp);
4176
               end loop;
4177
 
4178
               Append (
4179
                 Make_Range (Loc,
4180
                   Low_Bound => Make_Integer_Literal (Loc, 1),
4181
                   High_Bound =>
4182
                          Make_Integer_Literal (Loc, Num)),
4183
                 Indices);
4184
            end loop;
4185
 
4186
         else
4187
            --  We know the aggregate type is unconstrained and the aggregate
4188
            --  is not processable by the back end, therefore not necessarily
4189
            --  positional. Retrieve each dimension bounds (computed earlier).
4190
            --  earlier.
4191
 
4192
            for D in 1 .. Number_Dimensions (Typ) loop
4193
               Append (
4194
                 Make_Range (Loc,
4195
                    Low_Bound  => Aggr_Low  (D),
4196
                    High_Bound => Aggr_High (D)),
4197
                 Indices);
4198
            end loop;
4199
         end if;
4200
 
4201
         Decl :=
4202
           Make_Full_Type_Declaration (Loc,
4203
               Defining_Identifier => Agg_Type,
4204
               Type_Definition =>
4205
                 Make_Constrained_Array_Definition (Loc,
4206
                   Discrete_Subtype_Definitions => Indices,
4207
                   Component_Definition =>
4208
                     Make_Component_Definition (Loc,
4209
                       Aliased_Present => False,
4210
                       Subtype_Indication =>
4211
                         New_Occurrence_Of (Component_Type (Typ), Loc))));
4212
 
4213
         Insert_Action (N, Decl);
4214
         Analyze (Decl);
4215
         Set_Etype (N, Agg_Type);
4216
         Set_Is_Itype (Agg_Type);
4217
         Freeze_Itype (Agg_Type, N);
4218
      end Build_Constrained_Type;
4219
 
4220
      ------------------
4221
      -- Check_Bounds --
4222
      ------------------
4223
 
4224
      procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is
4225
         Aggr_Lo : Node_Id;
4226
         Aggr_Hi : Node_Id;
4227
 
4228
         Ind_Lo  : Node_Id;
4229
         Ind_Hi  : Node_Id;
4230
 
4231
         Cond    : Node_Id := Empty;
4232
 
4233
      begin
4234
         Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi);
4235
         Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi);
4236
 
4237
         --  Generate the following test:
4238
         --
4239
         --    [constraint_error when
4240
         --      Aggr_Lo <= Aggr_Hi and then
4241
         --        (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
4242
 
4243
         --  As an optimization try to see if some tests are trivially vacuous
4244
         --  because we are comparing an expression against itself.
4245
 
4246
         if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then
4247
            Cond := Empty;
4248
 
4249
         elsif Aggr_Hi = Ind_Hi then
4250
            Cond :=
4251
              Make_Op_Lt (Loc,
4252
                Left_Opnd  => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
4253
                Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo));
4254
 
4255
         elsif Aggr_Lo = Ind_Lo then
4256
            Cond :=
4257
              Make_Op_Gt (Loc,
4258
                Left_Opnd  => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
4259
                Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Hi));
4260
 
4261
         else
4262
            Cond :=
4263
              Make_Or_Else (Loc,
4264
                Left_Opnd =>
4265
                  Make_Op_Lt (Loc,
4266
                    Left_Opnd  => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
4267
                    Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)),
4268
 
4269
                Right_Opnd =>
4270
                  Make_Op_Gt (Loc,
4271
                    Left_Opnd  => Duplicate_Subexpr (Aggr_Hi),
4272
                    Right_Opnd => Duplicate_Subexpr (Ind_Hi)));
4273
         end if;
4274
 
4275
         if Present (Cond) then
4276
            Cond :=
4277
              Make_And_Then (Loc,
4278
                Left_Opnd =>
4279
                  Make_Op_Le (Loc,
4280
                    Left_Opnd  => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
4281
                    Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)),
4282
 
4283
                Right_Opnd => Cond);
4284
 
4285
            Set_Analyzed (Left_Opnd  (Left_Opnd (Cond)), False);
4286
            Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False);
4287
            Insert_Action (N,
4288
              Make_Raise_Constraint_Error (Loc,
4289
                Condition => Cond,
4290
                Reason    => CE_Length_Check_Failed));
4291
         end if;
4292
      end Check_Bounds;
4293
 
4294
      ----------------------------
4295
      -- Check_Same_Aggr_Bounds --
4296
      ----------------------------
4297
 
4298
      procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
4299
         Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr));
4300
         Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr));
4301
         --  The bounds of this specific sub-aggregate
4302
 
4303
         Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
4304
         Aggr_Hi : constant Node_Id := Aggr_High (Dim);
4305
         --  The bounds of the aggregate for this dimension
4306
 
4307
         Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
4308
         --  The index type for this dimension.xxx
4309
 
4310
         Cond  : Node_Id := Empty;
4311
         Assoc : Node_Id;
4312
         Expr  : Node_Id;
4313
 
4314
      begin
4315
         --  If index checks are on generate the test
4316
 
4317
         --    [constraint_error when
4318
         --      Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
4319
 
4320
         --  As an optimization try to see if some tests are trivially vacuos
4321
         --  because we are comparing an expression against itself. Also for
4322
         --  the first dimension the test is trivially vacuous because there
4323
         --  is just one aggregate for dimension 1.
4324
 
4325
         if Index_Checks_Suppressed (Ind_Typ) then
4326
            Cond := Empty;
4327
 
4328
         elsif Dim = 1
4329
           or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi)
4330
         then
4331
            Cond := Empty;
4332
 
4333
         elsif Aggr_Hi = Sub_Hi then
4334
            Cond :=
4335
              Make_Op_Ne (Loc,
4336
                Left_Opnd  => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
4337
                Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo));
4338
 
4339
         elsif Aggr_Lo = Sub_Lo then
4340
            Cond :=
4341
              Make_Op_Ne (Loc,
4342
                Left_Opnd  => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
4343
                Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi));
4344
 
4345
         else
4346
            Cond :=
4347
              Make_Or_Else (Loc,
4348
                Left_Opnd =>
4349
                  Make_Op_Ne (Loc,
4350
                    Left_Opnd  => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
4351
                    Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)),
4352
 
4353
                Right_Opnd =>
4354
                  Make_Op_Ne (Loc,
4355
                    Left_Opnd  => Duplicate_Subexpr (Aggr_Hi),
4356
                    Right_Opnd => Duplicate_Subexpr (Sub_Hi)));
4357
         end if;
4358
 
4359
         if Present (Cond) then
4360
            Insert_Action (N,
4361
              Make_Raise_Constraint_Error (Loc,
4362
                Condition => Cond,
4363
                Reason    => CE_Length_Check_Failed));
4364
         end if;
4365
 
4366
         --  Now look inside the sub-aggregate to see if there is more work
4367
 
4368
         if Dim < Aggr_Dimension then
4369
 
4370
            --  Process positional components
4371
 
4372
            if Present (Expressions (Sub_Aggr)) then
4373
               Expr := First (Expressions (Sub_Aggr));
4374
               while Present (Expr) loop
4375
                  Check_Same_Aggr_Bounds (Expr, Dim + 1);
4376
                  Next (Expr);
4377
               end loop;
4378
            end if;
4379
 
4380
            --  Process component associations
4381
 
4382
            if Present (Component_Associations (Sub_Aggr)) then
4383
               Assoc := First (Component_Associations (Sub_Aggr));
4384
               while Present (Assoc) loop
4385
                  Expr := Expression (Assoc);
4386
                  Check_Same_Aggr_Bounds (Expr, Dim + 1);
4387
                  Next (Assoc);
4388
               end loop;
4389
            end if;
4390
         end if;
4391
      end Check_Same_Aggr_Bounds;
4392
 
4393
      ----------------------------
4394
      -- Compute_Others_Present --
4395
      ----------------------------
4396
 
4397
      procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is
4398
         Assoc : Node_Id;
4399
         Expr  : Node_Id;
4400
 
4401
      begin
4402
         if Present (Component_Associations (Sub_Aggr)) then
4403
            Assoc := Last (Component_Associations (Sub_Aggr));
4404
 
4405
            if Nkind (First (Choices (Assoc))) = N_Others_Choice then
4406
               Others_Present (Dim) := True;
4407
            end if;
4408
         end if;
4409
 
4410
         --  Now look inside the sub-aggregate to see if there is more work
4411
 
4412
         if Dim < Aggr_Dimension then
4413
 
4414
            --  Process positional components
4415
 
4416
            if Present (Expressions (Sub_Aggr)) then
4417
               Expr := First (Expressions (Sub_Aggr));
4418
               while Present (Expr) loop
4419
                  Compute_Others_Present (Expr, Dim + 1);
4420
                  Next (Expr);
4421
               end loop;
4422
            end if;
4423
 
4424
            --  Process component associations
4425
 
4426
            if Present (Component_Associations (Sub_Aggr)) then
4427
               Assoc := First (Component_Associations (Sub_Aggr));
4428
               while Present (Assoc) loop
4429
                  Expr := Expression (Assoc);
4430
                  Compute_Others_Present (Expr, Dim + 1);
4431
                  Next (Assoc);
4432
               end loop;
4433
            end if;
4434
         end if;
4435
      end Compute_Others_Present;
4436
 
4437
      ------------------------
4438
      -- Has_Address_Clause --
4439
      ------------------------
4440
 
4441
      function Has_Address_Clause (D : Node_Id) return Boolean is
4442
         Id   : constant Entity_Id := Defining_Identifier (D);
4443
         Decl : Node_Id;
4444
 
4445
      begin
4446
         Decl := Next (D);
4447
         while Present (Decl) loop
4448
            if Nkind (Decl) = N_At_Clause
4449
               and then Chars (Identifier (Decl)) = Chars (Id)
4450
            then
4451
               return True;
4452
 
4453
            elsif Nkind (Decl) = N_Attribute_Definition_Clause
4454
               and then Chars (Decl) = Name_Address
4455
               and then Chars (Name (Decl)) = Chars (Id)
4456
            then
4457
               return True;
4458
            end if;
4459
 
4460
            Next (Decl);
4461
         end loop;
4462
 
4463
         return False;
4464
      end Has_Address_Clause;
4465
 
4466
      ------------------------
4467
      -- In_Place_Assign_OK --
4468
      ------------------------
4469
 
4470
      function In_Place_Assign_OK return Boolean is
4471
         Aggr_In : Node_Id;
4472
         Aggr_Lo : Node_Id;
4473
         Aggr_Hi : Node_Id;
4474
         Obj_In  : Node_Id;
4475
         Obj_Lo  : Node_Id;
4476
         Obj_Hi  : Node_Id;
4477
 
4478
         function Is_Others_Aggregate (Aggr : Node_Id) return Boolean;
4479
         --  Aggregates that consist of a single Others choice are safe
4480
         --  if the single expression is.
4481
 
4482
         function Safe_Aggregate (Aggr : Node_Id) return Boolean;
4483
         --  Check recursively that each component of a (sub)aggregate does
4484
         --  not depend on the variable being assigned to.
4485
 
4486
         function Safe_Component (Expr : Node_Id) return Boolean;
4487
         --  Verify that an expression cannot depend on the variable being
4488
         --  assigned to. Room for improvement here (but less than before).
4489
 
4490
         -------------------------
4491
         -- Is_Others_Aggregate --
4492
         -------------------------
4493
 
4494
         function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is
4495
         begin
4496
            return No (Expressions (Aggr))
4497
              and then Nkind
4498
                (First (Choices (First (Component_Associations (Aggr)))))
4499
                  = N_Others_Choice;
4500
         end Is_Others_Aggregate;
4501
 
4502
         --------------------
4503
         -- Safe_Aggregate --
4504
         --------------------
4505
 
4506
         function Safe_Aggregate (Aggr : Node_Id) return Boolean is
4507
            Expr : Node_Id;
4508
 
4509
         begin
4510
            if Present (Expressions (Aggr)) then
4511
               Expr := First (Expressions (Aggr));
4512
               while Present (Expr) loop
4513
                  if Nkind (Expr) = N_Aggregate then
4514
                     if not Safe_Aggregate (Expr) then
4515
                        return False;
4516
                     end if;
4517
 
4518
                  elsif not Safe_Component (Expr) then
4519
                     return False;
4520
                  end if;
4521
 
4522
                  Next (Expr);
4523
               end loop;
4524
            end if;
4525
 
4526
            if Present (Component_Associations (Aggr)) then
4527
               Expr := First (Component_Associations (Aggr));
4528
               while Present (Expr) loop
4529
                  if Nkind (Expression (Expr)) = N_Aggregate then
4530
                     if not Safe_Aggregate (Expression (Expr)) then
4531
                        return False;
4532
                     end if;
4533
 
4534
                  elsif not Safe_Component (Expression (Expr)) then
4535
                     return False;
4536
                  end if;
4537
 
4538
                  Next (Expr);
4539
               end loop;
4540
            end if;
4541
 
4542
            return True;
4543
         end Safe_Aggregate;
4544
 
4545
         --------------------
4546
         -- Safe_Component --
4547
         --------------------
4548
 
4549
         function Safe_Component (Expr : Node_Id) return Boolean is
4550
            Comp : Node_Id := Expr;
4551
 
4552
            function Check_Component (Comp : Node_Id) return Boolean;
4553
            --  Do the recursive traversal, after copy
4554
 
4555
            ---------------------
4556
            -- Check_Component --
4557
            ---------------------
4558
 
4559
            function Check_Component (Comp : Node_Id) return Boolean is
4560
            begin
4561
               if Is_Overloaded (Comp) then
4562
                  return False;
4563
               end if;
4564
 
4565
               return Compile_Time_Known_Value (Comp)
4566
 
4567
                 or else (Is_Entity_Name (Comp)
4568
                           and then  Present (Entity (Comp))
4569
                           and then No (Renamed_Object (Entity (Comp))))
4570
 
4571
                 or else (Nkind (Comp) = N_Attribute_Reference
4572
                           and then Check_Component (Prefix (Comp)))
4573
 
4574
                 or else (Nkind (Comp) in N_Binary_Op
4575
                           and then Check_Component (Left_Opnd  (Comp))
4576
                           and then Check_Component (Right_Opnd (Comp)))
4577
 
4578
                 or else (Nkind (Comp) in N_Unary_Op
4579
                           and then Check_Component (Right_Opnd (Comp)))
4580
 
4581
                 or else (Nkind (Comp) = N_Selected_Component
4582
                           and then Check_Component (Prefix (Comp)))
4583
 
4584
                 or else (Nkind (Comp) = N_Unchecked_Type_Conversion
4585
                           and then Check_Component (Expression (Comp)));
4586
            end Check_Component;
4587
 
4588
         --  Start of processing for Safe_Component
4589
 
4590
         begin
4591
            --  If the component appears in an association that may
4592
            --  correspond to more than one element, it is not analyzed
4593
            --  before the expansion into assignments, to avoid side effects.
4594
            --  We analyze, but do not resolve the copy, to obtain sufficient
4595
            --  entity information for the checks that follow. If component is
4596
            --  overloaded we assume an unsafe function call.
4597
 
4598
            if not Analyzed (Comp) then
4599
               if Is_Overloaded (Expr) then
4600
                  return False;
4601
 
4602
               elsif Nkind (Expr) = N_Aggregate
4603
                  and then not Is_Others_Aggregate (Expr)
4604
               then
4605
                  return False;
4606
 
4607
               elsif Nkind (Expr) = N_Allocator then
4608
 
4609
                  --  For now, too complex to analyze
4610
 
4611
                  return False;
4612
               end if;
4613
 
4614
               Comp := New_Copy_Tree (Expr);
4615
               Set_Parent (Comp, Parent (Expr));
4616
               Analyze (Comp);
4617
            end if;
4618
 
4619
            if Nkind (Comp) = N_Aggregate then
4620
               return Safe_Aggregate (Comp);
4621
            else
4622
               return Check_Component (Comp);
4623
            end if;
4624
         end Safe_Component;
4625
 
4626
      --  Start of processing for In_Place_Assign_OK
4627
 
4628
      begin
4629
         if Present (Component_Associations (N)) then
4630
 
4631
            --  On assignment, sliding can take place, so we cannot do the
4632
            --  assignment in place unless the bounds of the aggregate are
4633
            --  statically equal to those of the target.
4634
 
4635
            --  If the aggregate is given by an others choice, the bounds
4636
            --  are derived from the left-hand side, and the assignment is
4637
            --  safe if the expression is.
4638
 
4639
            if Is_Others_Aggregate (N) then
4640
               return
4641
                 Safe_Component
4642
                  (Expression (First (Component_Associations (N))));
4643
            end if;
4644
 
4645
            Aggr_In := First_Index (Etype (N));
4646
 
4647
            if Nkind (Parent (N)) = N_Assignment_Statement then
4648
               Obj_In  := First_Index (Etype (Name (Parent (N))));
4649
 
4650
            else
4651
               --  Context is an allocator. Check bounds of aggregate
4652
               --  against given type in qualified expression.
4653
 
4654
               pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator);
4655
               Obj_In :=
4656
                 First_Index (Etype (Entity (Subtype_Mark (Parent (N)))));
4657
            end if;
4658
 
4659
            while Present (Aggr_In) loop
4660
               Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
4661
               Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
4662
 
4663
               if not Compile_Time_Known_Value (Aggr_Lo)
4664
                 or else not Compile_Time_Known_Value (Aggr_Hi)
4665
                 or else not Compile_Time_Known_Value (Obj_Lo)
4666
                 or else not Compile_Time_Known_Value (Obj_Hi)
4667
                 or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
4668
                 or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
4669
               then
4670
                  return False;
4671
               end if;
4672
 
4673
               Next_Index (Aggr_In);
4674
               Next_Index (Obj_In);
4675
            end loop;
4676
         end if;
4677
 
4678
         --  Now check the component values themselves
4679
 
4680
         return Safe_Aggregate (N);
4681
      end In_Place_Assign_OK;
4682
 
4683
      ------------------
4684
      -- Others_Check --
4685
      ------------------
4686
 
4687
      procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is
4688
         Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
4689
         Aggr_Hi : constant Node_Id := Aggr_High (Dim);
4690
         --  The bounds of the aggregate for this dimension
4691
 
4692
         Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
4693
         --  The index type for this dimension
4694
 
4695
         Need_To_Check : Boolean := False;
4696
 
4697
         Choices_Lo : Node_Id := Empty;
4698
         Choices_Hi : Node_Id := Empty;
4699
         --  The lowest and highest discrete choices for a named sub-aggregate
4700
 
4701
         Nb_Choices : Int := -1;
4702
         --  The number of discrete non-others choices in this sub-aggregate
4703
 
4704
         Nb_Elements : Uint := Uint_0;
4705
         --  The number of elements in a positional aggregate
4706
 
4707
         Cond : Node_Id := Empty;
4708
 
4709
         Assoc  : Node_Id;
4710
         Choice : Node_Id;
4711
         Expr   : Node_Id;
4712
 
4713
      begin
4714
         --  Check if we have an others choice. If we do make sure that this
4715
         --  sub-aggregate contains at least one element in addition to the
4716
         --  others choice.
4717
 
4718
         if Range_Checks_Suppressed (Ind_Typ) then
4719
            Need_To_Check := False;
4720
 
4721
         elsif Present (Expressions (Sub_Aggr))
4722
           and then Present (Component_Associations (Sub_Aggr))
4723
         then
4724
            Need_To_Check := True;
4725
 
4726
         elsif Present (Component_Associations (Sub_Aggr)) then
4727
            Assoc := Last (Component_Associations (Sub_Aggr));
4728
 
4729
            if Nkind (First (Choices (Assoc))) /= N_Others_Choice then
4730
               Need_To_Check := False;
4731
 
4732
            else
4733
               --  Count the number of discrete choices. Start with -1 because
4734
               --  the others choice does not count.
4735
 
4736
               Nb_Choices := -1;
4737
               Assoc := First (Component_Associations (Sub_Aggr));
4738
               while Present (Assoc) loop
4739
                  Choice := First (Choices (Assoc));
4740
                  while Present (Choice) loop
4741
                     Nb_Choices := Nb_Choices + 1;
4742
                     Next (Choice);
4743
                  end loop;
4744
 
4745
                  Next (Assoc);
4746
               end loop;
4747
 
4748
               --  If there is only an others choice nothing to do
4749
 
4750
               Need_To_Check := (Nb_Choices > 0);
4751
            end if;
4752
 
4753
         else
4754
            Need_To_Check := False;
4755
         end if;
4756
 
4757
         --  If we are dealing with a positional sub-aggregate with an others
4758
         --  choice then compute the number or positional elements.
4759
 
4760
         if Need_To_Check and then Present (Expressions (Sub_Aggr)) then
4761
            Expr := First (Expressions (Sub_Aggr));
4762
            Nb_Elements := Uint_0;
4763
            while Present (Expr) loop
4764
               Nb_Elements := Nb_Elements + 1;
4765
               Next (Expr);
4766
            end loop;
4767
 
4768
         --  If the aggregate contains discrete choices and an others choice
4769
         --  compute the smallest and largest discrete choice values.
4770
 
4771
         elsif Need_To_Check then
4772
            Compute_Choices_Lo_And_Choices_Hi : declare
4773
 
4774
               Table : Case_Table_Type (1 .. Nb_Choices);
4775
               --  Used to sort all the different choice values
4776
 
4777
               J    : Pos := 1;
4778
               Low  : Node_Id;
4779
               High : Node_Id;
4780
 
4781
            begin
4782
               Assoc := First (Component_Associations (Sub_Aggr));
4783
               while Present (Assoc) loop
4784
                  Choice := First (Choices (Assoc));
4785
                  while Present (Choice) loop
4786
                     if Nkind (Choice) = N_Others_Choice then
4787
                        exit;
4788
                     end if;
4789
 
4790
                     Get_Index_Bounds (Choice, Low, High);
4791
                     Table (J).Choice_Lo := Low;
4792
                     Table (J).Choice_Hi := High;
4793
 
4794
                     J := J + 1;
4795
                     Next (Choice);
4796
                  end loop;
4797
 
4798
                  Next (Assoc);
4799
               end loop;
4800
 
4801
               --  Sort the discrete choices
4802
 
4803
               Sort_Case_Table (Table);
4804
 
4805
               Choices_Lo := Table (1).Choice_Lo;
4806
               Choices_Hi := Table (Nb_Choices).Choice_Hi;
4807
            end Compute_Choices_Lo_And_Choices_Hi;
4808
         end if;
4809
 
4810
         --  If no others choice in this sub-aggregate, or the aggregate
4811
         --  comprises only an others choice, nothing to do.
4812
 
4813
         if not Need_To_Check then
4814
            Cond := Empty;
4815
 
4816
         --  If we are dealing with an aggregate containing an others choice
4817
         --  and positional components, we generate the following test:
4818
 
4819
         --    if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
4820
         --            Ind_Typ'Pos (Aggr_Hi)
4821
         --    then
4822
         --       raise Constraint_Error;
4823
         --    end if;
4824
 
4825
         elsif Nb_Elements > Uint_0 then
4826
            Cond :=
4827
              Make_Op_Gt (Loc,
4828
                Left_Opnd  =>
4829
                  Make_Op_Add (Loc,
4830
                    Left_Opnd  =>
4831
                      Make_Attribute_Reference (Loc,
4832
                        Prefix         => New_Reference_To (Ind_Typ, Loc),
4833
                        Attribute_Name => Name_Pos,
4834
                        Expressions    =>
4835
                          New_List
4836
                            (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
4837
                    Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
4838
 
4839
                Right_Opnd =>
4840
                  Make_Attribute_Reference (Loc,
4841
                    Prefix         => New_Reference_To (Ind_Typ, Loc),
4842
                    Attribute_Name => Name_Pos,
4843
                    Expressions    => New_List (
4844
                      Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
4845
 
4846
         --  If we are dealing with an aggregate containing an others choice
4847
         --  and discrete choices we generate the following test:
4848
 
4849
         --    [constraint_error when
4850
         --      Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
4851
 
4852
         else
4853
            Cond :=
4854
              Make_Or_Else (Loc,
4855
                Left_Opnd =>
4856
                  Make_Op_Lt (Loc,
4857
                    Left_Opnd  =>
4858
                      Duplicate_Subexpr_Move_Checks (Choices_Lo),
4859
                    Right_Opnd =>
4860
                      Duplicate_Subexpr_Move_Checks (Aggr_Lo)),
4861
 
4862
                Right_Opnd =>
4863
                  Make_Op_Gt (Loc,
4864
                    Left_Opnd  =>
4865
                      Duplicate_Subexpr (Choices_Hi),
4866
                    Right_Opnd =>
4867
                      Duplicate_Subexpr (Aggr_Hi)));
4868
         end if;
4869
 
4870
         if Present (Cond) then
4871
            Insert_Action (N,
4872
              Make_Raise_Constraint_Error (Loc,
4873
                Condition => Cond,
4874
                Reason    => CE_Length_Check_Failed));
4875
            --  Questionable reason code, shouldn't that be a
4876
            --  CE_Range_Check_Failed ???
4877
         end if;
4878
 
4879
         --  Now look inside the sub-aggregate to see if there is more work
4880
 
4881
         if Dim < Aggr_Dimension then
4882
 
4883
            --  Process positional components
4884
 
4885
            if Present (Expressions (Sub_Aggr)) then
4886
               Expr := First (Expressions (Sub_Aggr));
4887
               while Present (Expr) loop
4888
                  Others_Check (Expr, Dim + 1);
4889
                  Next (Expr);
4890
               end loop;
4891
            end if;
4892
 
4893
            --  Process component associations
4894
 
4895
            if Present (Component_Associations (Sub_Aggr)) then
4896
               Assoc := First (Component_Associations (Sub_Aggr));
4897
               while Present (Assoc) loop
4898
                  Expr := Expression (Assoc);
4899
                  Others_Check (Expr, Dim + 1);
4900
                  Next (Assoc);
4901
               end loop;
4902
            end if;
4903
         end if;
4904
      end Others_Check;
4905
 
4906
      --  Remaining Expand_Array_Aggregate variables
4907
 
4908
      Tmp : Entity_Id;
4909
      --  Holds the temporary aggregate value
4910
 
4911
      Tmp_Decl : Node_Id;
4912
      --  Holds the declaration of Tmp
4913
 
4914
      Aggr_Code   : List_Id;
4915
      Parent_Node : Node_Id;
4916
      Parent_Kind : Node_Kind;
4917
 
4918
   --  Start of processing for Expand_Array_Aggregate
4919
 
4920
   begin
4921
      --  Do not touch the special aggregates of attributes used for Asm calls
4922
 
4923
      if Is_RTE (Ctyp, RE_Asm_Input_Operand)
4924
        or else Is_RTE (Ctyp, RE_Asm_Output_Operand)
4925
      then
4926
         return;
4927
      end if;
4928
 
4929
      --  If the semantic analyzer has determined that aggregate N will raise
4930
      --  Constraint_Error at run-time, then the aggregate node has been
4931
      --  replaced with an N_Raise_Constraint_Error node and we should
4932
      --  never get here.
4933
 
4934
      pragma Assert (not Raises_Constraint_Error (N));
4935
 
4936
      --  STEP 1a
4937
 
4938
      --  Check that the index range defined by aggregate bounds is
4939
      --  compatible with corresponding index subtype.
4940
 
4941
      Index_Compatibility_Check : declare
4942
         Aggr_Index_Range : Node_Id := First_Index (Typ);
4943
         --  The current aggregate index range
4944
 
4945
         Index_Constraint : Node_Id := First_Index (Etype (Typ));
4946
         --  The corresponding index constraint against which we have to
4947
         --  check the above aggregate index range.
4948
 
4949
      begin
4950
         Compute_Others_Present (N, 1);
4951
 
4952
         for J in 1 .. Aggr_Dimension loop
4953
            --  There is no need to emit a check if an others choice is
4954
            --  present for this array aggregate dimension since in this
4955
            --  case one of N's sub-aggregates has taken its bounds from the
4956
            --  context and these bounds must have been checked already. In
4957
            --  addition all sub-aggregates corresponding to the same
4958
            --  dimension must all have the same bounds (checked in (c) below).
4959
 
4960
            if not Range_Checks_Suppressed (Etype (Index_Constraint))
4961
              and then not Others_Present (J)
4962
            then
4963
               --  We don't use Checks.Apply_Range_Check here because it emits
4964
               --  a spurious check. Namely it checks that the range defined by
4965
               --  the aggregate bounds is non empty. But we know this already
4966
               --  if we get here.
4967
 
4968
               Check_Bounds (Aggr_Index_Range, Index_Constraint);
4969
            end if;
4970
 
4971
            --  Save the low and high bounds of the aggregate index as well as
4972
            --  the index type for later use in checks (b) and (c) below.
4973
 
4974
            Aggr_Low  (J) := Low_Bound (Aggr_Index_Range);
4975
            Aggr_High (J) := High_Bound (Aggr_Index_Range);
4976
 
4977
            Aggr_Index_Typ (J) := Etype (Index_Constraint);
4978
 
4979
            Next_Index (Aggr_Index_Range);
4980
            Next_Index (Index_Constraint);
4981
         end loop;
4982
      end Index_Compatibility_Check;
4983
 
4984
      --  STEP 1b
4985
 
4986
      --  If an others choice is present check that no aggregate index is
4987
      --  outside the bounds of the index constraint.
4988
 
4989
      Others_Check (N, 1);
4990
 
4991
      --  STEP 1c
4992
 
4993
      --  For multidimensional arrays make sure that all subaggregates
4994
      --  corresponding to the same dimension have the same bounds.
4995
 
4996
      if Aggr_Dimension > 1 then
4997
         Check_Same_Aggr_Bounds (N, 1);
4998
      end if;
4999
 
5000
      --  STEP 2
5001
 
5002
      --  Here we test for is packed array aggregate that we can handle at
5003
      --  compile time. If so, return with transformation done. Note that we do
5004
      --  this even if the aggregate is nested, because once we have done this
5005
      --  processing, there is no more nested aggregate!
5006
 
5007
      if Packed_Array_Aggregate_Handled (N) then
5008
         return;
5009
      end if;
5010
 
5011
      --  At this point we try to convert to positional form
5012
 
5013
      if Ekind (Current_Scope) = E_Package
5014
        and then Static_Elaboration_Desired (Current_Scope)
5015
      then
5016
         Convert_To_Positional (N, Max_Others_Replicate => 100);
5017
 
5018
      else
5019
         Convert_To_Positional (N);
5020
      end if;
5021
 
5022
      --  if the result is no longer an aggregate (e.g. it may be a string
5023
      --  literal, or a temporary which has the needed value), then we are
5024
      --  done, since there is no longer a nested aggregate.
5025
 
5026
      if Nkind (N) /= N_Aggregate then
5027
         return;
5028
 
5029
      --  We are also done if the result is an analyzed aggregate
5030
      --  This case could use more comments ???
5031
 
5032
      elsif Analyzed (N)
5033
        and then N /= Original_Node (N)
5034
      then
5035
         return;
5036
      end if;
5037
 
5038
      --  If all aggregate components are compile-time known and the aggregate
5039
      --  has been flattened, nothing left to do. The same occurs if the
5040
      --  aggregate is used to initialize the components of an statically
5041
      --  allocated dispatch table.
5042
 
5043
      if Compile_Time_Known_Aggregate (N)
5044
        or else Is_Static_Dispatch_Table_Aggregate (N)
5045
      then
5046
         Set_Expansion_Delayed (N, False);
5047
         return;
5048
      end if;
5049
 
5050
      --  Now see if back end processing is possible
5051
 
5052
      if Backend_Processing_Possible (N) then
5053
 
5054
         --  If the aggregate is static but the constraints are not, build
5055
         --  a static subtype for the aggregate, so that Gigi can place it
5056
         --  in static memory. Perform an unchecked_conversion to the non-
5057
         --  static type imposed by the context.
5058
 
5059
         declare
5060
            Itype      : constant Entity_Id := Etype (N);
5061
            Index      : Node_Id;
5062
            Needs_Type : Boolean := False;
5063
 
5064
         begin
5065
            Index := First_Index (Itype);
5066
            while Present (Index) loop
5067
               if not Is_Static_Subtype (Etype (Index)) then
5068
                  Needs_Type := True;
5069
                  exit;
5070
               else
5071
                  Next_Index (Index);
5072
               end if;
5073
            end loop;
5074
 
5075
            if Needs_Type then
5076
               Build_Constrained_Type (Positional => True);
5077
               Rewrite (N, Unchecked_Convert_To (Itype, N));
5078
               Analyze (N);
5079
            end if;
5080
         end;
5081
 
5082
         return;
5083
      end if;
5084
 
5085
      --  STEP 3
5086
 
5087
      --  Delay expansion for nested aggregates: it will be taken care of
5088
      --  when the parent aggregate is expanded.
5089
 
5090
      Parent_Node := Parent (N);
5091
      Parent_Kind := Nkind (Parent_Node);
5092
 
5093
      if Parent_Kind = N_Qualified_Expression then
5094
         Parent_Node := Parent (Parent_Node);
5095
         Parent_Kind := Nkind (Parent_Node);
5096
      end if;
5097
 
5098
      if Parent_Kind = N_Aggregate
5099
        or else Parent_Kind = N_Extension_Aggregate
5100
        or else Parent_Kind = N_Component_Association
5101
        or else (Parent_Kind = N_Object_Declaration
5102
                  and then Needs_Finalization (Typ))
5103
        or else (Parent_Kind = N_Assignment_Statement
5104
                  and then Inside_Init_Proc)
5105
      then
5106
         if Static_Array_Aggregate (N)
5107
           or else Compile_Time_Known_Aggregate (N)
5108
         then
5109
            Set_Expansion_Delayed (N, False);
5110
            return;
5111
         else
5112
            Set_Expansion_Delayed (N);
5113
            return;
5114
         end if;
5115
      end if;
5116
 
5117
      --  STEP 4
5118
 
5119
      --  Look if in place aggregate expansion is possible
5120
 
5121
      --  For object declarations we build the aggregate in place, unless
5122
      --  the array is bit-packed or the component is controlled.
5123
 
5124
      --  For assignments we do the assignment in place if all the component
5125
      --  associations have compile-time known values. For other cases we
5126
      --  create a temporary. The analysis for safety of on-line assignment
5127
      --  is delicate, i.e. we don't know how to do it fully yet ???
5128
 
5129
      --  For allocators we assign to the designated object in place if the
5130
      --  aggregate meets the same conditions as other in-place assignments.
5131
      --  In this case the aggregate may not come from source but was created
5132
      --  for default initialization, e.g. with Initialize_Scalars.
5133
 
5134
      if Requires_Transient_Scope (Typ) then
5135
         Establish_Transient_Scope
5136
           (N, Sec_Stack => Has_Controlled_Component (Typ));
5137
      end if;
5138
 
5139
      if Has_Default_Init_Comps (N) then
5140
         Maybe_In_Place_OK := False;
5141
 
5142
      elsif Is_Bit_Packed_Array (Typ)
5143
        or else Has_Controlled_Component (Typ)
5144
      then
5145
         Maybe_In_Place_OK := False;
5146
 
5147
      else
5148
         Maybe_In_Place_OK :=
5149
          (Nkind (Parent (N)) = N_Assignment_Statement
5150
            and then Comes_From_Source (N)
5151
            and then In_Place_Assign_OK)
5152
 
5153
          or else
5154
            (Nkind (Parent (Parent (N))) = N_Allocator
5155
              and then In_Place_Assign_OK);
5156
      end if;
5157
 
5158
      --  If this is an array of tasks, it will be expanded into build-in-place
5159
      --  assignments. Build an activation chain for the tasks now.
5160
 
5161
      if Has_Task (Etype (N)) then
5162
         Build_Activation_Chain_Entity (N);
5163
      end if;
5164
 
5165
      if not Has_Default_Init_Comps (N)
5166
         and then Comes_From_Source (Parent (N))
5167
         and then Nkind (Parent (N)) = N_Object_Declaration
5168
         and then not
5169
           Must_Slide (Etype (Defining_Identifier (Parent (N))), Typ)
5170
         and then N = Expression (Parent (N))
5171
         and then not Is_Bit_Packed_Array (Typ)
5172
         and then not Has_Controlled_Component (Typ)
5173
         and then not Has_Address_Clause (Parent (N))
5174
      then
5175
         Tmp := Defining_Identifier (Parent (N));
5176
         Set_No_Initialization (Parent (N));
5177
         Set_Expression (Parent (N), Empty);
5178
 
5179
         --  Set the type of the entity, for use in the analysis of the
5180
         --  subsequent indexed assignments. If the nominal type is not
5181
         --  constrained, build a subtype from the known bounds of the
5182
         --  aggregate. If the declaration has a subtype mark, use it,
5183
         --  otherwise use the itype of the aggregate.
5184
 
5185
         if not Is_Constrained (Typ) then
5186
            Build_Constrained_Type (Positional => False);
5187
         elsif Is_Entity_Name (Object_Definition (Parent (N)))
5188
           and then Is_Constrained (Entity (Object_Definition (Parent (N))))
5189
         then
5190
            Set_Etype (Tmp, Entity (Object_Definition (Parent (N))));
5191
         else
5192
            Set_Size_Known_At_Compile_Time (Typ, False);
5193
            Set_Etype (Tmp, Typ);
5194
         end if;
5195
 
5196
      elsif Maybe_In_Place_OK
5197
        and then Nkind (Parent (N)) = N_Qualified_Expression
5198
        and then Nkind (Parent (Parent (N))) = N_Allocator
5199
      then
5200
         Set_Expansion_Delayed (N);
5201
         return;
5202
 
5203
      --  In the remaining cases the aggregate is the RHS of an assignment
5204
 
5205
      elsif Maybe_In_Place_OK
5206
        and then Is_Entity_Name (Name (Parent (N)))
5207
      then
5208
         Tmp := Entity (Name (Parent (N)));
5209
 
5210
         if Etype (Tmp) /= Etype (N) then
5211
            Apply_Length_Check (N, Etype (Tmp));
5212
 
5213
            if Nkind (N) = N_Raise_Constraint_Error then
5214
 
5215
               --  Static error, nothing further to expand
5216
 
5217
               return;
5218
            end if;
5219
         end if;
5220
 
5221
      elsif Maybe_In_Place_OK
5222
        and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
5223
        and then Is_Entity_Name (Prefix (Name (Parent (N))))
5224
      then
5225
         Tmp := Name (Parent (N));
5226
 
5227
         if Etype (Tmp) /= Etype (N) then
5228
            Apply_Length_Check (N, Etype (Tmp));
5229
         end if;
5230
 
5231
      elsif Maybe_In_Place_OK
5232
        and then Nkind (Name (Parent (N))) = N_Slice
5233
        and then Safe_Slice_Assignment (N)
5234
      then
5235
         --  Safe_Slice_Assignment rewrites assignment as a loop
5236
 
5237
         return;
5238
 
5239
      --  Step 5
5240
 
5241
      --  In place aggregate expansion is not possible
5242
 
5243
      else
5244
         Maybe_In_Place_OK := False;
5245
         Tmp := Make_Temporary (Loc, 'A', N);
5246
         Tmp_Decl :=
5247
           Make_Object_Declaration
5248
             (Loc,
5249
              Defining_Identifier => Tmp,
5250
              Object_Definition   => New_Occurrence_Of (Typ, Loc));
5251
         Set_No_Initialization (Tmp_Decl, True);
5252
 
5253
         --  If we are within a loop, the temporary will be pushed on the
5254
         --  stack at each iteration. If the aggregate is the expression for an
5255
         --  allocator, it will be immediately copied to the heap and can
5256
         --  be reclaimed at once. We create a transient scope around the
5257
         --  aggregate for this purpose.
5258
 
5259
         if Ekind (Current_Scope) = E_Loop
5260
           and then Nkind (Parent (Parent (N))) = N_Allocator
5261
         then
5262
            Establish_Transient_Scope (N, False);
5263
         end if;
5264
 
5265
         Insert_Action (N, Tmp_Decl);
5266
      end if;
5267
 
5268
      --  Construct and insert the aggregate code. We can safely suppress index
5269
      --  checks because this code is guaranteed not to raise CE on index
5270
      --  checks. However we should *not* suppress all checks.
5271
 
5272
      declare
5273
         Target : Node_Id;
5274
 
5275
      begin
5276
         if Nkind (Tmp) = N_Defining_Identifier then
5277
            Target := New_Reference_To (Tmp, Loc);
5278
 
5279
         else
5280
 
5281
            if Has_Default_Init_Comps (N) then
5282
 
5283
               --  Ada 2005 (AI-287): This case has not been analyzed???
5284
 
5285
               raise Program_Error;
5286
            end if;
5287
 
5288
            --  Name in assignment is explicit dereference
5289
 
5290
            Target := New_Copy (Tmp);
5291
         end if;
5292
 
5293
         Aggr_Code :=
5294
           Build_Array_Aggr_Code (N,
5295
             Ctype       => Ctyp,
5296
             Index       => First_Index (Typ),
5297
             Into        => Target,
5298
             Scalar_Comp => Is_Scalar_Type (Ctyp));
5299
      end;
5300
 
5301
      if Comes_From_Source (Tmp) then
5302
         Insert_Actions_After (Parent (N), Aggr_Code);
5303
 
5304
      else
5305
         Insert_Actions (N, Aggr_Code);
5306
      end if;
5307
 
5308
      --  If the aggregate has been assigned in place, remove the original
5309
      --  assignment.
5310
 
5311
      if Nkind (Parent (N)) = N_Assignment_Statement
5312
        and then Maybe_In_Place_OK
5313
      then
5314
         Rewrite (Parent (N), Make_Null_Statement (Loc));
5315
 
5316
      elsif Nkind (Parent (N)) /= N_Object_Declaration
5317
        or else Tmp /= Defining_Identifier (Parent (N))
5318
      then
5319
         Rewrite (N, New_Occurrence_Of (Tmp, Loc));
5320
         Analyze_And_Resolve (N, Typ);
5321
      end if;
5322
   end Expand_Array_Aggregate;
5323
 
5324
   ------------------------
5325
   -- Expand_N_Aggregate --
5326
   ------------------------
5327
 
5328
   procedure Expand_N_Aggregate (N : Node_Id) is
5329
   begin
5330
      if Is_Record_Type (Etype (N)) then
5331
         Expand_Record_Aggregate (N);
5332
      else
5333
         Expand_Array_Aggregate (N);
5334
      end if;
5335
   exception
5336
      when RE_Not_Available =>
5337
         return;
5338
   end Expand_N_Aggregate;
5339
 
5340
   ----------------------------------
5341
   -- Expand_N_Extension_Aggregate --
5342
   ----------------------------------
5343
 
5344
   --  If the ancestor part is an expression, add a component association for
5345
   --  the parent field. If the type of the ancestor part is not the direct
5346
   --  parent of the expected type,  build recursively the needed ancestors.
5347
   --  If the ancestor part is a subtype_mark, replace aggregate with a decla-
5348
   --  ration for a temporary of the expected type, followed by individual
5349
   --  assignments to the given components.
5350
 
5351
   procedure Expand_N_Extension_Aggregate (N : Node_Id) is
5352
      Loc : constant Source_Ptr := Sloc  (N);
5353
      A   : constant Node_Id    := Ancestor_Part (N);
5354
      Typ : constant Entity_Id  := Etype (N);
5355
 
5356
   begin
5357
      --  If the ancestor is a subtype mark, an init proc must be called
5358
      --  on the resulting object which thus has to be materialized in
5359
      --  the front-end
5360
 
5361
      if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
5362
         Convert_To_Assignments (N, Typ);
5363
 
5364
      --  The extension aggregate is transformed into a record aggregate
5365
      --  of the following form (c1 and c2 are inherited components)
5366
 
5367
      --   (Exp with c3 => a, c4 => b)
5368
      --      ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b)
5369
 
5370
      else
5371
         Set_Etype (N, Typ);
5372
 
5373
         if Tagged_Type_Expansion then
5374
            Expand_Record_Aggregate (N,
5375
              Orig_Tag    =>
5376
                New_Occurrence_Of
5377
                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc),
5378
              Parent_Expr => A);
5379
         else
5380
            --  No tag is needed in the case of a VM
5381
            Expand_Record_Aggregate (N,
5382
              Parent_Expr => A);
5383
         end if;
5384
      end if;
5385
 
5386
   exception
5387
      when RE_Not_Available =>
5388
         return;
5389
   end Expand_N_Extension_Aggregate;
5390
 
5391
   -----------------------------
5392
   -- Expand_Record_Aggregate --
5393
   -----------------------------
5394
 
5395
   procedure Expand_Record_Aggregate
5396
     (N           : Node_Id;
5397
      Orig_Tag    : Node_Id := Empty;
5398
      Parent_Expr : Node_Id := Empty)
5399
   is
5400
      Loc      : constant Source_Ptr := Sloc  (N);
5401
      Comps    : constant List_Id    := Component_Associations (N);
5402
      Typ      : constant Entity_Id  := Etype (N);
5403
      Base_Typ : constant Entity_Id  := Base_Type (Typ);
5404
 
5405
      Static_Components : Boolean := True;
5406
      --  Flag to indicate whether all components are compile-time known,
5407
      --  and the aggregate can be constructed statically and handled by
5408
      --  the back-end.
5409
 
5410
      function Component_Not_OK_For_Backend return Boolean;
5411
      --  Check for presence of component which makes it impossible for the
5412
      --  backend to process the aggregate, thus requiring the use of a series
5413
      --  of assignment statements. Cases checked for are a nested aggregate
5414
      --  needing Late_Expansion, the presence of a tagged component which may
5415
      --  need tag adjustment, and a bit unaligned component reference.
5416
      --
5417
      --  We also force expansion into assignments if a component is of a
5418
      --  mutable type (including a private type with discriminants) because
5419
      --  in that case the size of the component to be copied may be smaller
5420
      --  than the side of the target, and there is no simple way for gigi
5421
      --  to compute the size of the object to be copied.
5422
      --
5423
      --  NOTE: This is part of the ongoing work to define precisely the
5424
      --  interface between front-end and back-end handling of aggregates.
5425
      --  In general it is desirable to pass aggregates as they are to gigi,
5426
      --  in order to minimize elaboration code. This is one case where the
5427
      --  semantics of Ada complicate the analysis and lead to anomalies in
5428
      --  the gcc back-end if the aggregate is not expanded into assignments.
5429
 
5430
      ----------------------------------
5431
      -- Component_Not_OK_For_Backend --
5432
      ----------------------------------
5433
 
5434
      function Component_Not_OK_For_Backend return Boolean is
5435
         C      : Node_Id;
5436
         Expr_Q : Node_Id;
5437
 
5438
      begin
5439
         if No (Comps) then
5440
            return False;
5441
         end if;
5442
 
5443
         C := First (Comps);
5444
         while Present (C) loop
5445
            if Nkind (Expression (C)) = N_Qualified_Expression then
5446
               Expr_Q := Expression (Expression (C));
5447
            else
5448
               Expr_Q := Expression (C);
5449
            end if;
5450
 
5451
            --  Return true if the aggregate has any associations for tagged
5452
            --  components that may require tag adjustment.
5453
 
5454
            --  These are cases where the source expression may have a tag that
5455
            --  could differ from the component tag (e.g., can occur for type
5456
            --  conversions and formal parameters). (Tag adjustment not needed
5457
            --  if VM_Target because object tags are implicit in the machine.)
5458
 
5459
            if Is_Tagged_Type (Etype (Expr_Q))
5460
              and then (Nkind (Expr_Q) = N_Type_Conversion
5461
                         or else (Is_Entity_Name (Expr_Q)
5462
                                    and then
5463
                                      Ekind (Entity (Expr_Q)) in Formal_Kind))
5464
              and then Tagged_Type_Expansion
5465
            then
5466
               Static_Components := False;
5467
               return True;
5468
 
5469
            elsif Is_Delayed_Aggregate (Expr_Q) then
5470
               Static_Components := False;
5471
               return True;
5472
 
5473
            elsif Possible_Bit_Aligned_Component (Expr_Q) then
5474
               Static_Components := False;
5475
               return True;
5476
            end if;
5477
 
5478
            if Is_Scalar_Type (Etype (Expr_Q)) then
5479
               if not Compile_Time_Known_Value (Expr_Q) then
5480
                  Static_Components := False;
5481
               end if;
5482
 
5483
            elsif Nkind (Expr_Q) /= N_Aggregate
5484
              or else not Compile_Time_Known_Aggregate (Expr_Q)
5485
            then
5486
               Static_Components := False;
5487
 
5488
               if Is_Private_Type (Etype (Expr_Q))
5489
                 and then Has_Discriminants (Etype (Expr_Q))
5490
               then
5491
                  return True;
5492
               end if;
5493
            end if;
5494
 
5495
            Next (C);
5496
         end loop;
5497
 
5498
         return False;
5499
      end Component_Not_OK_For_Backend;
5500
 
5501
      --  Remaining Expand_Record_Aggregate variables
5502
 
5503
      Tag_Value : Node_Id;
5504
      Comp      : Entity_Id;
5505
      New_Comp  : Node_Id;
5506
 
5507
   --  Start of processing for Expand_Record_Aggregate
5508
 
5509
   begin
5510
      --  If the aggregate is to be assigned to an atomic variable, we
5511
      --  have to prevent a piecemeal assignment even if the aggregate
5512
      --  is to be expanded. We create a temporary for the aggregate, and
5513
      --  assign the temporary instead, so that the back end can generate
5514
      --  an atomic move for it.
5515
 
5516
      if Is_Atomic (Typ)
5517
        and then Comes_From_Source (Parent (N))
5518
        and then Is_Atomic_Aggregate (N, Typ)
5519
      then
5520
         return;
5521
 
5522
      --  No special management required for aggregates used to initialize
5523
      --  statically allocated dispatch tables
5524
 
5525
      elsif Is_Static_Dispatch_Table_Aggregate (N) then
5526
         return;
5527
      end if;
5528
 
5529
      --  Ada 2005 (AI-318-2): We need to convert to assignments if components
5530
      --  are build-in-place function calls. This test could be more specific,
5531
      --  but doing it for all inherently limited aggregates seems harmless.
5532
      --  The assignments will turn into build-in-place function calls (see
5533
      --  Make_Build_In_Place_Call_In_Assignment).
5534
 
5535
      if Ada_Version >= Ada_05 and then Is_Inherently_Limited_Type (Typ) then
5536
         Convert_To_Assignments (N, Typ);
5537
 
5538
      --  Gigi doesn't handle properly temporaries of variable size
5539
      --  so we generate it in the front-end
5540
 
5541
      elsif not Size_Known_At_Compile_Time (Typ) then
5542
         Convert_To_Assignments (N, Typ);
5543
 
5544
      --  Temporaries for controlled aggregates need to be attached to a
5545
      --  final chain in order to be properly finalized, so it has to
5546
      --  be created in the front-end
5547
 
5548
      elsif Is_Controlled (Typ)
5549
        or else Has_Controlled_Component (Base_Type (Typ))
5550
      then
5551
         Convert_To_Assignments (N, Typ);
5552
 
5553
         --  Ada 2005 (AI-287): In case of default initialized components we
5554
         --  convert the aggregate into assignments.
5555
 
5556
      elsif Has_Default_Init_Comps (N) then
5557
         Convert_To_Assignments (N, Typ);
5558
 
5559
      --  Check components
5560
 
5561
      elsif Component_Not_OK_For_Backend then
5562
         Convert_To_Assignments (N, Typ);
5563
 
5564
      --  If an ancestor is private, some components are not inherited and
5565
      --  we cannot expand into a record aggregate
5566
 
5567
      elsif Has_Private_Ancestor (Typ) then
5568
         Convert_To_Assignments (N, Typ);
5569
 
5570
      --  ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
5571
      --  is not able to handle the aggregate for Late_Request.
5572
 
5573
      elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
5574
         Convert_To_Assignments (N, Typ);
5575
 
5576
      --  If the tagged types covers interface types we need to initialize all
5577
      --  hidden components containing pointers to secondary dispatch tables.
5578
 
5579
      elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then
5580
         Convert_To_Assignments (N, Typ);
5581
 
5582
      --  If some components are mutable, the size of the aggregate component
5583
      --  may be distinct from the default size of the type component, so
5584
      --  we need to expand to insure that the back-end copies the proper
5585
      --  size of the data.
5586
 
5587
      elsif Has_Mutable_Components (Typ) then
5588
         Convert_To_Assignments (N, Typ);
5589
 
5590
      --  If the type involved has any non-bit aligned components, then we are
5591
      --  not sure that the back end can handle this case correctly.
5592
 
5593
      elsif Type_May_Have_Bit_Aligned_Components (Typ) then
5594
         Convert_To_Assignments (N, Typ);
5595
 
5596
      --  In all other cases, build a proper aggregate handlable by gigi
5597
 
5598
      else
5599
         if Nkind (N) = N_Aggregate then
5600
 
5601
            --  If the aggregate is static and can be handled by the back-end,
5602
            --  nothing left to do.
5603
 
5604
            if Static_Components then
5605
               Set_Compile_Time_Known_Aggregate (N);
5606
               Set_Expansion_Delayed (N, False);
5607
            end if;
5608
         end if;
5609
 
5610
         --  If no discriminants, nothing special to do
5611
 
5612
         if not Has_Discriminants (Typ) then
5613
            null;
5614
 
5615
         --  Case of discriminants present
5616
 
5617
         elsif Is_Derived_Type (Typ) then
5618
 
5619
            --  For untagged types,  non-stored discriminants are replaced
5620
            --  with stored discriminants, which are the ones that gigi uses
5621
            --  to describe the type and its components.
5622
 
5623
            Generate_Aggregate_For_Derived_Type : declare
5624
               Constraints  : constant List_Id := New_List;
5625
               First_Comp   : Node_Id;
5626
               Discriminant : Entity_Id;
5627
               Decl         : Node_Id;
5628
               Num_Disc     : Int := 0;
5629
               Num_Gird     : Int := 0;
5630
 
5631
               procedure Prepend_Stored_Values (T : Entity_Id);
5632
               --  Scan the list of stored discriminants of the type, and add
5633
               --  their values to the aggregate being built.
5634
 
5635
               ---------------------------
5636
               -- Prepend_Stored_Values --
5637
               ---------------------------
5638
 
5639
               procedure Prepend_Stored_Values (T : Entity_Id) is
5640
               begin
5641
                  Discriminant := First_Stored_Discriminant (T);
5642
                  while Present (Discriminant) loop
5643
                     New_Comp :=
5644
                       Make_Component_Association (Loc,
5645
                         Choices    =>
5646
                           New_List (New_Occurrence_Of (Discriminant, Loc)),
5647
 
5648
                         Expression =>
5649
                           New_Copy_Tree (
5650
                             Get_Discriminant_Value (
5651
                                 Discriminant,
5652
                                 Typ,
5653
                                 Discriminant_Constraint (Typ))));
5654
 
5655
                     if No (First_Comp) then
5656
                        Prepend_To (Component_Associations (N), New_Comp);
5657
                     else
5658
                        Insert_After (First_Comp, New_Comp);
5659
                     end if;
5660
 
5661
                     First_Comp := New_Comp;
5662
                     Next_Stored_Discriminant (Discriminant);
5663
                  end loop;
5664
               end Prepend_Stored_Values;
5665
 
5666
            --  Start of processing for Generate_Aggregate_For_Derived_Type
5667
 
5668
            begin
5669
               --  Remove the associations for the discriminant of derived type
5670
 
5671
               First_Comp := First (Component_Associations (N));
5672
               while Present (First_Comp) loop
5673
                  Comp := First_Comp;
5674
                  Next (First_Comp);
5675
 
5676
                  if Ekind (Entity
5677
                             (First (Choices (Comp)))) = E_Discriminant
5678
                  then
5679
                     Remove (Comp);
5680
                     Num_Disc := Num_Disc + 1;
5681
                  end if;
5682
               end loop;
5683
 
5684
               --  Insert stored discriminant associations in the correct
5685
               --  order. If there are more stored discriminants than new
5686
               --  discriminants, there is at least one new discriminant that
5687
               --  constrains more than one of the stored discriminants. In
5688
               --  this case we need to construct a proper subtype of the
5689
               --  parent type, in order to supply values to all the
5690
               --  components. Otherwise there is one-one correspondence
5691
               --  between the constraints and the stored discriminants.
5692
 
5693
               First_Comp := Empty;
5694
 
5695
               Discriminant := First_Stored_Discriminant (Base_Type (Typ));
5696
               while Present (Discriminant) loop
5697
                  Num_Gird := Num_Gird + 1;
5698
                  Next_Stored_Discriminant (Discriminant);
5699
               end loop;
5700
 
5701
               --  Case of more stored discriminants than new discriminants
5702
 
5703
               if Num_Gird > Num_Disc then
5704
 
5705
                  --  Create a proper subtype of the parent type, which is the
5706
                  --  proper implementation type for the aggregate, and convert
5707
                  --  it to the intended target type.
5708
 
5709
                  Discriminant := First_Stored_Discriminant (Base_Type (Typ));
5710
                  while Present (Discriminant) loop
5711
                     New_Comp :=
5712
                       New_Copy_Tree (
5713
                         Get_Discriminant_Value (
5714
                             Discriminant,
5715
                             Typ,
5716
                             Discriminant_Constraint (Typ)));
5717
                     Append (New_Comp, Constraints);
5718
                     Next_Stored_Discriminant (Discriminant);
5719
                  end loop;
5720
 
5721
                  Decl :=
5722
                    Make_Subtype_Declaration (Loc,
5723
                      Defining_Identifier =>
5724
                         Make_Defining_Identifier (Loc,
5725
                            New_Internal_Name ('T')),
5726
                      Subtype_Indication =>
5727
                        Make_Subtype_Indication (Loc,
5728
                          Subtype_Mark =>
5729
                            New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
5730
                          Constraint =>
5731
                            Make_Index_Or_Discriminant_Constraint
5732
                              (Loc, Constraints)));
5733
 
5734
                  Insert_Action (N, Decl);
5735
                  Prepend_Stored_Values (Base_Type (Typ));
5736
 
5737
                  Set_Etype (N, Defining_Identifier (Decl));
5738
                  Set_Analyzed (N);
5739
 
5740
                  Rewrite (N, Unchecked_Convert_To (Typ, N));
5741
                  Analyze (N);
5742
 
5743
               --  Case where we do not have fewer new discriminants than
5744
               --  stored discriminants, so in this case we can simply use the
5745
               --  stored discriminants of the subtype.
5746
 
5747
               else
5748
                  Prepend_Stored_Values (Typ);
5749
               end if;
5750
            end Generate_Aggregate_For_Derived_Type;
5751
         end if;
5752
 
5753
         if Is_Tagged_Type (Typ) then
5754
 
5755
            --  The tagged case, _parent and _tag component must be created
5756
 
5757
            --  Reset null_present unconditionally. tagged records always have
5758
            --  at least one field (the tag or the parent)
5759
 
5760
            Set_Null_Record_Present (N, False);
5761
 
5762
            --  When the current aggregate comes from the expansion of an
5763
            --  extension aggregate, the parent expr is replaced by an
5764
            --  aggregate formed by selected components of this expr
5765
 
5766
            if Present (Parent_Expr)
5767
              and then Is_Empty_List (Comps)
5768
            then
5769
               Comp := First_Component_Or_Discriminant (Typ);
5770
               while Present (Comp) loop
5771
 
5772
                  --  Skip all expander-generated components
5773
 
5774
                  if
5775
                    not Comes_From_Source (Original_Record_Component (Comp))
5776
                  then
5777
                     null;
5778
 
5779
                  else
5780
                     New_Comp :=
5781
                       Make_Selected_Component (Loc,
5782
                         Prefix =>
5783
                           Unchecked_Convert_To (Typ,
5784
                             Duplicate_Subexpr (Parent_Expr, True)),
5785
 
5786
                         Selector_Name => New_Occurrence_Of (Comp, Loc));
5787
 
5788
                     Append_To (Comps,
5789
                       Make_Component_Association (Loc,
5790
                         Choices    =>
5791
                           New_List (New_Occurrence_Of (Comp, Loc)),
5792
                         Expression =>
5793
                           New_Comp));
5794
 
5795
                     Analyze_And_Resolve (New_Comp, Etype (Comp));
5796
                  end if;
5797
 
5798
                  Next_Component_Or_Discriminant (Comp);
5799
               end loop;
5800
            end if;
5801
 
5802
            --  Compute the value for the Tag now, if the type is a root it
5803
            --  will be included in the aggregate right away, otherwise it will
5804
            --  be propagated to the parent aggregate
5805
 
5806
            if Present (Orig_Tag) then
5807
               Tag_Value := Orig_Tag;
5808
            elsif not Tagged_Type_Expansion then
5809
               Tag_Value := Empty;
5810
            else
5811
               Tag_Value :=
5812
                 New_Occurrence_Of
5813
                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
5814
            end if;
5815
 
5816
            --  For a derived type, an aggregate for the parent is formed with
5817
            --  all the inherited components.
5818
 
5819
            if Is_Derived_Type (Typ) then
5820
 
5821
               declare
5822
                  First_Comp   : Node_Id;
5823
                  Parent_Comps : List_Id;
5824
                  Parent_Aggr  : Node_Id;
5825
                  Parent_Name  : Node_Id;
5826
 
5827
               begin
5828
                  --  Remove the inherited component association from the
5829
                  --  aggregate and store them in the parent aggregate
5830
 
5831
                  First_Comp := First (Component_Associations (N));
5832
                  Parent_Comps := New_List;
5833
                  while Present (First_Comp)
5834
                    and then Scope (Original_Record_Component (
5835
                            Entity (First (Choices (First_Comp))))) /= Base_Typ
5836
                  loop
5837
                     Comp := First_Comp;
5838
                     Next (First_Comp);
5839
                     Remove (Comp);
5840
                     Append (Comp, Parent_Comps);
5841
                  end loop;
5842
 
5843
                  Parent_Aggr := Make_Aggregate (Loc,
5844
                    Component_Associations => Parent_Comps);
5845
                  Set_Etype (Parent_Aggr, Etype (Base_Type (Typ)));
5846
 
5847
                  --  Find the _parent component
5848
 
5849
                  Comp := First_Component (Typ);
5850
                  while Chars (Comp) /= Name_uParent loop
5851
                     Comp := Next_Component (Comp);
5852
                  end loop;
5853
 
5854
                  Parent_Name := New_Occurrence_Of (Comp, Loc);
5855
 
5856
                  --  Insert the parent aggregate
5857
 
5858
                  Prepend_To (Component_Associations (N),
5859
                    Make_Component_Association (Loc,
5860
                      Choices    => New_List (Parent_Name),
5861
                      Expression => Parent_Aggr));
5862
 
5863
                  --  Expand recursively the parent propagating the right Tag
5864
 
5865
                  Expand_Record_Aggregate (
5866
                    Parent_Aggr, Tag_Value, Parent_Expr);
5867
               end;
5868
 
5869
            --  For a root type, the tag component is added (unless compiling
5870
            --  for the VMs, where tags are implicit).
5871
 
5872
            elsif Tagged_Type_Expansion then
5873
               declare
5874
                  Tag_Name  : constant Node_Id :=
5875
                                New_Occurrence_Of
5876
                                  (First_Tag_Component (Typ), Loc);
5877
                  Typ_Tag   : constant Entity_Id := RTE (RE_Tag);
5878
                  Conv_Node : constant Node_Id :=
5879
                                Unchecked_Convert_To (Typ_Tag, Tag_Value);
5880
 
5881
               begin
5882
                  Set_Etype (Conv_Node, Typ_Tag);
5883
                  Prepend_To (Component_Associations (N),
5884
                    Make_Component_Association (Loc,
5885
                      Choices    => New_List (Tag_Name),
5886
                      Expression => Conv_Node));
5887
               end;
5888
            end if;
5889
         end if;
5890
      end if;
5891
 
5892
   end Expand_Record_Aggregate;
5893
 
5894
   ----------------------------
5895
   -- Has_Default_Init_Comps --
5896
   ----------------------------
5897
 
5898
   function Has_Default_Init_Comps (N : Node_Id) return Boolean is
5899
      Comps : constant List_Id := Component_Associations (N);
5900
      C     : Node_Id;
5901
      Expr  : Node_Id;
5902
   begin
5903
      pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate));
5904
 
5905
      if No (Comps) then
5906
         return False;
5907
      end if;
5908
 
5909
      if Has_Self_Reference (N) then
5910
         return True;
5911
      end if;
5912
 
5913
      --  Check if any direct component has default initialized components
5914
 
5915
      C := First (Comps);
5916
      while Present (C) loop
5917
         if Box_Present (C) then
5918
            return True;
5919
         end if;
5920
 
5921
         Next (C);
5922
      end loop;
5923
 
5924
      --  Recursive call in case of aggregate expression
5925
 
5926
      C := First (Comps);
5927
      while Present (C) loop
5928
         Expr := Expression (C);
5929
 
5930
         if Present (Expr)
5931
           and then
5932
             Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
5933
           and then Has_Default_Init_Comps (Expr)
5934
         then
5935
            return True;
5936
         end if;
5937
 
5938
         Next (C);
5939
      end loop;
5940
 
5941
      return False;
5942
   end Has_Default_Init_Comps;
5943
 
5944
   --------------------------
5945
   -- Is_Delayed_Aggregate --
5946
   --------------------------
5947
 
5948
   function Is_Delayed_Aggregate (N : Node_Id) return Boolean is
5949
      Node : Node_Id   := N;
5950
      Kind : Node_Kind := Nkind (Node);
5951
 
5952
   begin
5953
      if Kind = N_Qualified_Expression then
5954
         Node := Expression (Node);
5955
         Kind := Nkind (Node);
5956
      end if;
5957
 
5958
      if Kind /= N_Aggregate and then Kind /= N_Extension_Aggregate then
5959
         return False;
5960
      else
5961
         return Expansion_Delayed (Node);
5962
      end if;
5963
   end Is_Delayed_Aggregate;
5964
 
5965
   ----------------------------------------
5966
   -- Is_Static_Dispatch_Table_Aggregate --
5967
   ----------------------------------------
5968
 
5969
   function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean is
5970
      Typ : constant Entity_Id := Base_Type (Etype (N));
5971
 
5972
   begin
5973
      return Static_Dispatch_Tables
5974
        and then Tagged_Type_Expansion
5975
        and then RTU_Loaded (Ada_Tags)
5976
 
5977
         --  Avoid circularity when rebuilding the compiler
5978
 
5979
        and then Cunit_Entity (Get_Source_Unit (N)) /= RTU_Entity (Ada_Tags)
5980
        and then (Typ = RTE (RE_Dispatch_Table_Wrapper)
5981
                    or else
5982
                  Typ = RTE (RE_Address_Array)
5983
                    or else
5984
                  Typ = RTE (RE_Type_Specific_Data)
5985
                    or else
5986
                  Typ = RTE (RE_Tag_Table)
5987
                    or else
5988
                  (RTE_Available (RE_Interface_Data)
5989
                     and then Typ = RTE (RE_Interface_Data))
5990
                    or else
5991
                  (RTE_Available (RE_Interfaces_Array)
5992
                     and then Typ = RTE (RE_Interfaces_Array))
5993
                    or else
5994
                  (RTE_Available (RE_Interface_Data_Element)
5995
                     and then Typ = RTE (RE_Interface_Data_Element)));
5996
   end Is_Static_Dispatch_Table_Aggregate;
5997
 
5998
   --------------------
5999
   -- Late_Expansion --
6000
   --------------------
6001
 
6002
   function Late_Expansion
6003
     (N      : Node_Id;
6004
      Typ    : Entity_Id;
6005
      Target : Node_Id;
6006
      Flist  : Node_Id   := Empty;
6007
      Obj    : Entity_Id := Empty) return List_Id
6008
   is
6009
   begin
6010
      if Is_Record_Type (Etype (N)) then
6011
         return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj);
6012
 
6013
      else pragma Assert (Is_Array_Type (Etype (N)));
6014
         return
6015
           Build_Array_Aggr_Code
6016
             (N           => N,
6017
              Ctype       => Component_Type (Etype (N)),
6018
              Index       => First_Index (Typ),
6019
              Into        => Target,
6020
              Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
6021
              Indices     => No_List,
6022
              Flist       => Flist);
6023
      end if;
6024
   end Late_Expansion;
6025
 
6026
   ----------------------------------
6027
   -- Make_OK_Assignment_Statement --
6028
   ----------------------------------
6029
 
6030
   function Make_OK_Assignment_Statement
6031
     (Sloc       : Source_Ptr;
6032
      Name       : Node_Id;
6033
      Expression : Node_Id) return Node_Id
6034
   is
6035
   begin
6036
      Set_Assignment_OK (Name);
6037
 
6038
      return Make_Assignment_Statement (Sloc, Name, Expression);
6039
   end Make_OK_Assignment_Statement;
6040
 
6041
   -----------------------
6042
   -- Number_Of_Choices --
6043
   -----------------------
6044
 
6045
   function Number_Of_Choices (N : Node_Id) return Nat is
6046
      Assoc  : Node_Id;
6047
      Choice : Node_Id;
6048
 
6049
      Nb_Choices : Nat := 0;
6050
 
6051
   begin
6052
      if Present (Expressions (N)) then
6053
         return 0;
6054
      end if;
6055
 
6056
      Assoc := First (Component_Associations (N));
6057
      while Present (Assoc) loop
6058
         Choice := First (Choices (Assoc));
6059
         while Present (Choice) loop
6060
            if Nkind (Choice) /= N_Others_Choice then
6061
               Nb_Choices := Nb_Choices + 1;
6062
            end if;
6063
 
6064
            Next (Choice);
6065
         end loop;
6066
 
6067
         Next (Assoc);
6068
      end loop;
6069
 
6070
      return Nb_Choices;
6071
   end Number_Of_Choices;
6072
 
6073
   ------------------------------------
6074
   -- Packed_Array_Aggregate_Handled --
6075
   ------------------------------------
6076
 
6077
   --  The current version of this procedure will handle at compile time
6078
   --  any array aggregate that meets these conditions:
6079
 
6080
   --    One dimensional, bit packed
6081
   --    Underlying packed type is modular type
6082
   --    Bounds are within 32-bit Int range
6083
   --    All bounds and values are static
6084
 
6085
   function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is
6086
      Loc  : constant Source_Ptr := Sloc (N);
6087
      Typ  : constant Entity_Id  := Etype (N);
6088
      Ctyp : constant Entity_Id  := Component_Type (Typ);
6089
 
6090
      Not_Handled : exception;
6091
      --  Exception raised if this aggregate cannot be handled
6092
 
6093
   begin
6094
      --  For now, handle only one dimensional bit packed arrays
6095
 
6096
      if not Is_Bit_Packed_Array (Typ)
6097
        or else Number_Dimensions (Typ) > 1
6098
        or else not Is_Modular_Integer_Type (Packed_Array_Type (Typ))
6099
      then
6100
         return False;
6101
      end if;
6102
 
6103
      if not Is_Scalar_Type (Component_Type (Typ))
6104
        and then Has_Non_Standard_Rep (Component_Type (Typ))
6105
      then
6106
         return False;
6107
      end if;
6108
 
6109
      declare
6110
         Csiz  : constant Nat := UI_To_Int (Component_Size (Typ));
6111
 
6112
         Lo : Node_Id;
6113
         Hi : Node_Id;
6114
         --  Bounds of index type
6115
 
6116
         Lob : Uint;
6117
         Hib : Uint;
6118
         --  Values of bounds if compile time known
6119
 
6120
         function Get_Component_Val (N : Node_Id) return Uint;
6121
         --  Given a expression value N of the component type Ctyp, returns a
6122
         --  value of Csiz (component size) bits representing this value. If
6123
         --  the value is non-static or any other reason exists why the value
6124
         --  cannot be returned, then Not_Handled is raised.
6125
 
6126
         -----------------------
6127
         -- Get_Component_Val --
6128
         -----------------------
6129
 
6130
         function Get_Component_Val (N : Node_Id) return Uint is
6131
            Val  : Uint;
6132
 
6133
         begin
6134
            --  We have to analyze the expression here before doing any further
6135
            --  processing here. The analysis of such expressions is deferred
6136
            --  till expansion to prevent some problems of premature analysis.
6137
 
6138
            Analyze_And_Resolve (N, Ctyp);
6139
 
6140
            --  Must have a compile time value. String literals have to be
6141
            --  converted into temporaries as well, because they cannot easily
6142
            --  be converted into their bit representation.
6143
 
6144
            if not Compile_Time_Known_Value (N)
6145
              or else Nkind (N) = N_String_Literal
6146
            then
6147
               raise Not_Handled;
6148
            end if;
6149
 
6150
            Val := Expr_Rep_Value (N);
6151
 
6152
            --  Adjust for bias, and strip proper number of bits
6153
 
6154
            if Has_Biased_Representation (Ctyp) then
6155
               Val := Val - Expr_Value (Type_Low_Bound (Ctyp));
6156
            end if;
6157
 
6158
            return Val mod Uint_2 ** Csiz;
6159
         end Get_Component_Val;
6160
 
6161
      --  Here we know we have a one dimensional bit packed array
6162
 
6163
      begin
6164
         Get_Index_Bounds (First_Index (Typ), Lo, Hi);
6165
 
6166
         --  Cannot do anything if bounds are dynamic
6167
 
6168
         if not Compile_Time_Known_Value (Lo)
6169
              or else
6170
            not Compile_Time_Known_Value (Hi)
6171
         then
6172
            return False;
6173
         end if;
6174
 
6175
         --  Or are silly out of range of int bounds
6176
 
6177
         Lob := Expr_Value (Lo);
6178
         Hib := Expr_Value (Hi);
6179
 
6180
         if not UI_Is_In_Int_Range (Lob)
6181
              or else
6182
            not UI_Is_In_Int_Range (Hib)
6183
         then
6184
            return False;
6185
         end if;
6186
 
6187
         --  At this stage we have a suitable aggregate for handling at compile
6188
         --  time (the only remaining checks are that the values of expressions
6189
         --  in the aggregate are compile time known (check is performed by
6190
         --  Get_Component_Val), and that any subtypes or ranges are statically
6191
         --  known.
6192
 
6193
         --  If the aggregate is not fully positional at this stage, then
6194
         --  convert it to positional form. Either this will fail, in which
6195
         --  case we can do nothing, or it will succeed, in which case we have
6196
         --  succeeded in handling the aggregate, or it will stay an aggregate,
6197
         --  in which case we have failed to handle this case.
6198
 
6199
         if Present (Component_Associations (N)) then
6200
            Convert_To_Positional
6201
             (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
6202
            return Nkind (N) /= N_Aggregate;
6203
         end if;
6204
 
6205
         --  Otherwise we are all positional, so convert to proper value
6206
 
6207
         declare
6208
            Lov : constant Int := UI_To_Int (Lob);
6209
            Hiv : constant Int := UI_To_Int (Hib);
6210
 
6211
            Len : constant Nat := Int'Max (0, Hiv - Lov + 1);
6212
            --  The length of the array (number of elements)
6213
 
6214
            Aggregate_Val : Uint;
6215
            --  Value of aggregate. The value is set in the low order bits of
6216
            --  this value. For the little-endian case, the values are stored
6217
            --  from low-order to high-order and for the big-endian case the
6218
            --  values are stored from high-order to low-order. Note that gigi
6219
            --  will take care of the conversions to left justify the value in
6220
            --  the big endian case (because of left justified modular type
6221
            --  processing), so we do not have to worry about that here.
6222
 
6223
            Lit : Node_Id;
6224
            --  Integer literal for resulting constructed value
6225
 
6226
            Shift : Nat;
6227
            --  Shift count from low order for next value
6228
 
6229
            Incr : Int;
6230
            --  Shift increment for loop
6231
 
6232
            Expr : Node_Id;
6233
            --  Next expression from positional parameters of aggregate
6234
 
6235
         begin
6236
            --  For little endian, we fill up the low order bits of the target
6237
            --  value. For big endian we fill up the high order bits of the
6238
            --  target value (which is a left justified modular value).
6239
 
6240
            if Bytes_Big_Endian xor Debug_Flag_8 then
6241
               Shift := Csiz * (Len - 1);
6242
               Incr  := -Csiz;
6243
            else
6244
               Shift := 0;
6245
               Incr  := +Csiz;
6246
            end if;
6247
 
6248
            --  Loop to set the values
6249
 
6250
            if Len = 0 then
6251
               Aggregate_Val := Uint_0;
6252
            else
6253
               Expr := First (Expressions (N));
6254
               Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
6255
 
6256
               for J in 2 .. Len loop
6257
                  Shift := Shift + Incr;
6258
                  Next (Expr);
6259
                  Aggregate_Val :=
6260
                    Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
6261
               end loop;
6262
            end if;
6263
 
6264
            --  Now we can rewrite with the proper value
6265
 
6266
            Lit :=
6267
              Make_Integer_Literal (Loc,
6268
                Intval => Aggregate_Val);
6269
            Set_Print_In_Hex (Lit);
6270
 
6271
            --  Construct the expression using this literal. Note that it is
6272
            --  important to qualify the literal with its proper modular type
6273
            --  since universal integer does not have the required range and
6274
            --  also this is a left justified modular type, which is important
6275
            --  in the big-endian case.
6276
 
6277
            Rewrite (N,
6278
              Unchecked_Convert_To (Typ,
6279
                Make_Qualified_Expression (Loc,
6280
                  Subtype_Mark =>
6281
                    New_Occurrence_Of (Packed_Array_Type (Typ), Loc),
6282
                  Expression   => Lit)));
6283
 
6284
            Analyze_And_Resolve (N, Typ);
6285
            return True;
6286
         end;
6287
      end;
6288
 
6289
   exception
6290
      when Not_Handled =>
6291
         return False;
6292
   end Packed_Array_Aggregate_Handled;
6293
 
6294
   ----------------------------
6295
   -- Has_Mutable_Components --
6296
   ----------------------------
6297
 
6298
   function Has_Mutable_Components (Typ : Entity_Id) return Boolean is
6299
      Comp : Entity_Id;
6300
 
6301
   begin
6302
      Comp := First_Component (Typ);
6303
      while Present (Comp) loop
6304
         if Is_Record_Type (Etype (Comp))
6305
           and then Has_Discriminants (Etype (Comp))
6306
           and then not Is_Constrained (Etype (Comp))
6307
         then
6308
            return True;
6309
         end if;
6310
 
6311
         Next_Component (Comp);
6312
      end loop;
6313
 
6314
      return False;
6315
   end Has_Mutable_Components;
6316
 
6317
   ------------------------------
6318
   -- Initialize_Discriminants --
6319
   ------------------------------
6320
 
6321
   procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is
6322
      Loc  : constant Source_Ptr := Sloc (N);
6323
      Bas  : constant Entity_Id  := Base_Type (Typ);
6324
      Par  : constant Entity_Id  := Etype (Bas);
6325
      Decl : constant Node_Id    := Parent (Par);
6326
      Ref  : Node_Id;
6327
 
6328
   begin
6329
      if Is_Tagged_Type (Bas)
6330
        and then Is_Derived_Type (Bas)
6331
        and then Has_Discriminants (Par)
6332
        and then Has_Discriminants (Bas)
6333
        and then Number_Discriminants (Bas) /= Number_Discriminants (Par)
6334
        and then Nkind (Decl) = N_Full_Type_Declaration
6335
        and then Nkind (Type_Definition (Decl)) = N_Record_Definition
6336
        and then Present
6337
          (Variant_Part (Component_List (Type_Definition (Decl))))
6338
        and then Nkind (N) /= N_Extension_Aggregate
6339
      then
6340
 
6341
         --   Call init proc to set discriminants.
6342
         --   There should eventually be a special procedure for this ???
6343
 
6344
         Ref := New_Reference_To (Defining_Identifier (N), Loc);
6345
         Insert_Actions_After (N,
6346
           Build_Initialization_Call (Sloc (N), Ref, Typ));
6347
      end if;
6348
   end Initialize_Discriminants;
6349
 
6350
   ----------------
6351
   -- Must_Slide --
6352
   ----------------
6353
 
6354
   function Must_Slide
6355
     (Obj_Type : Entity_Id;
6356
      Typ      : Entity_Id) return Boolean
6357
   is
6358
      L1, L2, H1, H2 : Node_Id;
6359
   begin
6360
      --  No sliding if the type of the object is not established yet, if it is
6361
      --  an unconstrained type whose actual subtype comes from the aggregate,
6362
      --  or if the two types are identical.
6363
 
6364
      if not Is_Array_Type (Obj_Type) then
6365
         return False;
6366
 
6367
      elsif not Is_Constrained (Obj_Type) then
6368
         return False;
6369
 
6370
      elsif Typ = Obj_Type then
6371
         return False;
6372
 
6373
      else
6374
         --  Sliding can only occur along the first dimension
6375
 
6376
         Get_Index_Bounds (First_Index (Typ), L1, H1);
6377
         Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
6378
 
6379
         if not Is_Static_Expression (L1)
6380
           or else not Is_Static_Expression (L2)
6381
           or else not Is_Static_Expression (H1)
6382
           or else not Is_Static_Expression (H2)
6383
         then
6384
            return False;
6385
         else
6386
            return Expr_Value (L1) /= Expr_Value (L2)
6387
              or else Expr_Value (H1) /= Expr_Value (H2);
6388
         end if;
6389
      end if;
6390
   end Must_Slide;
6391
 
6392
   ---------------------------
6393
   -- Safe_Slice_Assignment --
6394
   ---------------------------
6395
 
6396
   function Safe_Slice_Assignment (N : Node_Id) return Boolean is
6397
      Loc        : constant Source_Ptr := Sloc (Parent (N));
6398
      Pref       : constant Node_Id    := Prefix (Name (Parent (N)));
6399
      Range_Node : constant Node_Id    := Discrete_Range (Name (Parent (N)));
6400
      Expr       : Node_Id;
6401
      L_J        : Entity_Id;
6402
      L_Iter     : Node_Id;
6403
      L_Body     : Node_Id;
6404
      Stat       : Node_Id;
6405
 
6406
   begin
6407
      --  Generate: for J in Range loop Pref (J) := Expr; end loop;
6408
 
6409
      if Comes_From_Source (N)
6410
        and then No (Expressions (N))
6411
        and then Nkind (First (Choices (First (Component_Associations (N)))))
6412
                   = N_Others_Choice
6413
      then
6414
         Expr :=
6415
           Expression (First (Component_Associations (N)));
6416
         L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
6417
 
6418
         L_Iter :=
6419
           Make_Iteration_Scheme (Loc,
6420
             Loop_Parameter_Specification =>
6421
               Make_Loop_Parameter_Specification
6422
                 (Loc,
6423
                  Defining_Identifier         => L_J,
6424
                  Discrete_Subtype_Definition => Relocate_Node (Range_Node)));
6425
 
6426
         L_Body :=
6427
           Make_Assignment_Statement (Loc,
6428
              Name =>
6429
                Make_Indexed_Component (Loc,
6430
                  Prefix      => Relocate_Node (Pref),
6431
                  Expressions => New_List (New_Occurrence_Of (L_J, Loc))),
6432
               Expression => Relocate_Node (Expr));
6433
 
6434
         --  Construct the final loop
6435
 
6436
         Stat :=
6437
           Make_Implicit_Loop_Statement
6438
             (Node             => Parent (N),
6439
              Identifier       => Empty,
6440
              Iteration_Scheme => L_Iter,
6441
              Statements       => New_List (L_Body));
6442
 
6443
         --  Set type of aggregate to be type of lhs in assignment,
6444
         --  to suppress redundant length checks.
6445
 
6446
         Set_Etype (N, Etype (Name (Parent (N))));
6447
 
6448
         Rewrite (Parent (N), Stat);
6449
         Analyze (Parent (N));
6450
         return True;
6451
 
6452
      else
6453
         return False;
6454
      end if;
6455
   end Safe_Slice_Assignment;
6456
 
6457
   ---------------------
6458
   -- Sort_Case_Table --
6459
   ---------------------
6460
 
6461
   procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
6462
      L : constant Int := Case_Table'First;
6463
      U : constant Int := Case_Table'Last;
6464
      K : Int;
6465
      J : Int;
6466
      T : Case_Bounds;
6467
 
6468
   begin
6469
      K := L;
6470
      while K /= U loop
6471
         T := Case_Table (K + 1);
6472
 
6473
         J := K + 1;
6474
         while J /= L
6475
           and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
6476
                    Expr_Value (T.Choice_Lo)
6477
         loop
6478
            Case_Table (J) := Case_Table (J - 1);
6479
            J := J - 1;
6480
         end loop;
6481
 
6482
         Case_Table (J) := T;
6483
         K := K + 1;
6484
      end loop;
6485
   end Sort_Case_Table;
6486
 
6487
   ----------------------------
6488
   -- Static_Array_Aggregate --
6489
   ----------------------------
6490
 
6491
   function Static_Array_Aggregate (N : Node_Id) return Boolean is
6492
      Bounds : constant Node_Id := Aggregate_Bounds (N);
6493
 
6494
      Typ       : constant Entity_Id := Etype (N);
6495
      Comp_Type : constant Entity_Id := Component_Type (Typ);
6496
      Agg       : Node_Id;
6497
      Expr      : Node_Id;
6498
      Lo        : Node_Id;
6499
      Hi        : Node_Id;
6500
 
6501
   begin
6502
      if Is_Tagged_Type (Typ)
6503
        or else Is_Controlled (Typ)
6504
        or else Is_Packed (Typ)
6505
      then
6506
         return False;
6507
      end if;
6508
 
6509
      if Present (Bounds)
6510
        and then Nkind (Bounds) = N_Range
6511
        and then Nkind (Low_Bound  (Bounds)) = N_Integer_Literal
6512
        and then Nkind (High_Bound (Bounds)) = N_Integer_Literal
6513
      then
6514
         Lo := Low_Bound  (Bounds);
6515
         Hi := High_Bound (Bounds);
6516
 
6517
         if No (Component_Associations (N)) then
6518
 
6519
            --  Verify that all components are static integers
6520
 
6521
            Expr := First (Expressions (N));
6522
            while Present (Expr) loop
6523
               if Nkind (Expr) /= N_Integer_Literal then
6524
                  return False;
6525
               end if;
6526
 
6527
               Next (Expr);
6528
            end loop;
6529
 
6530
            return True;
6531
 
6532
         else
6533
            --  We allow only a single named association, either a static
6534
            --  range or an others_clause, with a static expression.
6535
 
6536
            Expr := First (Component_Associations (N));
6537
 
6538
            if Present (Expressions (N)) then
6539
               return False;
6540
 
6541
            elsif Present (Next (Expr)) then
6542
               return False;
6543
 
6544
            elsif Present (Next (First (Choices (Expr)))) then
6545
               return False;
6546
 
6547
            else
6548
               --  The aggregate is static if all components are literals,
6549
               --  or else all its components are static aggregates for the
6550
               --  component type. We also limit the size of a static aggregate
6551
               --  to prevent runaway static expressions.
6552
 
6553
               if Is_Array_Type (Comp_Type)
6554
                 or else Is_Record_Type (Comp_Type)
6555
               then
6556
                  if Nkind (Expression (Expr)) /= N_Aggregate
6557
                    or else
6558
                      not Compile_Time_Known_Aggregate (Expression (Expr))
6559
                  then
6560
                     return False;
6561
                  end if;
6562
 
6563
               elsif Nkind (Expression (Expr)) /= N_Integer_Literal then
6564
                  return False;
6565
 
6566
               elsif not Aggr_Size_OK (N, Typ) then
6567
                  return False;
6568
               end if;
6569
 
6570
               --  Create a positional aggregate with the right number of
6571
               --  copies of the expression.
6572
 
6573
               Agg := Make_Aggregate (Sloc (N), New_List, No_List);
6574
 
6575
               for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi))
6576
               loop
6577
                  Append_To
6578
                    (Expressions (Agg), New_Copy (Expression (Expr)));
6579
 
6580
                  --  The copied expression must be analyzed and resolved.
6581
                  --  Besides setting the type, this ensures that static
6582
                  --  expressions are appropriately marked as such.
6583
 
6584
                  Analyze_And_Resolve
6585
                    (Last (Expressions (Agg)), Component_Type (Typ));
6586
               end loop;
6587
 
6588
               Set_Aggregate_Bounds (Agg, Bounds);
6589
               Set_Etype (Agg, Typ);
6590
               Set_Analyzed (Agg);
6591
               Rewrite (N, Agg);
6592
               Set_Compile_Time_Known_Aggregate (N);
6593
 
6594
               return True;
6595
            end if;
6596
         end if;
6597
 
6598
      else
6599
         return False;
6600
      end if;
6601
   end Static_Array_Aggregate;
6602
 
6603
end Exp_Aggr;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.