]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/exp_aggr.adb
ada: Factor out tag assignments from type in expander
[thirdparty/gcc.git] / gcc / ada / exp_aggr.adb
CommitLineData
70482933
RK
1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- E X P _ A G G R --
6-- --
7-- B o d y --
8-- --
cccef051 9-- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
70482933
RK
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- --
b5c84c3c 13-- ware Foundation; either version 3, or (at your option) any later ver- --
70482933
RK
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 --
b5c84c3c
RD
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. --
70482933
RK
20-- --
21-- GNAT was originally developed by the GNAT team at New York University. --
71ff80dc 22-- Extensive contributions were provided by Ada Core Technologies Inc. --
70482933
RK
23-- --
24------------------------------------------------------------------------------
25
104f58db
BD
26with Aspects; use Aspects;
27with Atree; use Atree;
28with Checks; use Checks;
29with Debug; use Debug;
30with Einfo; use Einfo;
76f9c7f4 31with Einfo.Entities; use Einfo.Entities;
104f58db
BD
32with Einfo.Utils; use Einfo.Utils;
33with Elists; use Elists;
34with Errout; use Errout;
35with Expander; use Expander;
36with Exp_Util; use Exp_Util;
37with Exp_Ch3; use Exp_Ch3;
38with Exp_Ch6; use Exp_Ch6;
39with Exp_Ch7; use Exp_Ch7;
40with Exp_Ch9; use Exp_Ch9;
41with Exp_Disp; use Exp_Disp;
42with Exp_Tss; use Exp_Tss;
43with Freeze; use Freeze;
44with Itypes; use Itypes;
45with Lib; use Lib;
46with Namet; use Namet;
47with Nmake; use Nmake;
48with Nlists; use Nlists;
49with Opt; use Opt;
50with Restrict; use Restrict;
51with Rident; use Rident;
52with Rtsfind; use Rtsfind;
53with Ttypes; use Ttypes;
54with Sem; use Sem;
55with Sem_Aggr; use Sem_Aggr;
56with Sem_Aux; use Sem_Aux;
e1dfbb03 57with Sem_Case; use Sem_Case;
104f58db
BD
58with Sem_Ch3; use Sem_Ch3;
59with Sem_Ch8; use Sem_Ch8;
60with Sem_Ch13; use Sem_Ch13;
61with Sem_Eval; use Sem_Eval;
62with Sem_Mech; use Sem_Mech;
63with Sem_Res; use Sem_Res;
64with Sem_Util; use Sem_Util;
ca4bff3a 65 use Sem_Util.Storage_Model_Support;
104f58db
BD
66with Sinfo; use Sinfo;
67with Sinfo.Nodes; use Sinfo.Nodes;
68with Sinfo.Utils; use Sinfo.Utils;
69with Snames; use Snames;
70with Stand; use Stand;
71with Stringt; use Stringt;
72with Tbuild; use Tbuild;
73with Uintp; use Uintp;
74with Urealp; use Urealp;
bc50ac71 75with Warnsw; use Warnsw;
70482933
RK
76
77package body Exp_Aggr is
78
742084ad
MP
79 function Build_Assignment_With_Temporary
80 (Target : Node_Id;
ca4bff3a 81 Typ : Entity_Id;
742084ad
MP
82 Source : Node_Id) return List_Id;
83 -- Returns a list of actions to assign Source to Target of type Typ using
ca4bff3a 84 -- an extra temporary, which can potentially be large.
742084ad 85
70482933
RK
86 type Case_Bounds is record
87 Choice_Lo : Node_Id;
88 Choice_Hi : Node_Id;
89 Choice_Node : Node_Id;
90 end record;
91
92 type Case_Table_Type is array (Nat range <>) of Case_Bounds;
93 -- Table type used by Check_Case_Choices procedure
94
9eb8d5b4
AC
95 procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id);
96 procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
745f5698 97 procedure Expand_Container_Aggregate (N : Node_Id);
9eb8d5b4 98
a80b1eb7
EB
99 function Get_Base_Object (N : Node_Id) return Entity_Id;
100 -- Return the base object, i.e. the outermost prefix object, that N refers
101 -- to statically, or Empty if it cannot be determined. The assumption is
102 -- that all dereferences are explicit in the tree rooted at N.
103
df3e68b1
HK
104 function Has_Default_Init_Comps (N : Node_Id) return Boolean;
105 -- N is an aggregate (record or array). Checks the presence of default
106 -- initialization (<>) in any component (Ada 2005: AI-287).
107
fc84947c
EB
108 procedure Initialize_Component
109 (N : Node_Id;
110 Comp : Node_Id;
111 Comp_Typ : Entity_Id;
112 Init_Expr : Node_Id;
113 Stmts : List_Id);
114 -- Perform the initialization of component Comp with expected type Comp_Typ
115 -- of aggregate N. Init_Expr denotes the initialization expression of the
116 -- component. All generated code is added to Stmts.
117
118 procedure Initialize_Controlled_Component
119 (N : Node_Id;
120 Comp : Node_Id;
121 Comp_Typ : Entity_Id;
122 Init_Expr : Node_Id;
123 Stmts : List_Id);
124 -- Perform the initialization of controlled component Comp with expected
125 -- type Comp_Typ of aggregate N. Init_Expr denotes the initialization
126 -- expression of the component. All generated code is added to Stmts.
127
128 procedure Initialize_Simple_Component
129 (N : Node_Id;
130 Comp : Node_Id;
131 Comp_Typ : Node_Id;
132 Init_Expr : Node_Id;
133 Stmts : List_Id);
134 -- Perform the initialization of simple component Comp with expected
135 -- type Comp_Typ of aggregate N. Init_Expr denotes the initialization
136 -- expression of the component. All generated code is added to Stmts.
137
9f51b855
JM
138 function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean;
139 -- Return True if aggregate N is located in a context supported by the
140 -- CCG backend; False otherwise.
6031f544 141
df3e68b1
HK
142 function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean;
143 -- Returns true if N is an aggregate used to initialize the components
b465ef6f 144 -- of a statically allocated dispatch table.
df3e68b1 145
937e9676
AC
146 function Late_Expansion
147 (N : Node_Id;
148 Typ : Entity_Id;
149 Target : Node_Id) return List_Id;
150 -- This routine implements top-down expansion of nested aggregates. In
151 -- doing so, it avoids the generation of temporaries at each level. N is
152 -- a nested record or array aggregate with the Expansion_Delayed flag.
153 -- Typ is the expected type of the aggregate. Target is a (duplicatable)
154 -- expression that will hold the result of the aggregate expansion.
155
156 function Make_OK_Assignment_Statement
157 (Sloc : Source_Ptr;
158 Name : Node_Id;
159 Expression : Node_Id) return Node_Id;
160 -- This is like Make_Assignment_Statement, except that Assignment_OK
161 -- is set in the left operand. All assignments built by this unit use
162 -- this routine. This is needed to deal with assignments to initialized
163 -- constants that are done in place.
164
3cf3e5c6 165 function Must_Slide
6732c403
ES
166 (Aggr : Node_Id;
167 Obj_Type : Entity_Id;
3cf3e5c6
AC
168 Typ : Entity_Id) return Boolean;
169 -- A static array aggregate in an object declaration can in most cases be
170 -- expanded in place. The one exception is when the aggregate is given
171 -- with component associations that specify different bounds from those of
172 -- the type definition in the object declaration. In this pathological
173 -- case the aggregate must slide, and we must introduce an intermediate
174 -- temporary to hold it.
175 --
176 -- The same holds in an assignment to one-dimensional array of arrays,
177 -- when a component may be given with bounds that differ from those of the
178 -- component type.
179
937e9676
AC
180 function Number_Of_Choices (N : Node_Id) return Nat;
181 -- Returns the number of discrete choices (not including the others choice
182 -- if present) contained in (sub-)aggregate N.
183
184 procedure Process_Transient_Component
185 (Loc : Source_Ptr;
186 Comp_Typ : Entity_Id;
187 Init_Expr : Node_Id;
188 Fin_Call : out Node_Id;
189 Hook_Clear : out Node_Id;
190 Aggr : Node_Id := Empty;
191 Stmts : List_Id := No_List);
192 -- Subsidiary to the expansion of array and record aggregates. Generate
193 -- part of the necessary code to finalize a transient component. Comp_Typ
194 -- is the component type. Init_Expr is the initialization expression of the
195 -- component which is always a function call. Fin_Call is the finalization
196 -- call used to clean up the transient function result. Hook_Clear is the
197 -- hook reset statement. Aggr and Stmts both control the placement of the
198 -- generated code. Aggr is the related aggregate. If present, all code is
199 -- inserted prior to Aggr using Insert_Action. Stmts is the initialization
200 -- statements of the component. If present, all code is added to Stmts.
201
202 procedure Process_Transient_Component_Completion
203 (Loc : Source_Ptr;
204 Aggr : Node_Id;
205 Fin_Call : Node_Id;
206 Hook_Clear : Node_Id;
207 Stmts : List_Id);
208 -- Subsidiary to the expansion of array and record aggregates. Generate
209 -- part of the necessary code to finalize a transient component. Aggr is
210 -- the related aggregate. Fin_Clear is the finalization call used to clean
41a7b948
ES
211 -- up the transient component. Hook_Clear is the hook reset statement.
212 -- Stmts is the initialization statement list for the component. All
213 -- generated code is added to Stmts.
937e9676 214
70482933
RK
215 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
216 -- Sort the Case Table using the Lower Bound of each Choice as the key.
217 -- A simple insertion sort is used since the number of choices in a case
218 -- statement of variant part will usually be small and probably in near
219 -- sorted order.
220
221 ------------------------------------------------------
222 -- Local subprograms for Record Aggregate Expansion --
223 ------------------------------------------------------
224
d4dfb005
BD
225 function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean;
226 -- True if N is an aggregate (possibly qualified or converted) that is
227 -- being returned from a build-in-place function.
228
df3e68b1 229 function Build_Record_Aggr_Code
f7e6fc47
RD
230 (N : Node_Id;
231 Typ : Entity_Id;
232 Lhs : Node_Id) return List_Id;
df3e68b1
HK
233 -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
234 -- aggregate. Target is an expression containing the location on which the
235 -- component by component assignments will take place. Returns the list of
236 -- assignments plus all other adjustments needed for tagged and controlled
203ddcea 237 -- types.
df3e68b1
HK
238
239 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
d4dfb005 240 -- Transform a record aggregate into a sequence of assignments performed
64ac53f4 241 -- component by component. N is an N_Aggregate or N_Extension_Aggregate.
d4dfb005 242 -- Typ is the type of the record aggregate.
df3e68b1 243
70482933
RK
244 procedure Expand_Record_Aggregate
245 (N : Node_Id;
246 Orig_Tag : Node_Id := Empty;
247 Parent_Expr : Node_Id := Empty);
248 -- This is the top level procedure for record aggregate expansion.
249 -- Expansion for record aggregates needs expand aggregates for tagged
250 -- record types. Specifically Expand_Record_Aggregate adds the Tag
251 -- field in front of the Component_Association list that was created
252 -- during resolution by Resolve_Record_Aggregate.
253 --
254 -- N is the record aggregate node.
255 -- Orig_Tag is the value of the Tag that has to be provided for this
256 -- specific aggregate. It carries the tag corresponding to the type
257 -- of the outermost aggregate during the recursive expansion
258 -- Parent_Expr is the ancestor part of the original extension
259 -- aggregate
260
fbf5a39b 261 function Has_Mutable_Components (Typ : Entity_Id) return Boolean;
b465ef6f 262 -- Return true if one of the components is of a discriminated type with
fbf5a39b
AC
263 -- defaults. An aggregate for a type with mutable components must be
264 -- expanded into individual assignments.
265
a80b1eb7
EB
266 function In_Place_Assign_OK
267 (N : Node_Id;
268 Target_Object : Entity_Id := Empty) return Boolean;
4ff5aa0c
AC
269 -- Predicate to determine whether an aggregate assignment can be done in
270 -- place, because none of the new values can depend on the components of
271 -- the target of the assignment.
272
07fc65c4
GB
273 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);
274 -- If the type of the aggregate is a type extension with renamed discrimi-
275 -- nants, we must initialize the hidden discriminants of the parent.
276 -- Otherwise, the target object must not be initialized. The discriminants
277 -- are initialized by calling the initialization procedure for the type.
278 -- This is incorrect if the initialization of other components has any
279 -- side effects. We restrict this call to the case where the parent type
280 -- has a variant part, because this is the only case where the hidden
281 -- discriminants are accessed, namely when calling discriminant checking
282 -- functions of the parent type, and when applying a stream attribute to
283 -- an object of the derived type.
284
70482933 285 -----------------------------------------------------
07fc65c4 286 -- Local Subprograms for Array Aggregate Expansion --
70482933
RK
287 -----------------------------------------------------
288
2fedcc18
EB
289 function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean;
290 -- Returns true if an aggregate assignment can be done by the back end
291
eaf6e63a 292 function Aggr_Size_OK (N : Node_Id) return Boolean;
841dd0f5
AC
293 -- Very large static aggregates present problems to the back-end, and are
294 -- transformed into assignments and loops. This function verifies that the
295 -- total number of components of an aggregate is acceptable for rewriting
74e7891f
RD
296 -- into a purely positional static form. Aggr_Size_OK must be called before
297 -- calling Flatten.
298 --
841dd0f5 299 -- This function also detects and warns about one-component aggregates that
d940c627 300 -- appear in a nonstatic context. Even if the component value is static,
841dd0f5 301 -- such an aggregate must be expanded into an assignment.
643a0839 302
df3e68b1
HK
303 function Backend_Processing_Possible (N : Node_Id) return Boolean;
304 -- This function checks if array aggregate N can be processed directly
b465ef6f 305 -- by the backend. If this is the case, True is returned.
df3e68b1
HK
306
307 function Build_Array_Aggr_Code
308 (N : Node_Id;
309 Ctype : Entity_Id;
310 Index : Node_Id;
311 Into : Node_Id;
312 Scalar_Comp : Boolean;
313 Indexes : List_Id := No_List) return List_Id;
314 -- This recursive routine returns a list of statements containing the
315 -- loops and assignments that are needed for the expansion of the array
316 -- aggregate N.
317 --
318 -- N is the (sub-)aggregate node to be expanded into code. This node has
319 -- been fully analyzed, and its Etype is properly set.
320 --
d74716b3 321 -- Index is the index node corresponding to the array subaggregate N
df3e68b1
HK
322 --
323 -- Into is the target expression into which we are copying the aggregate.
324 -- Note that this node may not have been analyzed yet, and so the Etype
325 -- field may not be set.
326 --
327 -- Scalar_Comp is True if the component type of the aggregate is scalar
328 --
329 -- Indexes is the current list of expressions used to index the object we
330 -- are writing into.
331
6f639c98
ES
332 procedure Convert_Array_Aggr_In_Allocator
333 (Decl : Node_Id;
334 Aggr : Node_Id;
335 Target : Node_Id);
336 -- If the aggregate appears within an allocator and can be expanded in
337 -- place, this routine generates the individual assignments to components
338 -- of the designated object. This is an optimization over the general
339 -- case, where a temporary is first created on the stack and then used to
340 -- construct the allocated object on the heap.
341
07fc65c4 342 procedure Convert_To_Positional
c42006e9
AC
343 (N : Node_Id;
344 Handle_Bit_Packed : Boolean := False);
07fc65c4 345 -- If possible, convert named notation to positional notation. This
3cf3e5c6
AC
346 -- conversion is possible only in some static cases. If the conversion is
347 -- possible, then N is rewritten with the analyzed converted aggregate.
c42006e9 348 -- The parameter Handle_Bit_Packed is usually set False (since we do
3cf3e5c6
AC
349 -- not expect the back end to handle bit packed arrays, so the normal case
350 -- of conversion is pointless), but in the special case of a call from
351 -- Packed_Array_Aggregate_Handled, we set this parameter to True, since
352 -- these are cases we handle in there.
07fc65c4 353
70482933
RK
354 procedure Expand_Array_Aggregate (N : Node_Id);
355 -- This is the top-level routine to perform array aggregate expansion.
356 -- N is the N_Aggregate node to be expanded.
357
dc3af7e2 358 function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean;
dc3af7e2
AC
359 -- For two-dimensional packed aggregates with constant bounds and constant
360 -- components, it is preferable to pack the inner aggregates because the
361 -- whole matrix can then be presented to the back-end as a one-dimensional
362 -- list of literals. This is much more efficient than expanding into single
2791be24
AC
363 -- component assignments. This function determines if the type Typ is for
364 -- an array that is suitable for this optimization: it returns True if Typ
365 -- is a two dimensional bit packed array with component size 1, 2, or 4.
dc3af7e2 366
c42006e9 367 function Max_Aggregate_Size
eaf6e63a 368 (N : Node_Id;
c42006e9 369 Default_Size : Nat := 5000) return Nat;
eaf6e63a
BD
370 -- Return the max size for a static aggregate N. Return Default_Size if no
371 -- other special criteria trigger.
c42006e9 372
07fc65c4
GB
373 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
374 -- Given an array aggregate, this function handles the case of a packed
375 -- array aggregate with all constant values, where the aggregate can be
376 -- evaluated at compile time. If this is possible, then N is rewritten
377 -- to be its proper compile time value with all the components properly
50decc81
RD
378 -- assembled. The expression is analyzed and resolved and True is returned.
379 -- If this transformation is not possible, N is unchanged and False is
380 -- returned.
07fc65c4 381
5eeeed5e
AC
382 function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean;
383 -- If the type of the aggregate is a two-dimensional bit_packed array
384 -- it may be transformed into an array of bytes with constant values,
385 -- and presented to the back-end as a static value. The function returns
386 -- false if this transformation cannot be performed. THis is similar to,
387 -- and reuses part of the machinery in Packed_Array_Aggregate_Handled.
388
2fedcc18
EB
389 ------------------------------------
390 -- Aggr_Assignment_OK_For_Backend --
391 ------------------------------------
392
393 -- Back-end processing by Gigi/gcc is possible only if all the following
394 -- conditions are met:
395
396 -- 1. N consists of a single OTHERS choice, possibly recursively, or
397 -- of a single choice, possibly recursively, if it is surrounded by
398 -- a qualified expression whose subtype mark is unconstrained.
399
400 -- 2. The array type has no null ranges (the purpose of this is to
401 -- avoid a bogus warning for an out-of-range value).
402
403 -- 3. The array type has no atomic components
404
405 -- 4. The component type is elementary
406
407 -- 5. The component size is a multiple of Storage_Unit
408
409 -- 6. The component size is Storage_Unit or the value is of the form
410 -- M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit)
411 -- and M in 0 .. A-1. This can also be viewed as K occurrences of
412 -- the Storage_Unit value M, concatenated together.
413
414 -- The ultimate goal is to generate a call to a fast memset routine
415 -- specifically optimized for the target.
416
417 function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is
2fedcc18
EB
418
419 function Is_OK_Aggregate (Aggr : Node_Id) return Boolean;
420 -- Return true if Aggr is suitable for back-end assignment
421
422 ---------------------
423 -- Is_OK_Aggregate --
424 ---------------------
425
426 function Is_OK_Aggregate (Aggr : Node_Id) return Boolean is
427 Assoc : constant List_Id := Component_Associations (Aggr);
428
429 begin
430 -- An "others" aggregate is most likely OK, but see below
431
432 if Is_Others_Aggregate (Aggr) then
433 null;
434
435 -- An aggregate with a single choice requires a qualified expression
436 -- whose subtype mark is an unconstrained type because we need it to
437 -- have the semantics of an "others" aggregate.
438
439 elsif Nkind (Parent (N)) = N_Qualified_Expression
440 and then not Is_Constrained (Entity (Subtype_Mark (Parent (N))))
441 and then Is_Single_Aggregate (Aggr)
442 then
443 null;
444
445 -- The other cases are not OK
446
447 else
448 return False;
449 end if;
450
451 -- In any case we do not support an iterated association
452
453 return Nkind (First (Assoc)) /= N_Iterated_Component_Association;
454 end Is_OK_Aggregate;
455
7c4f3267
BD
456 Bounds : Range_Nodes;
457 Csiz : Uint := No_Uint;
458 Ctyp : Entity_Id;
459 Expr : Node_Id;
460 Index : Entity_Id;
461 Nunits : Int;
462 Remainder : Uint;
463 Value : Uint;
464
b120ca61
EB
465 -- Start of processing for Aggr_Assignment_OK_For_Backend
466
2fedcc18
EB
467 begin
468 -- Back end doesn't know about <>
469
470 if Has_Default_Init_Comps (N) then
471 return False;
472 end if;
473
474 -- Recurse as far as possible to find the innermost component type
475
476 Ctyp := Etype (N);
477 Expr := N;
478 while Is_Array_Type (Ctyp) loop
479 if Nkind (Expr) /= N_Aggregate
480 or else not Is_OK_Aggregate (Expr)
481 then
482 return False;
483 end if;
484
485 Index := First_Index (Ctyp);
486 while Present (Index) loop
7c4f3267 487 Bounds := Get_Index_Bounds (Index);
2fedcc18 488
7c4f3267 489 if Is_Null_Range (Bounds.First, Bounds.Last) then
2fedcc18
EB
490 return False;
491 end if;
492
493 Next_Index (Index);
494 end loop;
495
496 Expr := Expression (First (Component_Associations (Expr)));
497
498 for J in 1 .. Number_Dimensions (Ctyp) - 1 loop
499 if Nkind (Expr) /= N_Aggregate
500 or else not Is_OK_Aggregate (Expr)
501 then
502 return False;
503 end if;
504
505 Expr := Expression (First (Component_Associations (Expr)));
506 end loop;
507
508 if Has_Atomic_Components (Ctyp) then
509 return False;
510 end if;
511
512 Csiz := Component_Size (Ctyp);
513 Ctyp := Component_Type (Ctyp);
514
b120ca61 515 if Is_Full_Access (Ctyp) then
2fedcc18
EB
516 return False;
517 end if;
518 end loop;
519
520 -- Access types need to be dealt with specially
521
522 if Is_Access_Type (Ctyp) then
523
524 -- Component_Size is not set by Layout_Type if the component
525 -- type is an access type ???
526
527 Csiz := Esize (Ctyp);
528
529 -- Fat pointers are rejected as they are not really elementary
530 -- for the backend.
531
36e38022 532 if No (Csiz) or else Csiz /= System_Address_Size then
2fedcc18
EB
533 return False;
534 end if;
535
536 -- The supported expressions are NULL and constants, others are
537 -- rejected upfront to avoid being analyzed below, which can be
538 -- problematic for some of them, for example allocators.
539
540 if Nkind (Expr) /= N_Null and then not Is_Entity_Name (Expr) then
541 return False;
542 end if;
543
544 -- Scalar types are OK if their size is a multiple of Storage_Unit
545
36e38022 546 elsif Is_Scalar_Type (Ctyp) and then Present (Csiz) then
2fedcc18
EB
547
548 if Csiz mod System_Storage_Unit /= 0 then
549 return False;
550 end if;
551
552 -- Composite types are rejected
553
554 else
555 return False;
556 end if;
557
558 -- If the expression has side effects (e.g. contains calls with
559 -- potential side effects) reject as well. We only preanalyze the
560 -- expression to prevent the removal of intended side effects.
561
562 Preanalyze_And_Resolve (Expr, Ctyp);
563
564 if not Side_Effect_Free (Expr) then
565 return False;
566 end if;
567
568 -- The expression needs to be analyzed if True is returned
569
570 Analyze_And_Resolve (Expr, Ctyp);
571
572 -- Strip away any conversions from the expression as they simply
573 -- qualify the real expression.
574
4a08c95c 575 while Nkind (Expr) in N_Unchecked_Type_Conversion | N_Type_Conversion
2fedcc18
EB
576 loop
577 Expr := Expression (Expr);
578 end loop;
579
580 Nunits := UI_To_Int (Csiz) / System_Storage_Unit;
581
582 if Nunits = 1 then
583 return True;
584 end if;
585
586 if not Compile_Time_Known_Value (Expr) then
587 return False;
588 end if;
589
590 -- The only supported value for floating point is 0.0
591
592 if Is_Floating_Point_Type (Ctyp) then
593 return Expr_Value_R (Expr) = Ureal_0;
594 end if;
595
596 -- For other types, we can look into the value as an integer, which
597 -- means the representation value for enumeration literals.
598
599 Value := Expr_Rep_Value (Expr);
600
601 if Has_Biased_Representation (Ctyp) then
602 Value := Value - Expr_Value (Type_Low_Bound (Ctyp));
603 end if;
604
605 -- Values 0 and -1 immediately satisfy the last check
606
607 if Value = Uint_0 or else Value = Uint_Minus_1 then
608 return True;
609 end if;
610
611 -- We need to work with an unsigned value
612
613 if Value < 0 then
614 Value := Value + 2**(System_Storage_Unit * Nunits);
615 end if;
616
617 Remainder := Value rem 2**System_Storage_Unit;
618
619 for J in 1 .. Nunits - 1 loop
620 Value := Value / 2**System_Storage_Unit;
621
622 if Value rem 2**System_Storage_Unit /= Remainder then
623 return False;
624 end if;
625 end loop;
626
627 return True;
628 end Aggr_Assignment_OK_For_Backend;
629
643a0839
ES
630 ------------------
631 -- Aggr_Size_OK --
632 ------------------
633
eaf6e63a
BD
634 function Aggr_Size_OK (N : Node_Id) return Boolean is
635 Typ : constant Entity_Id := Etype (N);
643a0839
ES
636 Lo : Node_Id;
637 Hi : Node_Id;
638 Indx : Node_Id;
4167b075 639 Size : Uint;
643a0839
ES
640 Lov : Uint;
641 Hiv : Uint;
642
303fbb20
AC
643 Max_Aggr_Size : Nat;
644 -- Determines the maximum size of an array aggregate produced by
645 -- converting named to positional notation (e.g. from others clauses).
646 -- This avoids running away with attempts to convert huge aggregates,
647 -- which hit memory limits in the backend.
643a0839 648
16e764a7 649 function Component_Count (T : Entity_Id) return Nat;
457cee0b 650 -- The limit is applied to the total number of subcomponents that the
643a0839
ES
651 -- aggregate will have, which is the number of static expressions
652 -- that will appear in the flattened array. This requires a recursive
16b05213 653 -- computation of the number of scalar components of the structure.
643a0839
ES
654
655 ---------------------
656 -- Component_Count --
657 ---------------------
658
16e764a7
AC
659 function Component_Count (T : Entity_Id) return Nat is
660 Res : Nat := 0;
643a0839
ES
661 Comp : Entity_Id;
662
663 begin
664 if Is_Scalar_Type (T) then
665 return 1;
666
667 elsif Is_Record_Type (T) then
668 Comp := First_Component (T);
669 while Present (Comp) loop
670 Res := Res + Component_Count (Etype (Comp));
671 Next_Component (Comp);
672 end loop;
673
674 return Res;
675
676 elsif Is_Array_Type (T) then
677 declare
678 Lo : constant Node_Id :=
15f0f591 679 Type_Low_Bound (Etype (First_Index (T)));
643a0839 680 Hi : constant Node_Id :=
15f0f591 681 Type_High_Bound (Etype (First_Index (T)));
643a0839 682
16e764a7 683 Siz : constant Nat := Component_Count (Component_Type (T));
643a0839
ES
684
685 begin
b4213ffd
AC
686 -- Check for superflat arrays, i.e. arrays with such bounds
687 -- as 4 .. 2, to insure that this function never returns a
688 -- meaningless negative value.
689
643a0839
ES
690 if not Compile_Time_Known_Value (Lo)
691 or else not Compile_Time_Known_Value (Hi)
b4213ffd 692 or else Expr_Value (Hi) < Expr_Value (Lo)
643a0839
ES
693 then
694 return 0;
b4213ffd 695
643a0839 696 else
457cee0b
AC
697 -- If the number of components is greater than Int'Last,
698 -- then return Int'Last, so caller will return False (Aggr
699 -- size is not OK). Otherwise, UI_To_Int will crash.
700
701 declare
702 UI : constant Uint :=
16b8ba10 703 (Expr_Value (Hi) - Expr_Value (Lo) + 1) * Siz;
457cee0b
AC
704 begin
705 if UI_Is_In_Int_Range (UI) then
16b8ba10 706 return UI_To_Int (UI);
457cee0b
AC
707 else
708 return Int'Last;
709 end if;
710 end;
643a0839
ES
711 end if;
712 end;
713
714 else
715 -- Can only be a null for an access type
716
717 return 1;
718 end if;
719 end Component_Count;
720
721 -- Start of processing for Aggr_Size_OK
722
723 begin
c42006e9 724 -- We bump the maximum size unless the aggregate has a single component
b9ec8463 725 -- association, which will be more efficient if implemented with a loop.
73b670e3 726 -- The -gnatd_g switch disables this bumping.
b9ec8463 727
73b670e3
BD
728 if (No (Expressions (N))
729 and then No (Next (First (Component_Associations (N)))))
730 or else Debug_Flag_Underscore_G
b9ec8463 731 then
eaf6e63a 732 Max_Aggr_Size := Max_Aggregate_Size (N);
c42006e9 733 else
eaf6e63a 734 Max_Aggr_Size := Max_Aggregate_Size (N, 500_000);
303fbb20
AC
735 end if;
736
4167b075 737 Size := UI_From_Int (Component_Count (Component_Type (Typ)));
643a0839 738
5277cab6 739 Indx := First_Index (Typ);
643a0839
ES
740 while Present (Indx) loop
741 Lo := Type_Low_Bound (Etype (Indx));
742 Hi := Type_High_Bound (Etype (Indx));
743
744 -- Bounds need to be known at compile time
745
746 if not Compile_Time_Known_Value (Lo)
747 or else not Compile_Time_Known_Value (Hi)
748 then
749 return False;
750 end if;
751
752 Lov := Expr_Value (Lo);
753 Hiv := Expr_Value (Hi);
754
755 -- A flat array is always safe
756
757 if Hiv < Lov then
758 return True;
759 end if;
760
86038a88 761 -- One-component aggregates are suspicious, and if the context type
d940c627 762 -- is an object declaration with nonstatic bounds it will trip gcc;
86038a88 763 -- such an aggregate must be expanded into a single assignment.
58fda84d 764
36a66365 765 if Hiv = Lov and then Nkind (Parent (N)) = N_Object_Declaration then
58fda84d
ES
766 declare
767 Index_Type : constant Entity_Id :=
15f0f591
AC
768 Etype
769 (First_Index (Etype (Defining_Identifier (Parent (N)))));
86038a88
RD
770 Indx : Node_Id;
771
58fda84d
ES
772 begin
773 if not Compile_Time_Known_Value (Type_Low_Bound (Index_Type))
36a66365
AC
774 or else not Compile_Time_Known_Value
775 (Type_High_Bound (Index_Type))
58fda84d
ES
776 then
777 if Present (Component_Associations (N)) then
778 Indx :=
00f45f30
AC
779 First
780 (Choice_List (First (Component_Associations (N))));
324ac540 781
58fda84d
ES
782 if Is_Entity_Name (Indx)
783 and then not Is_Type (Entity (Indx))
784 then
785 Error_Msg_N
324ac540
AC
786 ("single component aggregate in "
787 & "non-static context??", Indx);
788 Error_Msg_N ("\maybe subtype name was meant??", Indx);
58fda84d
ES
789 end if;
790 end if;
791
792 return False;
793 end if;
794 end;
795 end if;
796
643a0839
ES
797 declare
798 Rng : constant Uint := Hiv - Lov + 1;
799
800 begin
801 -- Check if size is too large
802
803 if not UI_Is_In_Int_Range (Rng) then
804 return False;
805 end if;
806
4167b075
GD
807 -- Compute the size using universal arithmetic to avoid the
808 -- possibility of overflow on very large aggregates.
643a0839 809
4167b075
GD
810 Size := Size * Rng;
811
812 if Size <= 0
813 or else Size > Max_Aggr_Size
814 then
815 return False;
816 end if;
817 end;
643a0839
ES
818
819 -- Bounds must be in integer range, for later array construction
820
821 if not UI_Is_In_Int_Range (Lov)
822 or else
823 not UI_Is_In_Int_Range (Hiv)
824 then
825 return False;
826 end if;
827
828 Next_Index (Indx);
829 end loop;
830
831 return True;
832 end Aggr_Size_OK;
833
70482933
RK
834 ---------------------------------
835 -- Backend_Processing_Possible --
836 ---------------------------------
837
838 -- Backend processing by Gigi/gcc is possible only if all the following
839 -- conditions are met:
840
841 -- 1. N is fully positional
842
843 -- 2. N is not a bit-packed array aggregate;
844
845 -- 3. The size of N's array type must be known at compile time. Note
846 -- that this implies that the component size is also known
847
848 -- 4. The array type of N does not follow the Fortran layout convention
849 -- or if it does it must be 1 dimensional.
850
0f95b178
JM
851 -- 5. The array component type may not be tagged (which could necessitate
852 -- reassignment of proper tags).
70482933 853
0f95b178
JM
854 -- 6. The array component type must not have unaligned bit components
855
856 -- 7. None of the components of the aggregate may be bit unaligned
857 -- components.
858
859 -- 8. There cannot be delayed components, since we do not know enough
860 -- at this stage to know if back end processing is possible.
861
862 -- 9. There cannot be any discriminated record components, since the
863 -- back end cannot handle this complex case.
91b1417d 864
7f4c1903 865 -- 10. No controlled actions need to be generated for components
a8f59a33 866
7e22a38c
AC
867 -- 11. When generating C code, N must be part of a N_Object_Declaration
868
2d6aa715
AC
869 -- 12. When generating C code, N must not include function calls
870
70482933
RK
871 function Backend_Processing_Possible (N : Node_Id) return Boolean is
872 Typ : constant Entity_Id := Etype (N);
3cf3e5c6 873 -- Typ is the correct constrained array subtype of the aggregate
70482933 874
0f95b178
JM
875 function Component_Check (N : Node_Id; Index : Node_Id) return Boolean;
876 -- This routine checks components of aggregate N, enforcing checks
d74716b3 877 -- 1, 7, 8, 9, 11, and 12. In the multidimensional case, these checks
2d6aa715 878 -- are performed on subaggregates. The Index value is the current index
d74716b3 879 -- being checked in the multidimensional case.
70482933 880
0f95b178
JM
881 ---------------------
882 -- Component_Check --
883 ---------------------
70482933 884
0f95b178 885 function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is
35f4f238
JM
886 function Ultimate_Original_Expression (N : Node_Id) return Node_Id;
887 -- Given a type conversion or an unchecked type conversion N, return
888 -- its innermost original expression.
889
890 ----------------------------------
891 -- Ultimate_Original_Expression --
892 ----------------------------------
893
894 function Ultimate_Original_Expression (N : Node_Id) return Node_Id is
895 Expr : Node_Id := Original_Node (N);
896
897 begin
4a08c95c
AC
898 while Nkind (Expr) in
899 N_Type_Conversion | N_Unchecked_Type_Conversion
35f4f238
JM
900 loop
901 Expr := Original_Node (Expression (Expr));
902 end loop;
903
904 return Expr;
905 end Ultimate_Original_Expression;
906
907 -- Local variables
908
70482933
RK
909 Expr : Node_Id;
910
bbe008b6
HK
911 -- Start of processing for Component_Check
912
70482933 913 begin
0f95b178 914 -- Checks 1: (no component associations)
70482933
RK
915
916 if Present (Component_Associations (N)) then
917 return False;
918 end if;
919
7ec25b2b
AC
920 -- Checks 11: The C code generator cannot handle aggregates that are
921 -- not part of an object declaration.
7e22a38c 922
4ff5aa0c
AC
923 if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
924 return False;
7e22a38c
AC
925 end if;
926
0f95b178
JM
927 -- Checks on components
928
70482933
RK
929 -- Recurse to check subaggregates, which may appear in qualified
930 -- expressions. If delayed, the front-end will have to expand.
d940c627 931 -- If the component is a discriminated record, treat as nonstatic,
5277cab6 932 -- as the back-end cannot handle this properly.
70482933
RK
933
934 Expr := First (Expressions (N));
70482933 935 while Present (Expr) loop
0f95b178
JM
936
937 -- Checks 8: (no delayed components)
938
70482933
RK
939 if Is_Delayed_Aggregate (Expr) then
940 return False;
941 end if;
942
0f95b178
JM
943 -- Checks 9: (no discriminated records)
944
5277cab6
ES
945 if Present (Etype (Expr))
946 and then Is_Record_Type (Etype (Expr))
947 and then Has_Discriminants (Etype (Expr))
948 then
949 return False;
950 end if;
951
0f95b178
JM
952 -- Checks 7. Component must not be bit aligned component
953
954 if Possible_Bit_Aligned_Component (Expr) then
955 return False;
956 end if;
957
2d6aa715
AC
958 -- Checks 12: (no function call)
959
35f4f238
JM
960 if Modify_Tree_For_C
961 and then
962 Nkind (Ultimate_Original_Expression (Expr)) = N_Function_Call
963 then
2d6aa715
AC
964 return False;
965 end if;
966
0f95b178
JM
967 -- Recursion to following indexes for multiple dimension case
968
70482933 969 if Present (Next_Index (Index))
36a66365 970 and then not Component_Check (Expr, Next_Index (Index))
70482933
RK
971 then
972 return False;
973 end if;
974
0f95b178
JM
975 -- All checks for that component finished, on to next
976
70482933
RK
977 Next (Expr);
978 end loop;
979
980 return True;
0f95b178 981 end Component_Check;
70482933
RK
982
983 -- Start of processing for Backend_Processing_Possible
984
985 begin
a8f59a33 986 -- Checks 2 (array not bit packed) and 10 (no controlled actions)
70482933 987
a8f59a33 988 if Is_Bit_Packed_Array (Typ) or else Needs_Finalization (Typ) then
70482933
RK
989 return False;
990 end if;
991
a38ff9b1
ES
992 -- If component is limited, aggregate must be expanded because each
993 -- component assignment must be built in place.
994
51245e2d 995 if Is_Limited_View (Component_Type (Typ)) then
a38ff9b1
ES
996 return False;
997 end if;
998
d74716b3 999 -- Checks 4 (array must not be multidimensional Fortran case)
70482933
RK
1000
1001 if Convention (Typ) = Convention_Fortran
1002 and then Number_Dimensions (Typ) > 1
1003 then
1004 return False;
1005 end if;
1006
1007 -- Checks 3 (size of array must be known at compile time)
1008
1009 if not Size_Known_At_Compile_Time (Typ) then
1010 return False;
1011 end if;
1012
0f95b178 1013 -- Checks on components
70482933 1014
0f95b178 1015 if not Component_Check (N, First_Index (Typ)) then
70482933
RK
1016 return False;
1017 end if;
1018
0f95b178 1019 -- Checks 5 (if the component type is tagged, then we may need to do
36a66365
AC
1020 -- tag adjustments. Perhaps this should be refined to check for any
1021 -- component associations that actually need tag adjustment, similar
d4dfb005
BD
1022 -- to the test in Component_OK_For_Backend for record aggregates with
1023 -- tagged components, but not clear whether it's worthwhile ???; in the
1024 -- case of virtual machines (no Tagged_Type_Expansion), object tags are
1025 -- handled implicitly).
70482933 1026
1f110335
AC
1027 if Is_Tagged_Type (Component_Type (Typ))
1028 and then Tagged_Type_Expansion
1029 then
70482933
RK
1030 return False;
1031 end if;
1032
91b1417d
AC
1033 -- Checks 6 (component type must not have bit aligned components)
1034
1035 if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then
1036 return False;
1037 end if;
1038
70482933
RK
1039 -- Backend processing is possible
1040
70482933
RK
1041 return True;
1042 end Backend_Processing_Possible;
1043
1044 ---------------------------
1045 -- Build_Array_Aggr_Code --
1046 ---------------------------
1047
1048 -- The code that we generate from a one dimensional aggregate is
1049
d74716b3 1050 -- 1. If the subaggregate contains discrete choices we
70482933
RK
1051
1052 -- (a) Sort the discrete choices
1053
1054 -- (b) Otherwise for each discrete choice that specifies a range we
1055 -- emit a loop. If a range specifies a maximum of three values, or
1056 -- we are dealing with an expression we emit a sequence of
1057 -- assignments instead of a loop.
1058
3cf3e5c6 1059 -- (c) Generate the remaining loops to cover the others choice if any
70482933
RK
1060
1061 -- 2. If the aggregate contains positional elements we
1062
8313d0ee 1063 -- (a) Translate the positional elements in a series of assignments
70482933
RK
1064
1065 -- (b) Generate a final loop to cover the others choice if any.
1066 -- Note that this final loop has to be a while loop since the case
1067
1068 -- L : Integer := Integer'Last;
1069 -- H : Integer := Integer'Last;
1070 -- A : array (L .. H) := (1, others =>0);
1071
1072 -- cannot be handled by a for loop. Thus for the following
1073
8313d0ee 1074 -- array (L .. H) := (.. positional elements.., others => E);
70482933
RK
1075
1076 -- we always generate something like:
1077
07fc65c4
GB
1078 -- J : Index_Type := Index_Of_Last_Positional_Element;
1079 -- while J < H loop
1080 -- J := Index_Base'Succ (J)
1081 -- Tmp (J) := E;
70482933
RK
1082 -- end loop;
1083
1084 function Build_Array_Aggr_Code
1085 (N : Node_Id;
c45b6ae0 1086 Ctype : Entity_Id;
70482933
RK
1087 Index : Node_Id;
1088 Into : Node_Id;
1089 Scalar_Comp : Boolean;
df3e68b1 1090 Indexes : List_Id := No_List) return List_Id
70482933
RK
1091 is
1092 Loc : constant Source_Ptr := Sloc (N);
4f061cf2 1093 Typ : constant Entity_Id := Etype (N);
70482933
RK
1094 Index_Base : constant Entity_Id := Base_Type (Etype (Index));
1095 Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base);
1096 Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);
1097
1098 function Add (Val : Int; To : Node_Id) return Node_Id;
3cf3e5c6
AC
1099 -- Returns an expression where Val is added to expression To, unless
1100 -- To+Val is provably out of To's base type range. To must be an
1101 -- already analyzed expression.
70482933
RK
1102
1103 function Empty_Range (L, H : Node_Id) return Boolean;
3cf3e5c6 1104 -- Returns True if the range defined by L .. H is certainly empty
70482933
RK
1105
1106 function Equal (L, H : Node_Id) return Boolean;
3cf3e5c6 1107 -- Returns True if L = H for sure
70482933
RK
1108
1109 function Index_Base_Name return Node_Id;
3cf3e5c6 1110 -- Returns a new reference to the index type name
70482933 1111
937e9676
AC
1112 function Gen_Assign
1113 (Ind : Node_Id;
fc84947c 1114 Expr : Node_Id) return List_Id;
d74716b3
AC
1115 -- Ind must be a side-effect-free expression. If the input aggregate N
1116 -- to Build_Loop contains no subaggregates, then this function returns
1117 -- the assignment statement:
70482933 1118 --
deeb1604 1119 -- Into (Indexes, Ind) := Expr;
70482933 1120 --
fc84947c 1121 -- Otherwise we call Build_Code recursively.
c45b6ae0 1122 --
0ab80019
AC
1123 -- Ada 2005 (AI-287): In case of default initialized component, Expr
1124 -- is empty and we generate a call to the corresponding IP subprogram.
70482933
RK
1125
1126 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
d74716b3
AC
1127 -- Nodes L and H must be side-effect-free expressions. If the input
1128 -- aggregate N to Build_Loop contains no subaggregates, this routine
1129 -- returns the for loop statement:
70482933
RK
1130 --
1131 -- for J in Index_Base'(L) .. Index_Base'(H) loop
deeb1604 1132 -- Into (Indexes, J) := Expr;
70482933
RK
1133 -- end loop;
1134 --
937e9676
AC
1135 -- Otherwise we call Build_Code recursively. As an optimization if the
1136 -- loop covers 3 or fewer scalar elements we generate a sequence of
1137 -- assignments.
00f45f30
AC
1138 -- If the component association that generates the loop comes from an
1139 -- Iterated_Component_Association, the loop parameter has the name of
1140 -- the corresponding parameter in the original construct.
70482933
RK
1141
1142 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
d74716b3
AC
1143 -- Nodes L and H must be side-effect-free expressions. If the input
1144 -- aggregate N to Build_Loop contains no subaggregates, this routine
1145 -- returns the while loop statement:
70482933 1146 --
07fc65c4
GB
1147 -- J : Index_Base := L;
1148 -- while J < H loop
1149 -- J := Index_Base'Succ (J);
deeb1604 1150 -- Into (Indexes, J) := Expr;
70482933
RK
1151 -- end loop;
1152 --
fbf5a39b 1153 -- Otherwise we call Build_Code recursively
70482933 1154
59e9bc0b 1155 function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id;
e9999161
AC
1156 -- For an association with a box, use value given by aspect
1157 -- Default_Component_Value of array type if specified, else use
1158 -- value given by aspect Default_Value for component type itself
1159 -- if specified, else return Empty.
59e9bc0b 1160
70482933
RK
1161 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
1162 function Local_Expr_Value (E : Node_Id) return Uint;
1163 -- These two Local routines are used to replace the corresponding ones
1164 -- in sem_eval because while processing the bounds of an aggregate with
1165 -- discrete choices whose index type is an enumeration, we build static
1166 -- expressions not recognized by Compile_Time_Known_Value as such since
1167 -- they have not yet been analyzed and resolved. All the expressions in
1168 -- question are things like Index_Base_Name'Val (Const) which we can
1169 -- easily recognize as being constant.
1170
1171 ---------
1172 -- Add --
1173 ---------
1174
1175 function Add (Val : Int; To : Node_Id) return Node_Id is
1176 Expr_Pos : Node_Id;
1177 Expr : Node_Id;
1178 To_Pos : Node_Id;
fbf5a39b
AC
1179 U_To : Uint;
1180 U_Val : constant Uint := UI_From_Int (Val);
70482933
RK
1181
1182 begin
1183 -- Note: do not try to optimize the case of Val = 0, because
1184 -- we need to build a new node with the proper Sloc value anyway.
1185
1186 -- First test if we can do constant folding
1187
1188 if Local_Compile_Time_Known_Value (To) then
1189 U_To := Local_Expr_Value (To) + Val;
1190
1191 -- Determine if our constant is outside the range of the index.
1192 -- If so return an Empty node. This empty node will be caught
1193 -- by Empty_Range below.
1194
1195 if Compile_Time_Known_Value (Index_Base_L)
1196 and then U_To < Expr_Value (Index_Base_L)
1197 then
1198 return Empty;
1199
1200 elsif Compile_Time_Known_Value (Index_Base_H)
1201 and then U_To > Expr_Value (Index_Base_H)
1202 then
1203 return Empty;
1204 end if;
1205
1206 Expr_Pos := Make_Integer_Literal (Loc, U_To);
1207 Set_Is_Static_Expression (Expr_Pos);
1208
1209 if not Is_Enumeration_Type (Index_Base) then
1210 Expr := Expr_Pos;
1211
1212 -- If we are dealing with enumeration return
1213 -- Index_Base'Val (Expr_Pos)
1214
1215 else
1216 Expr :=
1217 Make_Attribute_Reference
1218 (Loc,
1219 Prefix => Index_Base_Name,
1220 Attribute_Name => Name_Val,
1221 Expressions => New_List (Expr_Pos));
1222 end if;
1223
1224 return Expr;
1225 end if;
1226
1227 -- If we are here no constant folding possible
1228
1229 if not Is_Enumeration_Type (Index_Base) then
1230 Expr :=
1231 Make_Op_Add (Loc,
47c14114
AC
1232 Left_Opnd => Duplicate_Subexpr (To),
1233 Right_Opnd => Make_Integer_Literal (Loc, U_Val));
70482933
RK
1234
1235 -- If we are dealing with enumeration return
1236 -- Index_Base'Val (Index_Base'Pos (To) + Val)
1237
1238 else
1239 To_Pos :=
1240 Make_Attribute_Reference
1241 (Loc,
1242 Prefix => Index_Base_Name,
1243 Attribute_Name => Name_Pos,
1244 Expressions => New_List (Duplicate_Subexpr (To)));
1245
1246 Expr_Pos :=
1247 Make_Op_Add (Loc,
47c14114
AC
1248 Left_Opnd => To_Pos,
1249 Right_Opnd => Make_Integer_Literal (Loc, U_Val));
70482933
RK
1250
1251 Expr :=
1252 Make_Attribute_Reference
1253 (Loc,
1254 Prefix => Index_Base_Name,
1255 Attribute_Name => Name_Val,
1256 Expressions => New_List (Expr_Pos));
1257 end if;
1258
1259 return Expr;
1260 end Add;
1261
1262 -----------------
1263 -- Empty_Range --
1264 -----------------
1265
1266 function Empty_Range (L, H : Node_Id) return Boolean is
1267 Is_Empty : Boolean := False;
1268 Low : Node_Id;
1269 High : Node_Id;
1270
1271 begin
1272 -- First check if L or H were already detected as overflowing the
1273 -- index base range type by function Add above. If this is so Add
1274 -- returns the empty node.
1275
1276 if No (L) or else No (H) then
1277 return True;
1278 end if;
1279
1280 for J in 1 .. 3 loop
1281 case J is
1282
1283 -- L > H range is empty
1284
1285 when 1 =>
1286 Low := L;
1287 High := H;
1288
1289 -- B_L > H range must be empty
1290
1291 when 2 =>
1292 Low := Index_Base_L;
1293 High := H;
1294
1295 -- L > B_H range must be empty
1296
1297 when 3 =>
1298 Low := L;
1299 High := Index_Base_H;
1300 end case;
1301
1302 if Local_Compile_Time_Known_Value (Low)
36a66365
AC
1303 and then
1304 Local_Compile_Time_Known_Value (High)
70482933
RK
1305 then
1306 Is_Empty :=
1307 UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High));
1308 end if;
1309
1310 exit when Is_Empty;
1311 end loop;
1312
1313 return Is_Empty;
1314 end Empty_Range;
1315
1316 -----------
1317 -- Equal --
1318 -----------
1319
1320 function Equal (L, H : Node_Id) return Boolean is
1321 begin
1322 if L = H then
1323 return True;
1324
1325 elsif Local_Compile_Time_Known_Value (L)
36a66365
AC
1326 and then
1327 Local_Compile_Time_Known_Value (H)
70482933
RK
1328 then
1329 return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H));
1330 end if;
1331
1332 return False;
1333 end Equal;
1334
1335 ----------------
1336 -- Gen_Assign --
1337 ----------------
1338
937e9676
AC
1339 function Gen_Assign
1340 (Ind : Node_Id;
fc84947c 1341 Expr : Node_Id) return List_Id
937e9676 1342 is
70482933 1343 function Add_Loop_Actions (Lis : List_Id) return List_Id;
937e9676
AC
1344 -- Collect insert_actions generated in the construction of a loop,
1345 -- and prepend them to the sequence of assignments to complete the
1346 -- eventual body of the loop.
1347
70482933
RK
1348 ----------------------
1349 -- Add_Loop_Actions --
1350 ----------------------
1351
1352 function Add_Loop_Actions (Lis : List_Id) return List_Id is
1353 Res : List_Id;
1354
1355 begin
0ab80019 1356 -- Ada 2005 (AI-287): Do nothing else in case of default
6e937c1c 1357 -- initialized component.
c45b6ae0 1358
d8f7b976 1359 if No (Expr) then
c45b6ae0
AC
1360 return Lis;
1361
1362 elsif Nkind (Parent (Expr)) = N_Component_Association
70482933
RK
1363 and then Present (Loop_Actions (Parent (Expr)))
1364 then
1365 Append_List (Lis, Loop_Actions (Parent (Expr)));
1366 Res := Loop_Actions (Parent (Expr));
1367 Set_Loop_Actions (Parent (Expr), No_List);
1368 return Res;
1369
1370 else
1371 return Lis;
1372 end if;
1373 end Add_Loop_Actions;
1374
10edebe7
AC
1375 -- Local variables
1376
1377 Stmts : constant List_Id := New_List;
1378
1379 Comp_Typ : Entity_Id := Empty;
1380 Expr_Q : Node_Id;
1381 Indexed_Comp : Node_Id;
2168d7cc 1382 Init_Call : Node_Id;
10edebe7 1383 New_Indexes : List_Id;
10edebe7 1384
70482933
RK
1385 -- Start of processing for Gen_Assign
1386
1387 begin
deeb1604
AC
1388 if No (Indexes) then
1389 New_Indexes := New_List;
70482933 1390 else
deeb1604 1391 New_Indexes := New_Copy_List_Tree (Indexes);
70482933
RK
1392 end if;
1393
deeb1604 1394 Append_To (New_Indexes, Ind);
70482933 1395
70482933
RK
1396 if Present (Next_Index (Index)) then
1397 return
1398 Add_Loop_Actions (
1399 Build_Array_Aggr_Code
c45b6ae0
AC
1400 (N => Expr,
1401 Ctype => Ctype,
1402 Index => Next_Index (Index),
1403 Into => Into,
1404 Scalar_Comp => Scalar_Comp,
df3e68b1 1405 Indexes => New_Indexes));
70482933
RK
1406 end if;
1407
1408 -- If we get here then we are at a bottom-level (sub-)aggregate
1409
fbf5a39b
AC
1410 Indexed_Comp :=
1411 Checks_Off
1412 (Make_Indexed_Component (Loc,
1413 Prefix => New_Copy_Tree (Into),
deeb1604 1414 Expressions => New_Indexes));
70482933
RK
1415
1416 Set_Assignment_OK (Indexed_Comp);
1417
0ab80019 1418 -- Ada 2005 (AI-287): In case of default initialized component, Expr
6e937c1c 1419 -- is not present (and therefore we also initialize Expr_Q to empty).
c45b6ae0 1420
4f061cf2 1421 Expr_Q := Unqualify (Expr);
70482933 1422
36a66365 1423 if Present (Etype (N)) and then Etype (N) /= Any_Composite then
10edebe7
AC
1424 Comp_Typ := Component_Type (Etype (N));
1425 pragma Assert (Comp_Typ = Ctype); -- AI-287
70482933 1426
deeb1604 1427 elsif Present (Next (First (New_Indexes))) then
70482933 1428
0ab80019 1429 -- Ada 2005 (AI-287): Do nothing in case of default initialized
c45b6ae0
AC
1430 -- component because we have received the component type in
1431 -- the formal parameter Ctype.
6e937c1c
AC
1432
1433 -- ??? Some assert pragmas have been added to check if this new
36a66365 1434 -- formal can be used to replace this code in all cases.
70482933 1435
c45b6ae0 1436 if Present (Expr) then
70482933 1437
36a66365
AC
1438 -- This is a multidimensional array. Recover the component type
1439 -- from the outermost aggregate, because subaggregates do not
1440 -- have an assigned type.
70482933 1441
c45b6ae0 1442 declare
5277cab6 1443 P : Node_Id;
70482933 1444
c45b6ae0 1445 begin
5277cab6 1446 P := Parent (Expr);
c45b6ae0 1447 while Present (P) loop
c45b6ae0
AC
1448 if Nkind (P) = N_Aggregate
1449 and then Present (Etype (P))
1450 then
10edebe7 1451 Comp_Typ := Component_Type (Etype (P));
c45b6ae0
AC
1452 exit;
1453
1454 else
1455 P := Parent (P);
1456 end if;
1457 end loop;
6e937c1c 1458
10edebe7 1459 pragma Assert (Comp_Typ = Ctype); -- AI-287
c45b6ae0
AC
1460 end;
1461 end if;
70482933
RK
1462 end if;
1463
0ab80019 1464 -- Ada 2005 (AI-287): We only analyze the expression in case of non-
6e937c1c 1465 -- default initialized components (otherwise Expr_Q is not present).
c45b6ae0
AC
1466
1467 if Present (Expr_Q)
4a08c95c 1468 and then Nkind (Expr_Q) in N_Aggregate | N_Extension_Aggregate
70482933 1469 then
d7f94401
AC
1470 -- At this stage the Expression may not have been analyzed yet
1471 -- because the array aggregate code has not been updated to use
1472 -- the Expansion_Delayed flag and avoid analysis altogether to
1473 -- solve the same problem (see Resolve_Aggr_Expr). So let us do
1474 -- the analysis of non-array aggregates now in order to get the
1475 -- value of Expansion_Delayed flag for the inner aggregate ???
70482933 1476
6cbd45e4
PMR
1477 -- In the case of an iterated component association, the analysis
1478 -- of the generated loop will analyze the expression in the
1479 -- proper context, in which the loop parameter is visible.
1480
d940c627 1481 if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ) then
10fdda1c
HK
1482 if Nkind (Parent (Expr_Q)) = N_Iterated_Component_Association
1483 or else Nkind (Parent (Parent ((Expr_Q)))) =
1484 N_Iterated_Component_Association
d940c627
ES
1485 then
1486 null;
1487 else
1488 Analyze_And_Resolve (Expr_Q, Comp_Typ);
1489 end if;
70482933
RK
1490 end if;
1491
1492 if Is_Delayed_Aggregate (Expr_Q) then
3cf3e5c6 1493
308e6f3a 1494 -- This is either a subaggregate of a multidimensional array,
3cf3e5c6
AC
1495 -- or a component of an array type whose component type is
1496 -- also an array. In the latter case, the expression may have
1497 -- component associations that provide different bounds from
1498 -- those of the component type, and sliding must occur. Instead
1499 -- of decomposing the current aggregate assignment, force the
937e9676 1500 -- reanalysis of the assignment, so that a temporary will be
3cf3e5c6
AC
1501 -- generated in the usual fashion, and sliding will take place.
1502
1503 if Nkind (Parent (N)) = N_Assignment_Statement
10edebe7 1504 and then Is_Array_Type (Comp_Typ)
3cf3e5c6 1505 and then Present (Component_Associations (Expr_Q))
6732c403 1506 and then Must_Slide (N, Comp_Typ, Etype (Expr_Q))
3cf3e5c6
AC
1507 then
1508 Set_Expansion_Delayed (Expr_Q, False);
1509 Set_Analyzed (Expr_Q, False);
1510
1511 else
1512 return
1513 Add_Loop_Actions (
df3e68b1 1514 Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp));
3cf3e5c6 1515 end if;
70482933
RK
1516 end if;
1517 end if;
1518
937e9676 1519 if Present (Expr) then
fc84947c
EB
1520 Initialize_Component
1521 (N => N,
1522 Comp => Indexed_Comp,
1523 Comp_Typ => Comp_Typ,
1524 Init_Expr => Expr,
1525 Stmts => Stmts);
937e9676 1526
0ab80019 1527 -- Ada 2005 (AI-287): In case of default initialized component, call
6e937c1c 1528 -- the initialization subprogram associated with the component type.
3b9fa2df
ES
1529 -- If the component type is an access type, add an explicit null
1530 -- assignment, because for the back-end there is an initialization
1531 -- present for the whole aggregate, and no default initialization
1532 -- will take place.
1533
1534 -- In addition, if the component type is controlled, we must call
1535 -- its Initialize procedure explicitly, because there is no explicit
1536 -- object creation that will invoke it otherwise.
70482933 1537
937e9676 1538 else
3b9fa2df 1539 if Present (Base_Init_Proc (Base_Type (Ctype)))
615cbd95
AC
1540 or else Has_Task (Base_Type (Ctype))
1541 then
10edebe7 1542 Append_List_To (Stmts,
c45b6ae0
AC
1543 Build_Initialization_Call (Loc,
1544 Id_Ref => Indexed_Comp,
1545 Typ => Ctype,
1546 With_Default_Init => True));
3b9fa2df 1547
ffcfb997
ES
1548 -- If the component type has invariants, add an invariant
1549 -- check after the component is default-initialized. It will
1550 -- be analyzed and resolved before the code for initialization
1551 -- of other components.
1552
1553 if Has_Invariants (Ctype) then
1554 Set_Etype (Indexed_Comp, Ctype);
10edebe7 1555 Append_To (Stmts, Make_Invariant_Call (Indexed_Comp));
ffcfb997 1556 end if;
3b9fa2df
ES
1557 end if;
1558
048e5cef 1559 if Needs_Finalization (Ctype) then
2168d7cc 1560 Init_Call :=
37368818
RD
1561 Make_Init_Call
1562 (Obj_Ref => New_Copy_Tree (Indexed_Comp),
2168d7cc
AC
1563 Typ => Ctype);
1564
1565 -- Guard against a missing [Deep_]Initialize when the component
1566 -- type was not properly frozen.
1567
1568 if Present (Init_Call) then
1569 Append_To (Stmts, Init_Call);
1570 end if;
615cbd95 1571 end if;
097826df
GD
1572
1573 -- If Default_Initial_Condition applies to the component type,
1574 -- add a DIC check after the component is default-initialized,
1575 -- as well as after an Initialize procedure is called, in the
1576 -- case of components of a controlled type. It will be analyzed
1577 -- and resolved before the code for initialization of other
1578 -- components.
1579
1580 -- Theoretically this might also be needed for cases where Expr
1581 -- is not empty, but a default init still applies, such as for
1582 -- Default_Value cases, in which case we won't get here. ???
1583
1584 if Has_DIC (Ctype) and then Present (DIC_Procedure (Ctype)) then
1585 Append_To (Stmts,
1586 Build_DIC_Call (Loc, New_Copy_Tree (Indexed_Comp), Ctype));
1587 end if;
70482933
RK
1588 end if;
1589
10edebe7 1590 return Add_Loop_Actions (Stmts);
70482933
RK
1591 end Gen_Assign;
1592
1593 --------------
1594 -- Gen_Loop --
1595 --------------
1596
1597 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
00f45f30 1598 Is_Iterated_Component : constant Boolean :=
898edf75 1599 Parent_Kind (Expr) = N_Iterated_Component_Association;
00f45f30 1600
e3584606
MP
1601 Ent : Entity_Id;
1602
07fc65c4 1603 L_J : Node_Id;
70482933 1604
240fe2a4
AC
1605 L_L : Node_Id;
1606 -- Index_Base'(L)
1607
1608 L_H : Node_Id;
1609 -- Index_Base'(H)
1610
70482933
RK
1611 L_Range : Node_Id;
1612 -- Index_Base'(L) .. Index_Base'(H)
1613
1614 L_Iteration_Scheme : Node_Id;
07fc65c4 1615 -- L_J in Index_Base'(L) .. Index_Base'(H)
70482933
RK
1616
1617 L_Body : List_Id;
1618 -- The statements to execute in the loop
1619
fbf5a39b
AC
1620 S : constant List_Id := New_List;
1621 -- List of statements
70482933
RK
1622
1623 Tcopy : Node_Id;
1624 -- Copy of expression tree, used for checking purposes
1625
1626 begin
1627 -- If loop bounds define an empty range return the null statement
1628
1629 if Empty_Range (L, H) then
1630 Append_To (S, Make_Null_Statement (Loc));
1631
0ab80019 1632 -- Ada 2005 (AI-287): Nothing else need to be done in case of
6e937c1c 1633 -- default initialized component.
70482933 1634
d8f7b976 1635 if No (Expr) then
c45b6ae0
AC
1636 null;
1637
1638 else
1639 -- The expression must be type-checked even though no component
1640 -- of the aggregate will have this value. This is done only for
1641 -- actual components of the array, not for subaggregates. Do
1642 -- the check on a copy, because the expression may be shared
1643 -- among several choices, some of which might be non-null.
1644
1645 if Present (Etype (N))
1646 and then Is_Array_Type (Etype (N))
1647 and then No (Next_Index (Index))
1648 then
1649 Expander_Mode_Save_And_Set (False);
1650 Tcopy := New_Copy_Tree (Expr);
1651 Set_Parent (Tcopy, N);
4270e945
PT
1652
1653 -- For iterated_component_association analyze and resolve
1654 -- the expression with name of the index parameter visible.
1655 -- To manipulate scopes, we use entity of the implicit loop.
1656
1657 if Is_Iterated_Component then
1658 declare
1659 Index_Parameter : constant Entity_Id :=
1660 Defining_Identifier (Parent (Expr));
1661 begin
1662 Push_Scope (Scope (Index_Parameter));
1663 Enter_Name (Index_Parameter);
1664 Analyze_And_Resolve
1665 (Tcopy, Component_Type (Etype (N)));
1666 End_Scope;
1667 end;
1668
1669 -- For ordinary component association, just analyze and
1670 -- resolve the expression.
1671
1672 else
1673 Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
1674 end if;
1675
c45b6ae0
AC
1676 Expander_Mode_Restore;
1677 end if;
70482933
RK
1678 end if;
1679
1680 return S;
1681
00f45f30
AC
1682 -- If loop bounds are the same then generate an assignment, unless
1683 -- the parent construct is an Iterated_Component_Association.
70482933 1684
00f45f30 1685 elsif Equal (L, H) and then not Is_Iterated_Component then
70482933
RK
1686 return Gen_Assign (New_Copy_Tree (L), Expr);
1687
3b9fa2df
ES
1688 -- If H - L <= 2 then generate a sequence of assignments when we are
1689 -- processing the bottom most aggregate and it contains scalar
1690 -- components.
70482933
RK
1691
1692 elsif No (Next_Index (Index))
1693 and then Scalar_Comp
1694 and then Local_Compile_Time_Known_Value (L)
1695 and then Local_Compile_Time_Known_Value (H)
1696 and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
00f45f30 1697 and then not Is_Iterated_Component
70482933
RK
1698 then
1699 Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
1700 Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
1701
1702 if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then
1703 Append_List_To (S, Gen_Assign (Add (2, To => L), Expr));
1704 end if;
1705
1706 return S;
1707 end if;
1708
07fc65c4 1709 -- Otherwise construct the loop, starting with the loop index L_J
70482933 1710
00f45f30 1711 if Is_Iterated_Component then
e3584606
MP
1712
1713 -- Create a new scope for the loop variable so that the
1714 -- following Gen_Assign (that ends up calling
1715 -- Preanalyze_And_Resolve) can correctly find it.
1716
1717 Ent := New_Internal_Entity (E_Loop,
1718 Current_Scope, Loc, 'L');
1719 Set_Etype (Ent, Standard_Void_Type);
1720 Set_Parent (Ent, Parent (Parent (Expr)));
1721 Push_Scope (Ent);
1722
72cdccfa
HK
1723 L_J :=
1724 Make_Defining_Identifier (Loc,
1725 Chars => (Chars (Defining_Identifier (Parent (Expr)))));
00f45f30 1726
e3584606
MP
1727 Enter_Name (L_J);
1728
1729 -- The Etype will be set by a later Analyze call.
1730 Set_Etype (L_J, Any_Type);
1731
1732 Mutate_Ekind (L_J, E_Variable);
25e4024c 1733 Set_Is_Not_Self_Hidden (L_J);
e3584606 1734 Set_Scope (L_J, Ent);
00f45f30
AC
1735 else
1736 L_J := Make_Temporary (Loc, 'J', L);
1737 end if;
70482933 1738
240fe2a4
AC
1739 -- Construct "L .. H" in Index_Base. We use a qualified expression
1740 -- for the bound to convert to the index base, but we don't need
1741 -- to do that if we already have the base type at hand.
1742
1743 if Etype (L) = Index_Base then
4eac8834 1744 L_L := New_Copy_Tree (L);
240fe2a4
AC
1745 else
1746 L_L :=
1747 Make_Qualified_Expression (Loc,
1748 Subtype_Mark => Index_Base_Name,
00f45f30 1749 Expression => New_Copy_Tree (L));
240fe2a4
AC
1750 end if;
1751
1752 if Etype (H) = Index_Base then
4eac8834 1753 L_H := New_Copy_Tree (H);
240fe2a4
AC
1754 else
1755 L_H :=
1756 Make_Qualified_Expression (Loc,
1757 Subtype_Mark => Index_Base_Name,
00f45f30 1758 Expression => New_Copy_Tree (H));
240fe2a4 1759 end if;
70482933
RK
1760
1761 L_Range :=
240fe2a4 1762 Make_Range (Loc,
ffcfb997 1763 Low_Bound => L_L,
240fe2a4 1764 High_Bound => L_H);
70482933 1765
07fc65c4 1766 -- Construct "for L_J in Index_Base range L .. H"
70482933
RK
1767
1768 L_Iteration_Scheme :=
8313d0ee 1769 Make_Iteration_Scheme (Loc,
70482933 1770 Loop_Parameter_Specification =>
8313d0ee 1771 Make_Loop_Parameter_Specification (Loc,
07fc65c4 1772 Defining_Identifier => L_J,
70482933
RK
1773 Discrete_Subtype_Definition => L_Range));
1774
1775 -- Construct the statements to execute in the loop body
1776
fc84947c 1777 L_Body := Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr);
70482933
RK
1778
1779 -- Construct the final loop
1780
37368818
RD
1781 Append_To (S,
1782 Make_Implicit_Loop_Statement
1783 (Node => N,
1784 Identifier => Empty,
1785 Iteration_Scheme => L_Iteration_Scheme,
1786 Statements => L_Body));
70482933 1787
e3584606
MP
1788 if Is_Iterated_Component then
1789 End_Scope;
1790 end if;
1791
3b9fa2df
ES
1792 -- A small optimization: if the aggregate is initialized with a box
1793 -- and the component type has no initialization procedure, remove the
1794 -- useless empty loop.
0f95b178
JM
1795
1796 if Nkind (First (S)) = N_Loop_Statement
1797 and then Is_Empty_List (Statements (First (S)))
1798 then
1799 return New_List (Make_Null_Statement (Loc));
1800 else
1801 return S;
1802 end if;
70482933
RK
1803 end Gen_Loop;
1804
1805 ---------------
1806 -- Gen_While --
1807 ---------------
1808
1809 -- The code built is
1810
07fc65c4
GB
1811 -- W_J : Index_Base := L;
1812 -- while W_J < H loop
1813 -- W_J := Index_Base'Succ (W);
70482933
RK
1814 -- L_Body;
1815 -- end loop;
1816
1817 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is
07fc65c4 1818 W_J : Node_Id;
70482933
RK
1819
1820 W_Decl : Node_Id;
07fc65c4 1821 -- W_J : Base_Type := L;
70482933
RK
1822
1823 W_Iteration_Scheme : Node_Id;
07fc65c4 1824 -- while W_J < H
70482933
RK
1825
1826 W_Index_Succ : Node_Id;
07fc65c4 1827 -- Index_Base'Succ (J)
70482933 1828
fbf5a39b 1829 W_Increment : Node_Id;
07fc65c4 1830 -- W_J := Index_Base'Succ (W)
70482933 1831
fbf5a39b 1832 W_Body : constant List_Id := New_List;
70482933
RK
1833 -- The statements to execute in the loop
1834
fbf5a39b 1835 S : constant List_Id := New_List;
70482933
RK
1836 -- list of statement
1837
1838 begin
1839 -- If loop bounds define an empty range or are equal return null
1840
1841 if Empty_Range (L, H) or else Equal (L, H) then
1842 Append_To (S, Make_Null_Statement (Loc));
1843 return S;
1844 end if;
1845
07fc65c4 1846 -- Build the decl of W_J
70482933 1847
191fcb3a 1848 W_J := Make_Temporary (Loc, 'J', L);
70482933
RK
1849 W_Decl :=
1850 Make_Object_Declaration
1851 (Loc,
07fc65c4 1852 Defining_Identifier => W_J,
70482933
RK
1853 Object_Definition => Index_Base_Name,
1854 Expression => L);
1855
1856 -- Theoretically we should do a New_Copy_Tree (L) here, but we know
1857 -- that in this particular case L is a fresh Expr generated by
1858 -- Add which we are the only ones to use.
1859
1860 Append_To (S, W_Decl);
1861
fbf5a39b 1862 -- Construct " while W_J < H"
70482933
RK
1863
1864 W_Iteration_Scheme :=
1865 Make_Iteration_Scheme
1866 (Loc,
1867 Condition => Make_Op_Lt
1868 (Loc,
e4494292 1869 Left_Opnd => New_Occurrence_Of (W_J, Loc),
70482933
RK
1870 Right_Opnd => New_Copy_Tree (H)));
1871
1872 -- Construct the statements to execute in the loop body
1873
1874 W_Index_Succ :=
1875 Make_Attribute_Reference
1876 (Loc,
1877 Prefix => Index_Base_Name,
1878 Attribute_Name => Name_Succ,
e4494292 1879 Expressions => New_List (New_Occurrence_Of (W_J, Loc)));
70482933
RK
1880
1881 W_Increment :=
1882 Make_OK_Assignment_Statement
1883 (Loc,
e4494292 1884 Name => New_Occurrence_Of (W_J, Loc),
70482933
RK
1885 Expression => W_Index_Succ);
1886
1887 Append_To (W_Body, W_Increment);
937e9676 1888
70482933 1889 Append_List_To (W_Body,
fc84947c 1890 Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr));
70482933
RK
1891
1892 -- Construct the final loop
1893
37368818
RD
1894 Append_To (S,
1895 Make_Implicit_Loop_Statement
1896 (Node => N,
1897 Identifier => Empty,
1898 Iteration_Scheme => W_Iteration_Scheme,
1899 Statements => W_Body));
70482933
RK
1900
1901 return S;
1902 end Gen_While;
1903
59e9bc0b
AC
1904 --------------------
1905 -- Get_Assoc_Expr --
1906 --------------------
1907
c8df2335
EB
1908 -- Duplicate the expression in case we will be generating several loops.
1909 -- As a result the expression is no longer shared between the loops and
1910 -- is reevaluated for each such loop.
1911
59e9bc0b 1912 function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id is
e9999161
AC
1913 Typ : constant Entity_Id := Base_Type (Etype (N));
1914
59e9bc0b
AC
1915 begin
1916 if Box_Present (Assoc) then
d7b2fad2 1917 if Present (Default_Aspect_Component_Value (Typ)) then
c8df2335 1918 return New_Copy_Tree (Default_Aspect_Component_Value (Typ));
d7b2fad2 1919 elsif Needs_Simple_Initialization (Ctype) then
c8df2335 1920 return New_Copy_Tree (Get_Simple_Init_Val (Ctype, N));
59e9bc0b
AC
1921 else
1922 return Empty;
1923 end if;
1924
1925 else
c8df2335
EB
1926 -- The expression will be passed to Gen_Loop, which immediately
1927 -- calls Parent_Kind on it, so we set Parent when it matters.
1928
1929 return
1930 Expr : constant Node_Id := New_Copy_Tree (Expression (Assoc))
1931 do
1932 Copy_Parent (To => Expr, From => Expression (Assoc));
1933 end return;
59e9bc0b
AC
1934 end if;
1935 end Get_Assoc_Expr;
1936
70482933
RK
1937 ---------------------
1938 -- Index_Base_Name --
1939 ---------------------
1940
1941 function Index_Base_Name return Node_Id is
1942 begin
e4494292 1943 return New_Occurrence_Of (Index_Base, Sloc (N));
70482933
RK
1944 end Index_Base_Name;
1945
1946 ------------------------------------
1947 -- Local_Compile_Time_Known_Value --
1948 ------------------------------------
1949
1950 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is
1951 begin
1952 return Compile_Time_Known_Value (E)
1953 or else
1954 (Nkind (E) = N_Attribute_Reference
fbf5a39b
AC
1955 and then Attribute_Name (E) = Name_Val
1956 and then Compile_Time_Known_Value (First (Expressions (E))));
70482933
RK
1957 end Local_Compile_Time_Known_Value;
1958
1959 ----------------------
1960 -- Local_Expr_Value --
1961 ----------------------
1962
1963 function Local_Expr_Value (E : Node_Id) return Uint is
1964 begin
1965 if Compile_Time_Known_Value (E) then
1966 return Expr_Value (E);
1967 else
1968 return Expr_Value (First (Expressions (E)));
1969 end if;
1970 end Local_Expr_Value;
1971
937e9676 1972 -- Local variables
70482933 1973
937e9676 1974 New_Code : constant List_Id := New_List;
70482933 1975
10c257af
ES
1976 Aggr_Bounds : constant Range_Nodes :=
1977 Get_Index_Bounds (Aggregate_Bounds (N));
1978 Aggr_L : Node_Id renames Aggr_Bounds.First;
1979 Aggr_H : Node_Id renames Aggr_Bounds.Last;
d74716b3
AC
1980 -- The aggregate bounds of this specific subaggregate. Note that if the
1981 -- code generated by Build_Array_Aggr_Code is executed then these bounds
1982 -- are OK. Otherwise a Constraint_Error would have been raised.
70482933 1983
fbf5a39b
AC
1984 Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L);
1985 Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
7324bf49 1986 -- After Duplicate_Subexpr these are side-effect free
70482933 1987
937e9676
AC
1988 Assoc : Node_Id;
1989 Choice : Node_Id;
1990 Expr : Node_Id;
70482933 1991
7c4f3267
BD
1992 Bounds : Range_Nodes;
1993 Low : Node_Id renames Bounds.First;
1994 High : Node_Id renames Bounds.Last;
1995
70482933
RK
1996 Nb_Choices : Nat := 0;
1997 Table : Case_Table_Type (1 .. Number_Of_Choices (N));
1998 -- Used to sort all the different choice values
1999
2000 Nb_Elements : Int;
2001 -- Number of elements in the positional aggregate
2002
937e9676 2003 Others_Assoc : Node_Id := Empty;
70482933
RK
2004
2005 -- Start of processing for Build_Array_Aggr_Code
2006
2007 begin
8ba0b4cf 2008 -- First before we start, a special case. If we have a bit packed
fbf5a39b
AC
2009 -- array represented as a modular type, then clear the value to
2010 -- zero first, to ensure that unused bits are properly cleared.
2011
fbf5a39b
AC
2012 if Present (Typ)
2013 and then Is_Bit_Packed_Array (Typ)
8ca597af 2014 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ))
fbf5a39b 2015 then
445514c0
EB
2016 declare
2017 Zero : constant Node_Id := Make_Integer_Literal (Loc, Uint_0);
2018 begin
2019 Analyze_And_Resolve (Zero, Packed_Array_Impl_Type (Typ));
2020 Append_To (New_Code,
2021 Make_Assignment_Statement (Loc,
2022 Name => New_Copy_Tree (Into),
2023 Expression => Unchecked_Convert_To (Typ, Zero)));
2024 end;
fbf5a39b
AC
2025 end if;
2026
0e08f7ab
ES
2027 -- If the component type contains tasks, we need to build a Master
2028 -- entity in the current scope, because it will be needed if build-
2029 -- in-place functions are called in the expanded code.
2030
36a66365 2031 if Nkind (Parent (N)) = N_Object_Declaration and then Has_Task (Typ) then
0e08f7ab
ES
2032 Build_Master_Entity (Defining_Identifier (Parent (N)));
2033 end if;
2034
70482933 2035 -- STEP 1: Process component associations
3b9fa2df 2036
fbf5a39b
AC
2037 -- For those associations that may generate a loop, initialize
2038 -- Loop_Actions to collect inserted actions that may be crated.
70482933 2039
3b9fa2df
ES
2040 -- Skip this if no component associations
2041
70482933
RK
2042 if No (Expressions (N)) then
2043
2044 -- STEP 1 (a): Sort the discrete choices
2045
2046 Assoc := First (Component_Associations (N));
2047 while Present (Assoc) loop
00f45f30 2048 Choice := First (Choice_List (Assoc));
70482933 2049 while Present (Choice) loop
70482933 2050 if Nkind (Choice) = N_Others_Choice then
59e9bc0b 2051 Others_Assoc := Assoc;
70482933
RK
2052 exit;
2053 end if;
2054
7c4f3267 2055 Bounds := Get_Index_Bounds (Choice);
70482933 2056
fbf5a39b
AC
2057 if Low /= High then
2058 Set_Loop_Actions (Assoc, New_List);
2059 end if;
2060
70482933 2061 Nb_Choices := Nb_Choices + 1;
59e9bc0b
AC
2062
2063 Table (Nb_Choices) :=
2064 (Choice_Lo => Low,
2065 Choice_Hi => High,
2066 Choice_Node => Get_Assoc_Expr (Assoc));
2067
70482933
RK
2068 Next (Choice);
2069 end loop;
2070
2071 Next (Assoc);
2072 end loop;
2073
2074 -- If there is more than one set of choices these must be static
2075 -- and we can therefore sort them. Remember that Nb_Choices does not
2076 -- account for an others choice.
2077
2078 if Nb_Choices > 1 then
2079 Sort_Case_Table (Table);
2080 end if;
2081
74580e1b 2082 -- STEP 1 (b): take care of the whole set of discrete choices
70482933
RK
2083
2084 for J in 1 .. Nb_Choices loop
2085 Low := Table (J).Choice_Lo;
2086 High := Table (J).Choice_Hi;
2087 Expr := Table (J).Choice_Node;
70482933
RK
2088 Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
2089 end loop;
2090
2091 -- STEP 1 (c): generate the remaining loops to cover others choice
2092 -- We don't need to generate loops over empty gaps, but if there is
2093 -- a single empty range we must analyze the expression for semantics
2094
59e9bc0b 2095 if Present (Others_Assoc) then
70482933 2096 declare
c8df2335 2097 First : Boolean := True;
70482933
RK
2098
2099 begin
2100 for J in 0 .. Nb_Choices loop
70482933
RK
2101 if J = 0 then
2102 Low := Aggr_Low;
2103 else
2104 Low := Add (1, To => Table (J).Choice_Hi);
2105 end if;
2106
2107 if J = Nb_Choices then
2108 High := Aggr_High;
2109 else
2110 High := Add (-1, To => Table (J + 1).Choice_Lo);
2111 end if;
2112
fbf5a39b 2113 -- If this is an expansion within an init proc, make
c84700e7
ES
2114 -- sure that discriminant references are replaced by
2115 -- the corresponding discriminal.
2116
2117 if Inside_Init_Proc then
2118 if Is_Entity_Name (Low)
2119 and then Ekind (Entity (Low)) = E_Discriminant
2120 then
2121 Set_Entity (Low, Discriminal (Entity (Low)));
2122 end if;
2123
2124 if Is_Entity_Name (High)
2125 and then Ekind (Entity (High)) = E_Discriminant
2126 then
2127 Set_Entity (High, Discriminal (Entity (High)));
2128 end if;
2129 end if;
2130
c8df2335 2131 if First or else not Empty_Range (Low, High) then
70482933 2132 First := False;
6951cbc9 2133 Set_Loop_Actions (Others_Assoc, New_List);
c8df2335
EB
2134 Expr := Get_Assoc_Expr (Others_Assoc);
2135 Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
70482933
RK
2136 end if;
2137 end loop;
2138 end;
2139 end if;
2140
2141 -- STEP 2: Process positional components
2142
2143 else
2144 -- STEP 2 (a): Generate the assignments for each positional element
2145 -- Note that here we have to use Aggr_L rather than Aggr_Low because
2146 -- Aggr_L is analyzed and Add wants an analyzed expression.
2147
2148 Expr := First (Expressions (N));
2149 Nb_Elements := -1;
70482933
RK
2150 while Present (Expr) loop
2151 Nb_Elements := Nb_Elements + 1;
2152 Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr),
2153 To => New_Code);
2154 Next (Expr);
2155 end loop;
2156
02a82539 2157 -- STEP 2 (b): Generate final loop if an others choice is present.
70482933
RK
2158 -- Here Nb_Elements gives the offset of the last positional element.
2159
2160 if Present (Component_Associations (N)) then
2161 Assoc := Last (Component_Associations (N));
70482933 2162
02a82539 2163 if Nkind (Assoc) = N_Iterated_Component_Association then
81e68a19 2164 -- Ada 2022: generate a loop to have a proper scope for
02a82539
ES
2165 -- the identifier that typically appears in the expression.
2166 -- The lower bound of the loop is the position after all
2167 -- previous positional components.
6e937c1c 2168
02a82539
ES
2169 Append_List (Gen_Loop (Add (Nb_Elements + 1, To => Aggr_L),
2170 Aggr_High,
2171 Expression (Assoc)),
2172 To => New_Code);
2173 else
2174 -- Ada 2005 (AI-287)
2175
2176 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
2177 Aggr_High,
2178 Get_Assoc_Expr (Assoc)),
2179 To => New_Code);
2180 end if;
70482933
RK
2181 end if;
2182 end if;
2183
2184 return New_Code;
2185 end Build_Array_Aggr_Code;
2186
742084ad
MP
2187 -------------------------------------
2188 -- Build_Assignment_With_Temporary --
2189 -------------------------------------
2190
2191 function Build_Assignment_With_Temporary
2192 (Target : Node_Id;
ca4bff3a 2193 Typ : Entity_Id;
742084ad
MP
2194 Source : Node_Id) return List_Id
2195 is
2196 Loc : constant Source_Ptr := Sloc (Source);
2197
2198 Aggr_Code : List_Id;
2199 Tmp : Entity_Id;
742084ad
MP
2200
2201 begin
ca4bff3a
EB
2202 Aggr_Code := New_List;
2203
2204 Tmp := Build_Temporary_On_Secondary_Stack (Loc, Typ, Aggr_Code);
2205
742084ad
MP
2206 Append_To (Aggr_Code,
2207 Make_OK_Assignment_Statement (Loc,
ca4bff3a
EB
2208 Name =>
2209 Make_Explicit_Dereference (Loc,
2210 Prefix => New_Occurrence_Of (Tmp, Loc)),
742084ad
MP
2211 Expression => Source));
2212
2213 Append_To (Aggr_Code,
2214 Make_OK_Assignment_Statement (Loc,
2215 Name => Target,
ca4bff3a
EB
2216 Expression =>
2217 Make_Explicit_Dereference (Loc,
2218 Prefix => New_Occurrence_Of (Tmp, Loc))));
2219
742084ad
MP
2220 return Aggr_Code;
2221 end Build_Assignment_With_Temporary;
2222
70482933
RK
2223 ----------------------------
2224 -- Build_Record_Aggr_Code --
2225 ----------------------------
2226
2227 function Build_Record_Aggr_Code
f7e6fc47
RD
2228 (N : Node_Id;
2229 Typ : Entity_Id;
2230 Lhs : Node_Id) return List_Id
70482933
RK
2231 is
2232 Loc : constant Source_Ptr := Sloc (N);
2233 L : constant List_Id := New_List;
70482933
RK
2234 N_Typ : constant Entity_Id := Etype (N);
2235
2236 Comp : Node_Id;
2237 Instr : Node_Id;
2238 Ref : Node_Id;
0f95b178 2239 Target : Entity_Id;
70482933
RK
2240 Comp_Type : Entity_Id;
2241 Selector : Entity_Id;
2242 Comp_Expr : Node_Id;
70482933
RK
2243 Expr_Q : Node_Id;
2244
70482933
RK
2245 -- If this is an internal aggregate, the External_Final_List is an
2246 -- expression for the controller record of the enclosing type.
3b9fa2df 2247
70482933
RK
2248 -- If the current aggregate has several controlled components, this
2249 -- expression will appear in several calls to attach to the finali-
2250 -- zation list, and it must not be shared.
2251
70482933
RK
2252 Ancestor_Is_Expression : Boolean := False;
2253 Ancestor_Is_Subtype_Mark : Boolean := False;
2254
2255 Init_Typ : Entity_Id := Empty;
5277cab6 2256
df3e68b1
HK
2257 Finalization_Done : Boolean := False;
2258 -- True if Generate_Finalization_Actions has already been called; calls
0f95b178 2259 -- after the first do nothing.
70482933 2260
70482933 2261 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
3b9fa2df
ES
2262 -- Returns the value that the given discriminant of an ancestor type
2263 -- should receive (in the absence of a conflict with the value provided
2264 -- by an ancestor part of an extension aggregate).
70482933
RK
2265
2266 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id);
3b9fa2df
ES
2267 -- Check that each of the discriminant values defined by the ancestor
2268 -- part of an extension aggregate match the corresponding values
2269 -- provided by either an association of the aggregate or by the
2270 -- constraint imposed by a parent type (RM95-4.3.2(8)).
70482933 2271
d8f7b976
ES
2272 function Compatible_Int_Bounds
2273 (Agg_Bounds : Node_Id;
2274 Typ_Bounds : Node_Id) return Boolean;
2275 -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is
2276 -- assumed that both bounds are integer ranges.
2277
df3e68b1 2278 procedure Generate_Finalization_Actions;
0f95b178
JM
2279 -- Deal with the various controlled type data structure initializations
2280 -- (but only if it hasn't been done already).
d8f7b976
ES
2281
2282 function Get_Constraint_Association (T : Entity_Id) return Node_Id;
2283 -- Returns the first discriminant association in the constraint
2284 -- associated with T, if any, otherwise returns Empty.
2285
71129dde
AC
2286 function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id;
2287 -- If the ancestor part is an unconstrained type and further ancestors
2288 -- do not provide discriminants for it, check aggregate components for
2289 -- values of the discriminants.
2290
3e582869
AC
2291 procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id);
2292 -- If Typ is derived, and constrains discriminants of the parent type,
2293 -- these discriminants are not components of the aggregate, and must be
2feb1f84 2294 -- initialized. The assignments are appended to List. The same is done
10c257af 2295 -- if Typ derives from an already constrained subtype of a discriminated
2feb1f84 2296 -- parent type.
3e582869 2297
71129dde
AC
2298 procedure Init_Stored_Discriminants;
2299 -- If the type is derived and has inherited discriminants, generate
2300 -- explicit assignments for each, using the store constraint of the
2301 -- type. Note that both visible and stored discriminants must be
2302 -- initialized in case the derived type has some renamed and some
2303 -- constrained discriminants.
2304
2305 procedure Init_Visible_Discriminants;
2306 -- If type has discriminants, retrieve their values from aggregate,
2307 -- and generate explicit assignments for each. This does not include
2308 -- discriminants inherited from ancestor, which are handled above.
2309 -- The type of the aggregate is a subtype created ealier using the
2310 -- given values of the discriminant components of the aggregate.
aab45d22 2311
d8f7b976
ES
2312 function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
2313 -- Check whether Bounds is a range node and its lower and higher bounds
2314 -- are integers literals.
7b9d0d69 2315
937e9676
AC
2316 function Replace_Type (Expr : Node_Id) return Traverse_Result;
2317 -- If the aggregate contains a self-reference, traverse each expression
2318 -- to replace a possible self-reference with a reference to the proper
2319 -- component of the target of the assignment.
2320
2321 function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result;
2322 -- If default expression of a component mentions a discriminant of the
2323 -- type, it must be rewritten as the discriminant of the target object.
2324
2325 ---------------------------------
2326 -- Ancestor_Discriminant_Value --
2327 ---------------------------------
70482933
RK
2328
2329 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is
2330 Assoc : Node_Id;
2331 Assoc_Elmt : Elmt_Id;
2332 Aggr_Comp : Entity_Id;
2333 Corresp_Disc : Entity_Id;
2334 Current_Typ : Entity_Id := Base_Type (Typ);
2335 Parent_Typ : Entity_Id;
2336 Parent_Disc : Entity_Id;
2337 Save_Assoc : Node_Id := Empty;
2338
2339 begin
3b9fa2df
ES
2340 -- First check any discriminant associations to see if any of them
2341 -- provide a value for the discriminant.
70482933
RK
2342
2343 if Present (Discriminant_Specifications (Parent (Current_Typ))) then
2344 Assoc := First (Component_Associations (N));
2345 while Present (Assoc) loop
2346 Aggr_Comp := Entity (First (Choices (Assoc)));
2347
2348 if Ekind (Aggr_Comp) = E_Discriminant then
2349 Save_Assoc := Expression (Assoc);
2350
2351 Corresp_Disc := Corresponding_Discriminant (Aggr_Comp);
2352 while Present (Corresp_Disc) loop
3b9fa2df
ES
2353
2354 -- If found a corresponding discriminant then return the
2355 -- value given in the aggregate. (Note: this is not
2356 -- correct in the presence of side effects. ???)
70482933
RK
2357
2358 if Disc = Corresp_Disc then
2359 return Duplicate_Subexpr (Expression (Assoc));
2360 end if;
fbf5a39b 2361
ffcfb997 2362 Corresp_Disc := Corresponding_Discriminant (Corresp_Disc);
70482933
RK
2363 end loop;
2364 end if;
2365
2366 Next (Assoc);
2367 end loop;
2368 end if;
2369
2370 -- No match found in aggregate, so chain up parent types to find
2371 -- a constraint that defines the value of the discriminant.
2372
2373 Parent_Typ := Etype (Current_Typ);
2374 while Current_Typ /= Parent_Typ loop
9013065b
AC
2375 if Has_Discriminants (Parent_Typ)
2376 and then not Has_Unknown_Discriminants (Parent_Typ)
2377 then
70482933
RK
2378 Parent_Disc := First_Discriminant (Parent_Typ);
2379
2380 -- We either get the association from the subtype indication
2381 -- of the type definition itself, or from the discriminant
2382 -- constraint associated with the type entity (which is
2383 -- preferable, but it's not always present ???)
2384
aff557c7 2385 if Is_Empty_Elmt_List (Discriminant_Constraint (Current_Typ))
70482933
RK
2386 then
2387 Assoc := Get_Constraint_Association (Current_Typ);
2388 Assoc_Elmt := No_Elmt;
2389 else
2390 Assoc_Elmt :=
2391 First_Elmt (Discriminant_Constraint (Current_Typ));
2392 Assoc := Node (Assoc_Elmt);
2393 end if;
2394
2395 -- Traverse the discriminants of the parent type looking
2396 -- for one that corresponds.
2397
2398 while Present (Parent_Disc) and then Present (Assoc) loop
2399 Corresp_Disc := Parent_Disc;
2400 while Present (Corresp_Disc)
2401 and then Disc /= Corresp_Disc
2402 loop
ffcfb997 2403 Corresp_Disc := Corresponding_Discriminant (Corresp_Disc);
70482933
RK
2404 end loop;
2405
2406 if Disc = Corresp_Disc then
2407 if Nkind (Assoc) = N_Discriminant_Association then
2408 Assoc := Expression (Assoc);
2409 end if;
2410
e80f0cb0
RD
2411 -- If the located association directly denotes
2412 -- a discriminant, then use the value of a saved
2413 -- association of the aggregate. This is an approach
2414 -- used to handle certain cases involving multiple
2415 -- discriminants mapped to a single discriminant of
2416 -- a descendant. It's not clear how to locate the
2417 -- appropriate discriminant value for such cases. ???
70482933
RK
2418
2419 if Is_Entity_Name (Assoc)
2420 and then Ekind (Entity (Assoc)) = E_Discriminant
2421 then
2422 Assoc := Save_Assoc;
2423 end if;
2424
2425 return Duplicate_Subexpr (Assoc);
2426 end if;
2427
2428 Next_Discriminant (Parent_Disc);
2429
2430 if No (Assoc_Elmt) then
2431 Next (Assoc);
ffcfb997 2432
70482933
RK
2433 else
2434 Next_Elmt (Assoc_Elmt);
ffcfb997 2435
70482933
RK
2436 if Present (Assoc_Elmt) then
2437 Assoc := Node (Assoc_Elmt);
2438 else
2439 Assoc := Empty;
2440 end if;
2441 end if;
2442 end loop;
2443 end if;
2444
2445 Current_Typ := Parent_Typ;
2446 Parent_Typ := Etype (Current_Typ);
2447 end loop;
2448
2449 -- In some cases there's no ancestor value to locate (such as
2450 -- when an ancestor part given by an expression defines the
2451 -- discriminant value).
2452
2453 return Empty;
2454 end Ancestor_Discriminant_Value;
2455
2456 ----------------------------------
2457 -- Check_Ancestor_Discriminants --
2458 ----------------------------------
2459
2460 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is
5277cab6 2461 Discr : Entity_Id;
70482933
RK
2462 Disc_Value : Node_Id;
2463 Cond : Node_Id;
2464
2465 begin
5277cab6 2466 Discr := First_Discriminant (Base_Type (Anc_Typ));
70482933
RK
2467 while Present (Discr) loop
2468 Disc_Value := Ancestor_Discriminant_Value (Discr);
2469
2470 if Present (Disc_Value) then
2471 Cond := Make_Op_Ne (Loc,
ffcfb997 2472 Left_Opnd =>
70482933
RK
2473 Make_Selected_Component (Loc,
2474 Prefix => New_Copy_Tree (Target),
2475 Selector_Name => New_Occurrence_Of (Discr, Loc)),
2476 Right_Opnd => Disc_Value);
2477
07fc65c4
GB
2478 Append_To (L,
2479 Make_Raise_Constraint_Error (Loc,
2480 Condition => Cond,
2481 Reason => CE_Discriminant_Check_Failed));
70482933
RK
2482 end if;
2483
2484 Next_Discriminant (Discr);
2485 end loop;
2486 end Check_Ancestor_Discriminants;
2487
d8f7b976
ES
2488 ---------------------------
2489 -- Compatible_Int_Bounds --
2490 ---------------------------
2491
2492 function Compatible_Int_Bounds
2493 (Agg_Bounds : Node_Id;
2494 Typ_Bounds : Node_Id) return Boolean
2495 is
2496 Agg_Lo : constant Uint := Intval (Low_Bound (Agg_Bounds));
2497 Agg_Hi : constant Uint := Intval (High_Bound (Agg_Bounds));
2498 Typ_Lo : constant Uint := Intval (Low_Bound (Typ_Bounds));
2499 Typ_Hi : constant Uint := Intval (High_Bound (Typ_Bounds));
2500 begin
2501 return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi;
2502 end Compatible_Int_Bounds;
2503
937e9676
AC
2504 -----------------------------------
2505 -- Generate_Finalization_Actions --
2506 -----------------------------------
2507
2508 procedure Generate_Finalization_Actions is
2509 begin
2510 -- Do the work only the first time this is called
2511
2512 if Finalization_Done then
2513 return;
2514 end if;
2515
2516 Finalization_Done := True;
2517
2518 -- Determine the external finalization list. It is either the
2519 -- finalization list of the outer scope or the one coming from an
2520 -- outer aggregate. When the target is not a temporary, the proper
2521 -- scope is the scope of the target rather than the potentially
2522 -- transient current scope.
2523
2524 if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then
2525 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2526 Set_Assignment_OK (Ref);
2527
2528 Append_To (L,
2529 Make_Procedure_Call_Statement (Loc,
2530 Name =>
2531 New_Occurrence_Of
2532 (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
2533 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
2534 end if;
2535 end Generate_Finalization_Actions;
2536
70482933
RK
2537 --------------------------------
2538 -- Get_Constraint_Association --
2539 --------------------------------
2540
2541 function Get_Constraint_Association (T : Entity_Id) return Node_Id is
2c17ca0a
AC
2542 Indic : Node_Id;
2543 Typ : Entity_Id;
70482933
RK
2544
2545 begin
2c17ca0a
AC
2546 Typ := T;
2547
598a56c0
ES
2548 -- If type is private, get constraint from full view. This was
2549 -- previously done in an instance context, but is needed whenever
2550 -- the ancestor part has a discriminant, possibly inherited through
2551 -- multiple derivations.
2c17ca0a 2552
598a56c0 2553 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
2c17ca0a
AC
2554 Typ := Full_View (Typ);
2555 end if;
2556
2557 Indic := Subtype_Indication (Type_Definition (Parent (Typ)));
2558
598a56c0 2559 -- Verify that the subtype indication carries a constraint
70482933
RK
2560
2561 if Nkind (Indic) = N_Subtype_Indication
2562 and then Present (Constraint (Indic))
2563 then
2564 return First (Constraints (Constraint (Indic)));
2565 end if;
2566
2567 return Empty;
2568 end Get_Constraint_Association;
2569
aab45d22
AC
2570 -------------------------------------
2571 -- Get_Explicit_Discriminant_Value --
2572 -------------------------------------
2573
7893514c
RD
2574 function Get_Explicit_Discriminant_Value
2575 (D : Entity_Id) return Node_Id
aab45d22
AC
2576 is
2577 Assoc : Node_Id;
2578 Choice : Node_Id;
2579 Val : Node_Id;
2580
2581 begin
2582 -- The aggregate has been normalized and all associations have a
2583 -- single choice.
2584
2585 Assoc := First (Component_Associations (N));
2586 while Present (Assoc) loop
2587 Choice := First (Choices (Assoc));
7893514c 2588
aab45d22
AC
2589 if Chars (Choice) = Chars (D) then
2590 Val := Expression (Assoc);
2591 Remove (Assoc);
2592 return Val;
2593 end if;
2594
2595 Next (Assoc);
2596 end loop;
2597
2598 return Empty;
2599 end Get_Explicit_Discriminant_Value;
2600
3e582869
AC
2601 -------------------------------
2602 -- Init_Hidden_Discriminants --
2603 -------------------------------
2604
2605 procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id) is
a25e72b5
AC
2606 function Is_Completely_Hidden_Discriminant
2607 (Discr : Entity_Id) return Boolean;
2608 -- Determine whether Discr is a completely hidden discriminant of
2609 -- type Typ.
2610
2611 ---------------------------------------
2612 -- Is_Completely_Hidden_Discriminant --
2613 ---------------------------------------
2614
2615 function Is_Completely_Hidden_Discriminant
2616 (Discr : Entity_Id) return Boolean
2617 is
2618 Item : Entity_Id;
2619
2620 begin
2621 -- Use First/Next_Entity as First/Next_Discriminant do not yield
2622 -- completely hidden discriminants.
2623
2624 Item := First_Entity (Typ);
2625 while Present (Item) loop
2626 if Ekind (Item) = E_Discriminant
2627 and then Is_Completely_Hidden (Item)
2628 and then Chars (Original_Record_Component (Item)) =
2629 Chars (Discr)
2630 then
2631 return True;
2632 end if;
2633
2634 Next_Entity (Item);
2635 end loop;
2636
2637 return False;
2638 end Is_Completely_Hidden_Discriminant;
2639
2640 -- Local variables
2641
2642 Base_Typ : Entity_Id;
2643 Discr : Entity_Id;
2644 Discr_Constr : Elmt_Id;
2645 Discr_Init : Node_Id;
2646 Discr_Val : Node_Id;
ddce04b8 2647 In_Aggr_Type : Boolean;
a25e72b5
AC
2648 Par_Typ : Entity_Id;
2649
2650 -- Start of processing for Init_Hidden_Discriminants
3e582869
AC
2651
2652 begin
7b536495
AC
2653 -- The constraints on the hidden discriminants, if present, are kept
2654 -- in the Stored_Constraint list of the type itself, or in that of
ddce04b8
AC
2655 -- the base type. If not in the constraints of the aggregate itself,
2656 -- we examine ancestors to find discriminants that are not renamed
2657 -- by other discriminants but constrained explicitly.
2658
2659 In_Aggr_Type := True;
2feb1f84 2660
a25e72b5
AC
2661 Base_Typ := Base_Type (Typ);
2662 while Is_Derived_Type (Base_Typ)
596f7139 2663 and then
a25e72b5 2664 (Present (Stored_Constraint (Base_Typ))
596f7139
AC
2665 or else
2666 (In_Aggr_Type and then Present (Stored_Constraint (Typ))))
3e582869 2667 loop
a25e72b5 2668 Par_Typ := Etype (Base_Typ);
7b536495 2669
a25e72b5 2670 if not Has_Discriminants (Par_Typ) then
2feb1f84
AC
2671 return;
2672 end if;
3e582869 2673
a25e72b5 2674 Discr := First_Discriminant (Par_Typ);
2feb1f84 2675
bdc193ba 2676 -- We know that one of the stored-constraint lists is present
2feb1f84 2677
a25e72b5
AC
2678 if Present (Stored_Constraint (Base_Typ)) then
2679 Discr_Constr := First_Elmt (Stored_Constraint (Base_Typ));
bdc193ba
AC
2680
2681 -- For private extension, stored constraint may be on full view
2682
a25e72b5
AC
2683 elsif Is_Private_Type (Base_Typ)
2684 and then Present (Full_View (Base_Typ))
2685 and then Present (Stored_Constraint (Full_View (Base_Typ)))
bdc193ba 2686 then
a25e72b5
AC
2687 Discr_Constr :=
2688 First_Elmt (Stored_Constraint (Full_View (Base_Typ)));
bdc193ba 2689
f056076f
BD
2690 -- Otherwise, no discriminant to process
2691
2feb1f84 2692 else
f056076f 2693 Discr_Constr := No_Elmt;
2feb1f84
AC
2694 end if;
2695
a25e72b5
AC
2696 while Present (Discr) and then Present (Discr_Constr) loop
2697 Discr_Val := Node (Discr_Constr);
2698
2699 -- The parent discriminant is renamed in the derived type,
2700 -- nothing to initialize.
3e582869 2701
a25e72b5
AC
2702 -- type Deriv_Typ (Discr : ...)
2703 -- is new Parent_Typ (Discr => Discr);
3e582869 2704
a25e72b5
AC
2705 if Is_Entity_Name (Discr_Val)
2706 and then Ekind (Entity (Discr_Val)) = E_Discriminant
3e582869 2707 then
a25e72b5
AC
2708 null;
2709
2710 -- When the parent discriminant is constrained at the type
2711 -- extension level, it does not appear in the derived type.
2712
2713 -- type Deriv_Typ (Discr : ...)
2714 -- is new Parent_Typ (Discr => Discr,
2715 -- Hidden_Discr => Expression);
3e582869 2716
a25e72b5
AC
2717 elsif Is_Completely_Hidden_Discriminant (Discr) then
2718 null;
2719
2720 -- Otherwise initialize the discriminant
2721
2722 else
2723 Discr_Init :=
3e582869 2724 Make_OK_Assignment_Statement (Loc,
a25e72b5
AC
2725 Name =>
2726 Make_Selected_Component (Loc,
2727 Prefix => New_Copy_Tree (Target),
2728 Selector_Name => New_Occurrence_Of (Discr, Loc)),
2729 Expression => New_Copy_Tree (Discr_Val));
3e582869 2730
a25e72b5 2731 Append_To (List, Discr_Init);
3e582869
AC
2732 end if;
2733
a25e72b5
AC
2734 Next_Elmt (Discr_Constr);
2735 Next_Discriminant (Discr);
3e582869
AC
2736 end loop;
2737
ddce04b8 2738 In_Aggr_Type := False;
a25e72b5 2739 Base_Typ := Base_Type (Par_Typ);
3e582869
AC
2740 end loop;
2741 end Init_Hidden_Discriminants;
2742
71129dde
AC
2743 --------------------------------
2744 -- Init_Visible_Discriminants --
2745 --------------------------------
2746
2747 procedure Init_Visible_Discriminants is
2748 Discriminant : Entity_Id;
2749 Discriminant_Value : Node_Id;
2750
2751 begin
2752 Discriminant := First_Discriminant (Typ);
2753 while Present (Discriminant) loop
2754 Comp_Expr :=
2755 Make_Selected_Component (Loc,
2756 Prefix => New_Copy_Tree (Target),
2757 Selector_Name => New_Occurrence_Of (Discriminant, Loc));
2758
2759 Discriminant_Value :=
2760 Get_Discriminant_Value
2761 (Discriminant, Typ, Discriminant_Constraint (N_Typ));
2762
2763 Instr :=
2764 Make_OK_Assignment_Statement (Loc,
2765 Name => Comp_Expr,
2766 Expression => New_Copy_Tree (Discriminant_Value));
2767
71129dde
AC
2768 Append_To (L, Instr);
2769
2770 Next_Discriminant (Discriminant);
2771 end loop;
2772 end Init_Visible_Discriminants;
2773
2774 -------------------------------
2775 -- Init_Stored_Discriminants --
2776 -------------------------------
2777
2778 procedure Init_Stored_Discriminants is
2779 Discriminant : Entity_Id;
2780 Discriminant_Value : Node_Id;
2781
2782 begin
2783 Discriminant := First_Stored_Discriminant (Typ);
2784 while Present (Discriminant) loop
2785 Comp_Expr :=
2786 Make_Selected_Component (Loc,
2787 Prefix => New_Copy_Tree (Target),
2788 Selector_Name => New_Occurrence_Of (Discriminant, Loc));
2789
2790 Discriminant_Value :=
2791 Get_Discriminant_Value
2792 (Discriminant, N_Typ, Discriminant_Constraint (N_Typ));
2793
2794 Instr :=
2795 Make_OK_Assignment_Statement (Loc,
2796 Name => Comp_Expr,
2797 Expression => New_Copy_Tree (Discriminant_Value));
2798
71129dde
AC
2799 Append_To (L, Instr);
2800
2801 Next_Stored_Discriminant (Discriminant);
2802 end loop;
2803 end Init_Stored_Discriminants;
2804
937e9676
AC
2805 -------------------------
2806 -- Is_Int_Range_Bounds --
2807 -------------------------
2808
2809 function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
2810 begin
2811 return Nkind (Bounds) = N_Range
2812 and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
2813 and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
2814 end Is_Int_Range_Bounds;
f2abc637 2815
0f95b178
JM
2816 ------------------
2817 -- Replace_Type --
2818 ------------------
2819
2820 function Replace_Type (Expr : Node_Id) return Traverse_Result is
2821 begin
acf63f8c
ES
2822 -- Note regarding the Root_Type test below: Aggregate components for
2823 -- self-referential types include attribute references to the current
2824 -- instance, of the form: Typ'access, etc.. These references are
2825 -- rewritten as references to the target of the aggregate: the
2826 -- left-hand side of an assignment, the entity in a declaration,
2827 -- or a temporary. Without this test, we would improperly extended
2828 -- this rewriting to attribute references whose prefix was not the
2829 -- type of the aggregate.
2830
0f95b178 2831 if Nkind (Expr) = N_Attribute_Reference
acf63f8c 2832 and then Is_Entity_Name (Prefix (Expr))
0f95b178 2833 and then Is_Type (Entity (Prefix (Expr)))
acf63f8c 2834 and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr)))
0f95b178
JM
2835 then
2836 if Is_Entity_Name (Lhs) then
304757d2 2837 Rewrite (Prefix (Expr), New_Occurrence_Of (Entity (Lhs), Loc));
0f95b178
JM
2838
2839 else
2840 Rewrite (Expr,
2841 Make_Attribute_Reference (Loc,
2842 Attribute_Name => Name_Unrestricted_Access,
2843 Prefix => New_Copy_Tree (Lhs)));
2844 Set_Analyzed (Parent (Expr), False);
2845 end if;
2846 end if;
2847
2848 return OK;
2849 end Replace_Type;
2850
937e9676
AC
2851 --------------------------
2852 -- Rewrite_Discriminant --
2853 --------------------------
2854
2855 function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
2856 begin
2857 if Is_Entity_Name (Expr)
2858 and then Present (Entity (Expr))
2859 and then Ekind (Entity (Expr)) = E_In_Parameter
2860 and then Present (Discriminal_Link (Entity (Expr)))
2861 and then Scope (Discriminal_Link (Entity (Expr))) =
2862 Base_Type (Etype (N))
2863 then
2864 Rewrite (Expr,
2865 Make_Selected_Component (Loc,
2866 Prefix => New_Copy_Tree (Lhs),
2867 Selector_Name => Make_Identifier (Loc, Chars (Expr))));
b8411279
ES
2868
2869 -- The generated code will be reanalyzed, but if the reference
2870 -- to the discriminant appears within an already analyzed
2871 -- expression (e.g. a conditional) we must set its proper entity
2872 -- now. Context is an initialization procedure.
2873
2874 Analyze (Expr);
937e9676
AC
2875 end if;
2876
2877 return OK;
2878 end Rewrite_Discriminant;
0f95b178 2879
f2abc637
AC
2880 procedure Replace_Discriminants is
2881 new Traverse_Proc (Rewrite_Discriminant);
2882
937e9676
AC
2883 procedure Replace_Self_Reference is
2884 new Traverse_Proc (Replace_Type);
2885
70482933
RK
2886 -- Start of processing for Build_Record_Aggr_Code
2887
2888 begin
0f95b178
JM
2889 if Has_Self_Reference (N) then
2890 Replace_Self_Reference (N);
2891 end if;
2892
2893 -- If the target of the aggregate is class-wide, we must convert it
2894 -- to the actual type of the aggregate, so that the proper components
2895 -- are visible. We know already that the types are compatible.
2896
2897 if Present (Etype (Lhs))
26a43556 2898 and then Is_Class_Wide_Type (Etype (Lhs))
0f95b178
JM
2899 then
2900 Target := Unchecked_Convert_To (Typ, Lhs);
2901 else
2902 Target := Lhs;
2903 end if;
2904
3b9fa2df
ES
2905 -- Deal with the ancestor part of extension aggregates or with the
2906 -- discriminants of the root type.
70482933
RK
2907
2908 if Nkind (N) = N_Extension_Aggregate then
2909 declare
df3e68b1 2910 Ancestor : constant Node_Id := Ancestor_Part (N);
2168d7cc 2911 Adj_Call : Node_Id;
df3e68b1 2912 Assign : List_Id;
70482933
RK
2913
2914 begin
70482933 2915 -- If the ancestor part is a subtype mark "T", we generate
fbf5a39b 2916
df3e68b1
HK
2917 -- init-proc (T (tmp)); if T is constrained and
2918 -- init-proc (S (tmp)); where S applies an appropriate
2919 -- constraint if T is unconstrained
70482933 2920
df3e68b1
HK
2921 if Is_Entity_Name (Ancestor)
2922 and then Is_Type (Entity (Ancestor))
2923 then
70482933
RK
2924 Ancestor_Is_Subtype_Mark := True;
2925
df3e68b1
HK
2926 if Is_Constrained (Entity (Ancestor)) then
2927 Init_Typ := Entity (Ancestor);
70482933 2928
3b9fa2df
ES
2929 -- For an ancestor part given by an unconstrained type mark,
2930 -- create a subtype constrained by appropriate corresponding
2931 -- discriminant values coming from either associations of the
2932 -- aggregate or a constraint on a parent type. The subtype will
2933 -- be used to generate the correct default value for the
2934 -- ancestor part.
70482933 2935
df3e68b1 2936 elsif Has_Discriminants (Entity (Ancestor)) then
70482933 2937 declare
df3e68b1 2938 Anc_Typ : constant Entity_Id := Entity (Ancestor);
fbf5a39b
AC
2939 Anc_Constr : constant List_Id := New_List;
2940 Discrim : Entity_Id;
70482933
RK
2941 Disc_Value : Node_Id;
2942 New_Indic : Node_Id;
2943 Subt_Decl : Node_Id;
fbf5a39b 2944
70482933 2945 begin
fbf5a39b 2946 Discrim := First_Discriminant (Anc_Typ);
70482933
RK
2947 while Present (Discrim) loop
2948 Disc_Value := Ancestor_Discriminant_Value (Discrim);
aab45d22
AC
2949
2950 -- If no usable discriminant in ancestors, check
2951 -- whether aggregate has an explicit value for it.
2952
2953 if No (Disc_Value) then
2954 Disc_Value :=
2955 Get_Explicit_Discriminant_Value (Discrim);
2956 end if;
2957
70482933
RK
2958 Append_To (Anc_Constr, Disc_Value);
2959 Next_Discriminant (Discrim);
2960 end loop;
2961
2962 New_Indic :=
2963 Make_Subtype_Indication (Loc,
2964 Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc),
2965 Constraint =>
2966 Make_Index_Or_Discriminant_Constraint (Loc,
2967 Constraints => Anc_Constr));
2968
2969 Init_Typ := Create_Itype (Ekind (Anc_Typ), N);
2970
2971 Subt_Decl :=
2972 Make_Subtype_Declaration (Loc,
2973 Defining_Identifier => Init_Typ,
2974 Subtype_Indication => New_Indic);
2975
3b9fa2df
ES
2976 -- Itypes must be analyzed with checks off Declaration
2977 -- must have a parent for proper handling of subsidiary
2978 -- actions.
70482933 2979
07fc65c4 2980 Set_Parent (Subt_Decl, N);
70482933
RK
2981 Analyze (Subt_Decl, Suppress => All_Checks);
2982 end;
2983 end if;
2984
2985 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2986 Set_Assignment_OK (Ref);
2987
64425dff 2988 if not Is_Interface (Init_Typ) then
3bb3f6d6
AC
2989 Append_List_To (L,
2990 Build_Initialization_Call (Loc,
2991 Id_Ref => Ref,
2992 Typ => Init_Typ,
2993 In_Init_Proc => Within_Init_Proc,
2994 With_Default_Init => Has_Default_Init_Comps (N)
2995 or else
2996 Has_Task (Base_Type (Init_Typ))));
2997
df3e68b1
HK
2998 if Is_Constrained (Entity (Ancestor))
2999 and then Has_Discriminants (Entity (Ancestor))
3bb3f6d6 3000 then
df3e68b1 3001 Check_Ancestor_Discriminants (Entity (Ancestor));
3bb3f6d6 3002 end if;
f7937111
GD
3003
3004 -- If ancestor type has Default_Initialization_Condition,
3005 -- add a DIC check after the ancestor object is initialized
3006 -- by default.
3007
3008 if Has_DIC (Entity (Ancestor))
3009 and then Present (DIC_Procedure (Entity (Ancestor)))
3010 then
3011 Append_To (L,
3012 Build_DIC_Call
3013 (Loc, New_Copy_Tree (Ref), Entity (Ancestor)));
3014 end if;
70482933
RK
3015 end if;
3016
11795185
JM
3017 -- Handle calls to C++ constructors
3018
df3e68b1
HK
3019 elsif Is_CPP_Constructor_Call (Ancestor) then
3020 Init_Typ := Etype (Ancestor);
11795185
JM
3021 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
3022 Set_Assignment_OK (Ref);
3023
3024 Append_List_To (L,
3025 Build_Initialization_Call (Loc,
3026 Id_Ref => Ref,
3027 Typ => Init_Typ,
3028 In_Init_Proc => Within_Init_Proc,
3029 With_Default_Init => Has_Default_Init_Comps (N),
df3e68b1 3030 Constructor_Ref => Ancestor));
11795185 3031
c5ee5ad2
BD
3032 -- Ada 2005 (AI-287): If the ancestor part is an aggregate of
3033 -- limited type, a recursive call expands the ancestor. Note that
3034 -- in the limited case, the ancestor part must be either a
d4dfb005
BD
3035 -- function call (possibly qualified) or aggregate (definitely
3036 -- qualified).
65356e64 3037
df3e68b1 3038 elsif Is_Limited_Type (Etype (Ancestor))
4a08c95c
AC
3039 and then Nkind (Unqualify (Ancestor)) in
3040 N_Aggregate | N_Extension_Aggregate
c5ee5ad2 3041 then
65356e64
AC
3042 Ancestor_Is_Expression := True;
3043
21d7ef70 3044 -- Set up finalization data for enclosing record, because
3b9fa2df
ES
3045 -- controlled subcomponents of the ancestor part will be
3046 -- attached to it.
3047
df3e68b1 3048 Generate_Finalization_Actions;
3b9fa2df 3049
7b9d0d69 3050 Append_List_To (L,
f7e6fc47
RD
3051 Build_Record_Aggr_Code
3052 (N => Unqualify (Ancestor),
3053 Typ => Etype (Unqualify (Ancestor)),
3054 Lhs => Target));
65356e64 3055
70482933 3056 -- If the ancestor part is an expression "E", we generate
3b9fa2df 3057
df3e68b1 3058 -- T (tmp) := E;
3b9fa2df 3059
c5ee5ad2
BD
3060 -- In Ada 2005, this includes the case of a (possibly qualified)
3061 -- limited function call. The assignment will turn into a
3b9fa2df 3062 -- build-in-place function call (for further details, see
c5ee5ad2 3063 -- Make_Build_In_Place_Call_In_Assignment).
70482933
RK
3064
3065 else
3066 Ancestor_Is_Expression := True;
df3e68b1 3067 Init_Typ := Etype (Ancestor);
70482933 3068
7b9d0d69
ES
3069 -- If the ancestor part is an aggregate, force its full
3070 -- expansion, which was delayed.
3071
4a08c95c
AC
3072 if Nkind (Unqualify (Ancestor)) in
3073 N_Aggregate | N_Extension_Aggregate
7b9d0d69 3074 then
df3e68b1
HK
3075 Set_Analyzed (Ancestor, False);
3076 Set_Analyzed (Expression (Ancestor), False);
7b9d0d69
ES
3077 end if;
3078
3079 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
3080 Set_Assignment_OK (Ref);
3081
376e7d14
AC
3082 -- Make the assignment without usual controlled actions, since
3083 -- we only want to Adjust afterwards, but not to Finalize
3084 -- beforehand. Add manual Adjust when necessary.
7b9d0d69
ES
3085
3086 Assign := New_List (
3087 Make_OK_Assignment_Statement (Loc,
3088 Name => Ref,
df3e68b1 3089 Expression => Ancestor));
7b9d0d69
ES
3090 Set_No_Ctrl_Actions (First (Assign));
3091
3092 -- Assign the tag now to make sure that the dispatching call in
535a8637
AC
3093 -- the subsequent deep_adjust works properly (unless
3094 -- Tagged_Type_Expansion where tags are implicit).
70482933 3095
1f110335 3096 if Tagged_Type_Expansion then
70482933 3097 Instr :=
af10c962
EB
3098 Make_Tag_Assignment_From_Type
3099 (Loc, New_Copy_Tree (Target), Base_Type (Typ));
70482933 3100
7b9d0d69 3101 Append_To (Assign, Instr);
0f95b178
JM
3102
3103 -- Ada 2005 (AI-251): If tagged type has progenitors we must
3104 -- also initialize tags of the secondary dispatch tables.
3105
ce2b6ba5 3106 if Has_Interfaces (Base_Type (Typ)) then
0f95b178 3107 Init_Secondary_Tags
ed323421
AC
3108 (Typ => Base_Type (Typ),
3109 Target => Target,
3110 Stmts_List => Assign,
fe683ef6 3111 Init_Tags_List => Assign);
0f95b178 3112 end if;
70482933
RK
3113 end if;
3114
7b9d0d69 3115 -- Call Adjust manually
70482933 3116
df3e68b1
HK
3117 if Needs_Finalization (Etype (Ancestor))
3118 and then not Is_Limited_Type (Etype (Ancestor))
d4dfb005 3119 and then not Is_Build_In_Place_Function_Call (Ancestor)
3b9fa2df 3120 then
2168d7cc 3121 Adj_Call :=
37368818
RD
3122 Make_Adjust_Call
3123 (Obj_Ref => New_Copy_Tree (Ref),
2168d7cc
AC
3124 Typ => Etype (Ancestor));
3125
3126 -- Guard against a missing [Deep_]Adjust when the ancestor
3127 -- type was not properly frozen.
3128
3129 if Present (Adj_Call) then
3130 Append_To (Assign, Adj_Call);
3131 end if;
70482933
RK
3132 end if;
3133
70482933 3134 Append_To (L,
7b9d0d69 3135 Make_Unsuppress_Block (Loc, Name_Discriminant_Check, Assign));
70482933
RK
3136
3137 if Has_Discriminants (Init_Typ) then
3138 Check_Ancestor_Discriminants (Init_Typ);
3139 end if;
3140 end if;
d4dfb005
BD
3141
3142 pragma Assert (Nkind (N) = N_Extension_Aggregate);
3143 pragma Assert
3144 (not (Ancestor_Is_Expression and Ancestor_Is_Subtype_Mark));
70482933
RK
3145 end;
3146
376e7d14
AC
3147 -- Generate assignments of hidden discriminants. If the base type is
3148 -- an unchecked union, the discriminants are unknown to the back-end
3149 -- and absent from a value of the type, so assignments for them are
3150 -- not emitted.
3e582869
AC
3151
3152 if Has_Discriminants (Typ)
3153 and then not Is_Unchecked_Union (Base_Type (Typ))
3154 then
3155 Init_Hidden_Discriminants (Typ, L);
3156 end if;
3157
fbf5a39b
AC
3158 -- Normal case (not an extension aggregate)
3159
70482933
RK
3160 else
3161 -- Generate the discriminant expressions, component by component.
3162 -- If the base type is an unchecked union, the discriminants are
3163 -- unknown to the back-end and absent from a value of the type, so
3164 -- assignments for them are not emitted.
3165
3166 if Has_Discriminants (Typ)
3167 and then not Is_Unchecked_Union (Base_Type (Typ))
3168 then
3e582869 3169 Init_Hidden_Discriminants (Typ, L);
d8f7b976
ES
3170
3171 -- Generate discriminant init values for the visible discriminants
70482933 3172
71129dde 3173 Init_Visible_Discriminants;
70482933 3174
71129dde
AC
3175 if Is_Derived_Type (N_Typ) then
3176 Init_Stored_Discriminants;
3177 end if;
70482933
RK
3178 end if;
3179 end if;
3180
28541488
JM
3181 -- For CPP types we generate an implicit call to the C++ default
3182 -- constructor to ensure the proper initialization of the _Tag
3183 -- component.
3184
36a66365 3185 if Is_CPP_Class (Root_Type (Typ)) and then CPP_Num_Prims (Typ) > 0 then
cefce34c 3186 Invoke_Constructor : declare
15f0f591 3187 CPP_Parent : constant Entity_Id := Enclosing_CPP_Parent (Typ);
cefce34c
JM
3188
3189 procedure Invoke_IC_Proc (T : Entity_Id);
3190 -- Recursive routine used to climb to parents. Required because
3191 -- parents must be initialized before descendants to ensure
3192 -- propagation of inherited C++ slots.
3193
3194 --------------------
3195 -- Invoke_IC_Proc --
3196 --------------------
3197
3198 procedure Invoke_IC_Proc (T : Entity_Id) is
3199 begin
3200 -- Avoid generating extra calls. Initialization required
3201 -- only for types defined from the level of derivation of
3202 -- type of the constructor and the type of the aggregate.
3203
3204 if T = CPP_Parent then
3205 return;
3206 end if;
3207
3208 Invoke_IC_Proc (Etype (T));
3209
3210 -- Generate call to the IC routine
3211
3212 if Present (CPP_Init_Proc (T)) then
3213 Append_To (L,
3214 Make_Procedure_Call_Statement (Loc,
ffcfb997 3215 Name => New_Occurrence_Of (CPP_Init_Proc (T), Loc)));
cefce34c
JM
3216 end if;
3217 end Invoke_IC_Proc;
3218
3219 -- Start of processing for Invoke_Constructor
3220
3221 begin
3222 -- Implicit invocation of the C++ constructor
3223
3224 if Nkind (N) = N_Aggregate then
3225 Append_To (L,
3226 Make_Procedure_Call_Statement (Loc,
37368818
RD
3227 Name =>
3228 New_Occurrence_Of (Base_Init_Proc (CPP_Parent), Loc),
cefce34c
JM
3229 Parameter_Associations => New_List (
3230 Unchecked_Convert_To (CPP_Parent,
3231 New_Copy_Tree (Lhs)))));
3232 end if;
3233
3234 Invoke_IC_Proc (Typ);
3235 end Invoke_Constructor;
28541488
JM
3236 end if;
3237
70482933
RK
3238 -- Generate the assignments, component by component
3239
3240 -- tmp.comp1 := Expr1_From_Aggr;
3241 -- tmp.comp2 := Expr2_From_Aggr;
3242 -- ....
3243
3244 Comp := First (Component_Associations (N));
3245 while Present (Comp) loop
b7e429ab 3246 Selector := Entity (First (Choices (Comp)));
df0ac6e1 3247 pragma Assert (Present (Selector));
70482933 3248
236fecbf
JM
3249 -- C++ constructors
3250
3251 if Is_CPP_Constructor_Call (Expression (Comp)) then
3252 Append_List_To (L,
3253 Build_Initialization_Call (Loc,
37368818
RD
3254 Id_Ref =>
3255 Make_Selected_Component (Loc,
3256 Prefix => New_Copy_Tree (Target),
3257 Selector_Name => New_Occurrence_Of (Selector, Loc)),
1c612f29
RD
3258 Typ => Etype (Selector),
3259 Enclos_Type => Typ,
236fecbf 3260 With_Default_Init => True,
1c612f29 3261 Constructor_Ref => Expression (Comp)));
236fecbf 3262
736f9bed
PT
3263 elsif Box_Present (Comp)
3264 and then Needs_Simple_Initialization (Etype (Selector))
3265 then
3266 Comp_Expr :=
3267 Make_Selected_Component (Loc,
3268 Prefix => New_Copy_Tree (Target),
3269 Selector_Name => New_Occurrence_Of (Selector, Loc));
3270
fc84947c
EB
3271 Initialize_Simple_Component
3272 (N => N,
3273 Comp => Comp_Expr,
736f9bed
PT
3274 Comp_Typ => Etype (Selector),
3275 Init_Expr => Get_Simple_Init_Val
3276 (Typ => Etype (Selector),
3277 N => Comp,
3278 Size =>
3279 (if Known_Esize (Selector)
3280 then Esize (Selector)
3281 else Uint_0)),
3282 Stmts => L);
3283
3b9fa2df 3284 -- Ada 2005 (AI-287): For each default-initialized component generate
52739835 3285 -- a call to the corresponding IP subprogram if available.
65356e64 3286
236fecbf 3287 elsif Box_Present (Comp)
52739835 3288 and then Has_Non_Null_Base_Init_Proc (Etype (Selector))
65356e64 3289 then
5277cab6 3290 if Ekind (Selector) /= E_Discriminant then
df3e68b1 3291 Generate_Finalization_Actions;
5277cab6
ES
3292 end if;
3293
0ab80019
AC
3294 -- Ada 2005 (AI-287): If the component type has tasks then
3295 -- generate the activation chain and master entities (except
3296 -- in case of an allocator because in that case these entities
3297 -- are generated by Build_Task_Allocate_Block_With_Init_Stmts).
c45b6ae0
AC
3298
3299 declare
91b1417d 3300 Ctype : constant Entity_Id := Etype (Selector);
1c612f29
RD
3301 Inside_Allocator : Boolean := False;
3302 P : Node_Id := Parent (N);
c45b6ae0
AC
3303
3304 begin
3305 if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
3306 while Present (P) loop
3307 if Nkind (P) = N_Allocator then
3308 Inside_Allocator := True;
3309 exit;
3310 end if;
3311
3312 P := Parent (P);
3313 end loop;
3314
3315 if not Inside_Init_Proc and not Inside_Allocator then
3316 Build_Activation_Chain_Entity (N);
c45b6ae0
AC
3317 end if;
3318 end if;
3319 end;
3320
65356e64
AC
3321 Append_List_To (L,
3322 Build_Initialization_Call (Loc,
1c612f29
RD
3323 Id_Ref => Make_Selected_Component (Loc,
3324 Prefix => New_Copy_Tree (Target),
3325 Selector_Name =>
3326 New_Occurrence_Of (Selector, Loc)),
3327 Typ => Etype (Selector),
3328 Enclos_Type => Typ,
c45b6ae0 3329 With_Default_Init => True));
65356e64 3330
7b9d0d69 3331 -- Prepare for component assignment
fbf5a39b 3332
236fecbf 3333 elsif Ekind (Selector) /= E_Discriminant
70482933
RK
3334 or else Nkind (N) = N_Extension_Aggregate
3335 then
7b9d0d69 3336 -- All the discriminants have now been assigned
3b9fa2df 3337
7b9d0d69
ES
3338 -- This is now a good moment to initialize and attach all the
3339 -- controllers. Their position may depend on the discriminants.
3340
5277cab6 3341 if Ekind (Selector) /= E_Discriminant then
df3e68b1 3342 Generate_Finalization_Actions;
7b9d0d69
ES
3343 end if;
3344
38171f43 3345 Comp_Type := Underlying_Type (Etype (Selector));
70482933
RK
3346 Comp_Expr :=
3347 Make_Selected_Component (Loc,
3348 Prefix => New_Copy_Tree (Target),
3349 Selector_Name => New_Occurrence_Of (Selector, Loc));
3350
4f061cf2 3351 Expr_Q := Unqualify (Expression (Comp));
70482933 3352
7b9d0d69
ES
3353 -- Now either create the assignment or generate the code for the
3354 -- inner aggregate top-down.
fbf5a39b 3355
70482933 3356 if Is_Delayed_Aggregate (Expr_Q) then
d8f7b976
ES
3357
3358 -- We have the following case of aggregate nesting inside
3359 -- an object declaration:
3360
3361 -- type Arr_Typ is array (Integer range <>) of ...;
3b9fa2df 3362
d8f7b976
ES
3363 -- type Rec_Typ (...) is record
3364 -- Obj_Arr_Typ : Arr_Typ (A .. B);
3365 -- end record;
3b9fa2df 3366
d8f7b976
ES
3367 -- Obj_Rec_Typ : Rec_Typ := (...,
3368 -- Obj_Arr_Typ => (X => (...), Y => (...)));
3369
3370 -- The length of the ranges of the aggregate and Obj_Add_Typ
3371 -- are equal (B - A = Y - X), but they do not coincide (X /=
3372 -- A and B /= Y). This case requires array sliding which is
3373 -- performed in the following manner:
3374
3375 -- subtype Arr_Sub is Arr_Typ (X .. Y);
3376 -- Temp : Arr_Sub;
3377 -- Temp (X) := (...);
3378 -- ...
3379 -- Temp (Y) := (...);
3380 -- Obj_Rec_Typ.Obj_Arr_Typ := Temp;
3381
5277cab6 3382 if Ekind (Comp_Type) = E_Array_Subtype
d8f7b976
ES
3383 and then Is_Int_Range_Bounds (Aggregate_Bounds (Expr_Q))
3384 and then Is_Int_Range_Bounds (First_Index (Comp_Type))
3385 and then not
5277cab6
ES
3386 Compatible_Int_Bounds
3387 (Agg_Bounds => Aggregate_Bounds (Expr_Q),
3388 Typ_Bounds => First_Index (Comp_Type))
d8f7b976 3389 then
5277cab6
ES
3390 -- Create the array subtype with bounds equal to those of
3391 -- the corresponding aggregate.
d8f7b976 3392
5277cab6 3393 declare
191fcb3a 3394 SubE : constant Entity_Id := Make_Temporary (Loc, 'T');
d8f7b976
ES
3395
3396 SubD : constant Node_Id :=
15f0f591
AC
3397 Make_Subtype_Declaration (Loc,
3398 Defining_Identifier => SubE,
3399 Subtype_Indication =>
3400 Make_Subtype_Indication (Loc,
3401 Subtype_Mark =>
e4494292 3402 New_Occurrence_Of (Etype (Comp_Type), Loc),
15f0f591
AC
3403 Constraint =>
3404 Make_Index_Or_Discriminant_Constraint
3405 (Loc,
3406 Constraints => New_List (
3407 New_Copy_Tree
3408 (Aggregate_Bounds (Expr_Q))))));
d8f7b976
ES
3409
3410 -- Create a temporary array of the above subtype which
3411 -- will be used to capture the aggregate assignments.
3412
faf387e1 3413 TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N);
d8f7b976
ES
3414
3415 TmpD : constant Node_Id :=
15f0f591
AC
3416 Make_Object_Declaration (Loc,
3417 Defining_Identifier => TmpE,
e4494292 3418 Object_Definition => New_Occurrence_Of (SubE, Loc));
d8f7b976
ES
3419
3420 begin
3421 Set_No_Initialization (TmpD);
3422 Append_To (L, SubD);
3423 Append_To (L, TmpD);
3424
5277cab6 3425 -- Expand aggregate into assignments to the temp array
d8f7b976
ES
3426
3427 Append_List_To (L,
3428 Late_Expansion (Expr_Q, Comp_Type,
e4494292 3429 New_Occurrence_Of (TmpE, Loc)));
d8f7b976
ES
3430
3431 -- Slide
3432
3433 Append_To (L,
3434 Make_Assignment_Statement (Loc,
3435 Name => New_Copy_Tree (Comp_Expr),
e4494292 3436 Expression => New_Occurrence_Of (TmpE, Loc)));
d8f7b976
ES
3437 end;
3438
3439 -- Normal case (sliding not required)
3440
3441 else
3442 Append_List_To (L,
df3e68b1 3443 Late_Expansion (Expr_Q, Comp_Type, Comp_Expr));
d8f7b976 3444 end if;
fbf5a39b 3445
5277cab6
ES
3446 -- Expr_Q is not delayed aggregate
3447
70482933 3448 else
f2abc637
AC
3449 if Has_Discriminants (Typ) then
3450 Replace_Discriminants (Expr_Q);
b3f5eef0
AC
3451
3452 -- If the component is an array type that depends on
3453 -- discriminants, and the expression is a single Others
3454 -- clause, create an explicit subtype for it because the
3455 -- backend has troubles recovering the actual bounds.
3456
3457 if Nkind (Expr_Q) = N_Aggregate
3458 and then Is_Array_Type (Comp_Type)
3459 and then Present (Component_Associations (Expr_Q))
3460 then
3461 declare
3462 Assoc : constant Node_Id :=
45ec05e1 3463 First (Component_Associations (Expr_Q));
b3f5eef0
AC
3464 Decl : Node_Id;
3465
3466 begin
f7f8e290
JM
3467 if Present (Assoc)
3468 and then
3469 Nkind (First (Choices (Assoc))) = N_Others_Choice
b3f5eef0
AC
3470 then
3471 Decl :=
3472 Build_Actual_Subtype_Of_Component
3473 (Comp_Type, Comp_Expr);
3474
3475 -- If the component type does not in fact depend on
3476 -- discriminants, the subtype declaration is empty.
3477
3478 if Present (Decl) then
3479 Append_To (L, Decl);
3480 Set_Etype (Comp_Expr, Defining_Entity (Decl));
3481 end if;
3482 end if;
3483 end;
3484 end if;
f2abc637
AC
3485 end if;
3486
c63a2ad6 3487 if Modify_Tree_For_C
a1e1820b
AC
3488 and then Nkind (Expr_Q) = N_Aggregate
3489 and then Is_Array_Type (Etype (Expr_Q))
3490 and then Present (First_Index (Etype (Expr_Q)))
3491 then
3492 declare
0c5c46a9 3493 Expr_Q_Type : constant Entity_Id := Etype (Expr_Q);
a1e1820b
AC
3494 begin
3495 Append_List_To (L,
3496 Build_Array_Aggr_Code
3497 (N => Expr_Q,
3498 Ctype => Component_Type (Expr_Q_Type),
3499 Index => First_Index (Expr_Q_Type),
3500 Into => Comp_Expr,
937e9676
AC
3501 Scalar_Comp =>
3502 Is_Scalar_Type (Component_Type (Expr_Q_Type))));
a1e1820b
AC
3503 end;
3504
3505 else
fc84947c
EB
3506 Initialize_Component
3507 (N => N,
3508 Comp => Comp_Expr,
3509 Comp_Typ => Etype (Selector),
3510 Init_Expr => Expr_Q,
3511 Stmts => L);
70482933
RK
3512 end if;
3513 end if;
fbf5a39b 3514
37368818 3515 -- comment would be good here ???
fbf5a39b
AC
3516
3517 elsif Ekind (Selector) = E_Discriminant
3518 and then Nkind (N) /= N_Extension_Aggregate
3519 and then Nkind (Parent (N)) = N_Component_Association
3520 and then Is_Constrained (Typ)
3521 then
3522 -- We must check that the discriminant value imposed by the
3523 -- context is the same as the value given in the subaggregate,
3524 -- because after the expansion into assignments there is no
3525 -- record on which to perform a regular discriminant check.
3526
3527 declare
3528 D_Val : Elmt_Id;
3529 Disc : Entity_Id;
3530
3531 begin
3532 D_Val := First_Elmt (Discriminant_Constraint (Typ));
3533 Disc := First_Discriminant (Typ);
fbf5a39b
AC
3534 while Chars (Disc) /= Chars (Selector) loop
3535 Next_Discriminant (Disc);
3536 Next_Elmt (D_Val);
3537 end loop;
3538
3539 pragma Assert (Present (D_Val));
3540
0f95b178
JM
3541 -- This check cannot performed for components that are
3542 -- constrained by a current instance, because this is not a
3543 -- value that can be compared with the actual constraint.
3544
3545 if Nkind (Node (D_Val)) /= N_Attribute_Reference
3546 or else not Is_Entity_Name (Prefix (Node (D_Val)))
3547 or else not Is_Type (Entity (Prefix (Node (D_Val))))
3548 then
3549 Append_To (L,
3550 Make_Raise_Constraint_Error (Loc,
3551 Condition =>
3552 Make_Op_Ne (Loc,
37368818 3553 Left_Opnd => New_Copy_Tree (Node (D_Val)),
0f95b178 3554 Right_Opnd => Expression (Comp)),
37368818 3555 Reason => CE_Discriminant_Check_Failed));
0f95b178
JM
3556
3557 else
3b9fa2df
ES
3558 -- Find self-reference in previous discriminant assignment,
3559 -- and replace with proper expression.
0f95b178
JM
3560
3561 declare
3562 Ass : Node_Id;
3563
3564 begin
3565 Ass := First (L);
3566 while Present (Ass) loop
3567 if Nkind (Ass) = N_Assignment_Statement
3568 and then Nkind (Name (Ass)) = N_Selected_Component
3569 and then Chars (Selector_Name (Name (Ass))) =
36a66365 3570 Chars (Disc)
0f95b178
JM
3571 then
3572 Set_Expression
3573 (Ass, New_Copy_Tree (Expression (Comp)));
3574 exit;
3575 end if;
3576 Next (Ass);
3577 end loop;
3578 end;
3579 end if;
fbf5a39b 3580 end;
70482933
RK
3581 end if;
3582
f7937111
GD
3583 -- If the component association was specified with a box and the
3584 -- component type has a Default_Initial_Condition, then generate
3585 -- a call to the DIC procedure.
3586
3587 if Has_DIC (Etype (Selector))
3588 and then Was_Default_Init_Box_Association (Comp)
3589 and then Present (DIC_Procedure (Etype (Selector)))
3590 then
3591 Append_To (L,
3592 Build_DIC_Call (Loc,
3593 Make_Selected_Component (Loc,
3594 Prefix => New_Copy_Tree (Target),
3595 Selector_Name => New_Occurrence_Of (Selector, Loc)),
3596 Etype (Selector)));
3597 end if;
3598
70482933
RK
3599 Next (Comp);
3600 end loop;
3601
bdc193ba
AC
3602 -- If the type is tagged, the tag needs to be initialized (unless we
3603 -- are in VM-mode where tags are implicit). It is done late in the
3604 -- initialization process because in some cases, we call the init
3605 -- proc of an ancestor which will not leave out the right tag.
70482933
RK
3606
3607 if Ancestor_Is_Expression then
3608 null;
3609
28541488
JM
3610 -- For CPP types we generated a call to the C++ default constructor
3611 -- before the components have been initialized to ensure the proper
3612 -- initialization of the _Tag component (see above).
3613
3614 elsif Is_CPP_Class (Typ) then
3615 null;
3616
1f110335 3617 elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
70482933 3618 Instr :=
af10c962
EB
3619 Make_Tag_Assignment_From_Type
3620 (Loc, New_Copy_Tree (Target), Base_Type (Typ));
70482933
RK
3621
3622 Append_To (L, Instr);
c5ee5ad2 3623
bdc193ba 3624 -- Ada 2005 (AI-251): If the tagged type has been derived from an
c5ee5ad2
BD
3625 -- abstract interfaces we must also initialize the tags of the
3626 -- secondary dispatch tables.
3627
ce2b6ba5 3628 if Has_Interfaces (Base_Type (Typ)) then
c5ee5ad2 3629 Init_Secondary_Tags
ed323421
AC
3630 (Typ => Base_Type (Typ),
3631 Target => Target,
3632 Stmts_List => L,
fe683ef6 3633 Init_Tags_List => L);
c5ee5ad2 3634 end if;
70482933
RK
3635 end if;
3636
7b9d0d69
ES
3637 -- If the controllers have not been initialized yet (by lack of non-
3638 -- discriminant components), let's do it now.
70482933 3639
df3e68b1 3640 Generate_Finalization_Actions;
70482933 3641
7b9d0d69 3642 return L;
70482933
RK
3643 end Build_Record_Aggr_Code;
3644
3645 -------------------------------
3646 -- Convert_Aggr_In_Allocator --
3647 -------------------------------
3648
fa57ac97
ES
3649 procedure Convert_Aggr_In_Allocator
3650 (Alloc : Node_Id;
3651 Decl : Node_Id;
3652 Aggr : Node_Id)
3653 is
70482933
RK
3654 Loc : constant Source_Ptr := Sloc (Aggr);
3655 Typ : constant Entity_Id := Etype (Aggr);
3656 Temp : constant Entity_Id := Defining_Identifier (Decl);
fbf5a39b
AC
3657
3658 Occ : constant Node_Id :=
15f0f591 3659 Unchecked_Convert_To (Typ,
e4494292 3660 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Temp, Loc)));
70482933 3661
70482933 3662 begin
6f639c98
ES
3663 if Is_Array_Type (Typ) then
3664 Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ);
3665
3666 elsif Has_Default_Init_Comps (Aggr) then
c45b6ae0
AC
3667 declare
3668 L : constant List_Id := New_List;
3669 Init_Stmts : List_Id;
3670
3671 begin
df3e68b1 3672 Init_Stmts := Late_Expansion (Aggr, Typ, Occ);
c45b6ae0 3673
0f95b178
JM
3674 if Has_Task (Typ) then
3675 Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
fa57ac97 3676 Insert_Actions (Alloc, L);
0f95b178 3677 else
fa57ac97 3678 Insert_Actions (Alloc, Init_Stmts);
0f95b178 3679 end if;
c45b6ae0
AC
3680 end;
3681
3682 else
df3e68b1 3683 Insert_Actions (Alloc, Late_Expansion (Aggr, Typ, Occ));
c45b6ae0 3684 end if;
70482933
RK
3685 end Convert_Aggr_In_Allocator;
3686
3687 --------------------------------
3688 -- Convert_Aggr_In_Assignment --
3689 --------------------------------
3690
3691 procedure Convert_Aggr_In_Assignment (N : Node_Id) is
4f061cf2 3692 Aggr : constant Node_Id := Unqualify (Expression (N));
3b9fa2df
ES
3693 Typ : constant Entity_Id := Etype (Aggr);
3694 Occ : constant Node_Id := New_Copy_Tree (Name (N));
70482933
RK
3695
3696 begin
df3e68b1 3697 Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
70482933
RK
3698 end Convert_Aggr_In_Assignment;
3699
3700 ---------------------------------
3701 -- Convert_Aggr_In_Object_Decl --
3702 ---------------------------------
3703
3704 procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is
3705 Obj : constant Entity_Id := Defining_Identifier (N);
4f061cf2 3706 Aggr : constant Node_Id := Unqualify (Expression (N));
70482933
RK
3707 Loc : constant Source_Ptr := Sloc (Aggr);
3708 Typ : constant Entity_Id := Etype (Aggr);
3709 Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
3710
fff7a6d9
AC
3711 Has_Transient_Scope : Boolean := False;
3712
fbf5a39b
AC
3713 function Discriminants_Ok return Boolean;
3714 -- If the object type is constrained, the discriminants in the
3715 -- aggregate must be checked against the discriminants of the subtype.
3716 -- This cannot be done using Apply_Discriminant_Checks because after
3717 -- expansion there is no aggregate left to check.
3718
3719 ----------------------
3720 -- Discriminants_Ok --
3721 ----------------------
3722
3723 function Discriminants_Ok return Boolean is
3724 Cond : Node_Id := Empty;
3725 Check : Node_Id;
3726 D : Entity_Id;
3727 Disc1 : Elmt_Id;
3728 Disc2 : Elmt_Id;
3729 Val1 : Node_Id;
3730 Val2 : Node_Id;
3731
3732 begin
3733 D := First_Discriminant (Typ);
3734 Disc1 := First_Elmt (Discriminant_Constraint (Typ));
3735 Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj)));
fbf5a39b
AC
3736 while Present (Disc1) and then Present (Disc2) loop
3737 Val1 := Node (Disc1);
3738 Val2 := Node (Disc2);
3739
3740 if not Is_OK_Static_Expression (Val1)
3741 or else not Is_OK_Static_Expression (Val2)
3742 then
3743 Check := Make_Op_Ne (Loc,
3744 Left_Opnd => Duplicate_Subexpr (Val1),
3745 Right_Opnd => Duplicate_Subexpr (Val2));
3746
3747 if No (Cond) then
3748 Cond := Check;
3749
3750 else
3751 Cond := Make_Or_Else (Loc,
3752 Left_Opnd => Cond,
3753 Right_Opnd => Check);
3754 end if;
3755
3756 elsif Expr_Value (Val1) /= Expr_Value (Val2) then
3757 Apply_Compile_Time_Constraint_Error (Aggr,
324ac540 3758 Msg => "incorrect value for discriminant&??",
fbf5a39b
AC
3759 Reason => CE_Discriminant_Check_Failed,
3760 Ent => D);
3761 return False;
3762 end if;
3763
3764 Next_Discriminant (D);
3765 Next_Elmt (Disc1);
3766 Next_Elmt (Disc2);
3767 end loop;
3768
d940c627 3769 -- If any discriminant constraint is nonstatic, emit a check
fbf5a39b
AC
3770
3771 if Present (Cond) then
3772 Insert_Action (N,
3773 Make_Raise_Constraint_Error (Loc,
3774 Condition => Cond,
ef1c0511 3775 Reason => CE_Discriminant_Check_Failed));
fbf5a39b
AC
3776 end if;
3777
3778 return True;
3779 end Discriminants_Ok;
3780
3781 -- Start of processing for Convert_Aggr_In_Object_Decl
3782
70482933
RK
3783 begin
3784 Set_Assignment_OK (Occ);
3785
fbf5a39b
AC
3786 if Has_Discriminants (Typ)
3787 and then Typ /= Etype (Obj)
3788 and then Is_Constrained (Etype (Obj))
3789 and then not Discriminants_Ok
3790 then
3791 return;
3792 end if;
3793
0f95b178
JM
3794 -- If the context is an extended return statement, it has its own
3795 -- finalization machinery (i.e. works like a transient scope) and
3796 -- we do not want to create an additional one, because objects on
3797 -- the finalization list of the return must be moved to the caller's
3798 -- finalization list to complete the return.
3799
fff7a6d9 3800 -- Similarly if the aggregate is limited, it is built in place, and the
3b9fa2df
ES
3801 -- controlled components are not assigned to intermediate temporaries
3802 -- so there is no need for a transient scope in this case either.
3803
0f95b178
JM
3804 if Requires_Transient_Scope (Typ)
3805 and then Ekind (Current_Scope) /= E_Return_Statement
3b9fa2df 3806 and then not Is_Limited_Type (Typ)
0f95b178 3807 then
6560f851 3808 Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False);
fff7a6d9 3809 Has_Transient_Scope := True;
6f5c2c4b 3810 end if;
02217452 3811
6f5c2c4b 3812 declare
fff7a6d9
AC
3813 Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ);
3814 Stmt : Node_Id;
3815 Param : Node_Id;
3816
6f5c2c4b 3817 begin
fff7a6d9
AC
3818 -- If Obj is already frozen or if N is wrapped in a transient scope,
3819 -- Stmts do not need to be saved in Initialization_Statements since
3820 -- there is no freezing issue.
3821
3822 if Is_Frozen (Obj) or else Has_Transient_Scope then
3823 Insert_Actions_After (N, Stmts);
3824 else
3825 Stmt := Make_Compound_Statement (Sloc (N), Actions => Stmts);
3826 Insert_Action_After (N, Stmt);
3827
3828 -- Insert_Action_After may freeze Obj in which case we should
3829 -- remove the compound statement just created and simply insert
3830 -- Stmts after N.
3831
3832 if Is_Frozen (Obj) then
3833 Remove (Stmt);
3834 Insert_Actions_After (N, Stmts);
3835 else
3836 Set_Initialization_Statements (Obj, Stmt);
3837 end if;
3838 end if;
3839
3840 -- If Typ has controlled components and a call to a Slice_Assign
3841 -- procedure is part of the initialization statements, then we
3842 -- need to initialize the array component since Slice_Assign will
3843 -- need to adjust it.
3844
3845 if Has_Controlled_Component (Typ) then
3846 Stmt := First (Stmts);
3847
3848 while Present (Stmt) loop
3849 if Nkind (Stmt) = N_Procedure_Call_Statement
f82fb002 3850 and then Is_TSS (Entity (Name (Stmt)), TSS_Slice_Assign)
fff7a6d9
AC
3851 then
3852 Param := First (Parameter_Associations (Stmt));
3853 Insert_Actions
3854 (Stmt,
3855 Build_Initialization_Call
3856 (Sloc (N), New_Copy_Tree (Param), Etype (Param)));
3857 end if;
3858
3859 Next (Stmt);
3860 end loop;
3861 end if;
6f5c2c4b 3862 end;
6560f851 3863
70482933 3864 Set_No_Initialization (N);
a671959b
ES
3865
3866 -- After expansion the expression can be removed from the declaration
3867 -- except if the object is class-wide, in which case the aggregate
3868 -- provides the actual type.
3869
3870 if not Is_Class_Wide_Type (Etype (Obj)) then
3871 Set_Expression (N, Empty);
3872 end if;
3873
07fc65c4 3874 Initialize_Discriminants (N, Typ);
70482933
RK
3875 end Convert_Aggr_In_Object_Decl;
3876
6f639c98 3877 -------------------------------------
3b9fa2df 3878 -- Convert_Array_Aggr_In_Allocator --
6f639c98
ES
3879 -------------------------------------
3880
3881 procedure Convert_Array_Aggr_In_Allocator
3882 (Decl : Node_Id;
3883 Aggr : Node_Id;
3884 Target : Node_Id)
3885 is
6f639c98
ES
3886 Typ : constant Entity_Id := Etype (Aggr);
3887 Ctyp : constant Entity_Id := Component_Type (Typ);
2fedcc18
EB
3888 Aggr_Code : List_Id;
3889 New_Aggr : Node_Id;
6f639c98
ES
3890
3891 begin
2fedcc18
EB
3892 -- The target is an explicit dereference of the allocated object
3893
3894 -- If the assignment can be done directly by the back end, then
3895 -- reset Set_Expansion_Delayed and do not expand further.
3896
3897 if not CodePeer_Mode
3898 and then not Modify_Tree_For_C
3899 and then Aggr_Assignment_OK_For_Backend (Aggr)
3900 then
3901 New_Aggr := New_Copy_Tree (Aggr);
3902 Set_Expansion_Delayed (New_Aggr, False);
3903
742084ad
MP
3904 -- In the case of Target's type using the Designated_Storage_Model
3905 -- aspect with a Copy_To procedure, insert a temporary and have the
3906 -- back end handle the assignment to it. Copy the result to the
3907 -- original target.
3908
3909 if Has_Designated_Storage_Model_Aspect
3910 (Etype (Prefix (Expression (Target))))
3911 and then Present (Storage_Model_Copy_To
3912 (Storage_Model_Object
3913 (Etype (Prefix (Expression (Target))))))
3914 then
ca4bff3a
EB
3915 Aggr_Code :=
3916 Build_Assignment_With_Temporary (Target, Typ, New_Aggr);
3917
742084ad
MP
3918 else
3919 Aggr_Code :=
3920 New_List (
3921 Make_OK_Assignment_Statement (Sloc (New_Aggr),
3922 Name => Target,
3923 Expression => New_Aggr));
3924 end if;
6f639c98 3925
2fedcc18
EB
3926 -- Or else, generate component assignments to it, as for an aggregate
3927 -- that appears on the right-hand side of an assignment statement.
2fedcc18
EB
3928 else
3929 Aggr_Code :=
3930 Build_Array_Aggr_Code (Aggr,
3931 Ctype => Ctyp,
3932 Index => First_Index (Typ),
3933 Into => Target,
3934 Scalar_Comp => Is_Scalar_Type (Ctyp));
3935 end if;
6f639c98
ES
3936
3937 Insert_Actions_After (Decl, Aggr_Code);
3938 end Convert_Array_Aggr_In_Allocator;
3939
4ff5aa0c
AC
3940 ------------------------
3941 -- In_Place_Assign_OK --
3942 ------------------------
3943
a80b1eb7
EB
3944 function In_Place_Assign_OK
3945 (N : Node_Id;
3946 Target_Object : Entity_Id := Empty) return Boolean
3947 is
4ff5aa0c
AC
3948 Is_Array : constant Boolean := Is_Array_Type (Etype (N));
3949
a80b1eb7 3950 Aggr_In : Node_Id;
7c4f3267 3951 Aggr_Bounds : Range_Nodes;
a80b1eb7 3952 Obj_In : Node_Id;
7c4f3267 3953 Obj_Bounds : Range_Nodes;
a80b1eb7
EB
3954 Parent_Kind : Node_Kind;
3955 Parent_Node : Node_Id;
4ff5aa0c
AC
3956
3957 function Safe_Aggregate (Aggr : Node_Id) return Boolean;
3958 -- Check recursively that each component of a (sub)aggregate does not
3959 -- depend on the variable being assigned to.
3960
3961 function Safe_Component (Expr : Node_Id) return Boolean;
a80b1eb7
EB
3962 -- Verify that an expression cannot depend on the target being assigned
3963 -- to. Return true for compile-time known values, stand-alone objects,
3964 -- parameters passed by copy, calls to functions that return by copy,
3965 -- selected components thereof only if the aggregate's type is an array,
3966 -- indexed components and slices thereof only if the aggregate's type is
3967 -- a record, and simple expressions involving only these as operands.
3968 -- This is OK whatever the target because, for a component to overlap
3969 -- with the target, it must be either a direct reference to a component
3970 -- of the target, in which case there must be a matching selection or
3971 -- indexation or slicing, or an indirect reference to such a component,
3972 -- which is excluded by the above condition. Additionally, if the target
3973 -- is statically known, return true for arbitrarily nested selections,
3974 -- indexations or slicings, provided that their ultimate prefix is not
3975 -- the target itself.
4ff5aa0c
AC
3976
3977 --------------------
3978 -- Safe_Aggregate --
3979 --------------------
3980
3981 function Safe_Aggregate (Aggr : Node_Id) return Boolean is
3982 Expr : Node_Id;
3983
3984 begin
3985 if Nkind (Parent (Aggr)) = N_Iterated_Component_Association then
3986 return False;
3987 end if;
3988
3989 if Present (Expressions (Aggr)) then
3990 Expr := First (Expressions (Aggr));
3991 while Present (Expr) loop
3992 if Nkind (Expr) = N_Aggregate then
3993 if not Safe_Aggregate (Expr) then
3994 return False;
3995 end if;
3996
3997 elsif not Safe_Component (Expr) then
3998 return False;
3999 end if;
4000
4001 Next (Expr);
4002 end loop;
4003 end if;
4004
4005 if Present (Component_Associations (Aggr)) then
4006 Expr := First (Component_Associations (Aggr));
4007 while Present (Expr) loop
4008 if Nkind (Expression (Expr)) = N_Aggregate then
4009 if not Safe_Aggregate (Expression (Expr)) then
4010 return False;
4011 end if;
4012
bc1146e5
HK
4013 -- If association has a box, no way to determine yet whether
4014 -- default can be assigned in place.
4ff5aa0c
AC
4015
4016 elsif Box_Present (Expr) then
4017 return False;
4018
4019 elsif not Safe_Component (Expression (Expr)) then
4020 return False;
4021 end if;
4022
4023 Next (Expr);
4024 end loop;
4025 end if;
4026
4027 return True;
4028 end Safe_Aggregate;
4029
4030 --------------------
4031 -- Safe_Component --
4032 --------------------
4033
4034 function Safe_Component (Expr : Node_Id) return Boolean is
4035 Comp : Node_Id := Expr;
4036
a80b1eb7
EB
4037 function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean;
4038 -- Do the recursive traversal, after copy. If T_OK is True, return
4039 -- True for a stand-alone object only if the target is statically
4040 -- known and distinct from the object. At the top level, we start
4041 -- with T_OK set to False and set it to True at a deeper level only
4042 -- if we cannot disambiguate the component here without statically
4043 -- knowing the target. Note that this is not optimal, we should do
4044 -- something along the lines of Denotes_Same_Prefix for that.
4ff5aa0c
AC
4045
4046 ---------------------
4047 -- Check_Component --
4048 ---------------------
4049
a80b1eb7
EB
4050 function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean
4051 is
4052
4053 function SDO (E : Entity_Id) return Uint;
4054 -- Return the Scope Depth Of the enclosing dynamic scope of E
4055
4056 ---------
4057 -- SDO --
4058 ---------
4059
4060 function SDO (E : Entity_Id) return Uint is
4061 begin
4062 return Scope_Depth (Enclosing_Dynamic_Scope (E));
4063 end SDO;
4064
4065 -- Start of processing for Check_Component
4066
4ff5aa0c 4067 begin
a80b1eb7 4068 if Is_Overloaded (C) then
4ff5aa0c 4069 return False;
a80b1eb7
EB
4070
4071 elsif Compile_Time_Known_Value (C) then
4072 return True;
4ff5aa0c
AC
4073 end if;
4074
a80b1eb7
EB
4075 case Nkind (C) is
4076 when N_Attribute_Reference =>
4077 return Check_Component (Prefix (C), T_OK);
4078
4079 when N_Function_Call =>
4080 if Nkind (Name (C)) = N_Explicit_Dereference then
4081 return not Returns_By_Ref (Etype (Name (C)));
4082 else
4083 return not Returns_By_Ref (Entity (Name (C)));
4084 end if;
4085
4086 when N_Indexed_Component | N_Slice =>
4087 -- In a target record, these operations cannot determine
4088 -- alone a component so we can recurse whatever the target.
4089 return Check_Component (Prefix (C), T_OK or else Is_Array);
4090
4091 when N_Selected_Component =>
4092 -- In a target array, this operation cannot determine alone
4093 -- a component so we can recurse whatever the target.
4094 return
4095 Check_Component (Prefix (C), T_OK or else not Is_Array);
4096
4097 when N_Type_Conversion | N_Unchecked_Type_Conversion =>
4098 return Check_Component (Expression (C), T_OK);
4ff5aa0c 4099
a80b1eb7
EB
4100 when N_Binary_Op =>
4101 return Check_Component (Left_Opnd (C), T_OK)
4102 and then Check_Component (Right_Opnd (C), T_OK);
4ff5aa0c 4103
a80b1eb7
EB
4104 when N_Unary_Op =>
4105 return Check_Component (Right_Opnd (C), T_OK);
4ff5aa0c 4106
a80b1eb7
EB
4107 when others =>
4108 if Is_Entity_Name (C) and then Is_Object (Entity (C)) then
4109 -- Case of a formal parameter component. It's either
4110 -- trivial if passed by copy or very annoying if not,
4111 -- because in the latter case it's almost equivalent
4112 -- to a dereference, so the path-based disambiguation
4113 -- logic is totally off and we always need the target.
4ff5aa0c 4114
a80b1eb7
EB
4115 if Is_Formal (Entity (C)) then
4116
4117 -- If it is passed by copy, then this is safe
4118
4119 if Mechanism (Entity (C)) = By_Copy then
4120 return True;
4121
4122 -- Otherwise, this is safe if the target is present
4123 -- and is at least as deeply nested as the component.
4124
4125 else
4126 return Present (Target_Object)
4127 and then not Is_Formal (Target_Object)
4128 and then SDO (Target_Object) >= SDO (Entity (C));
4129 end if;
4130
4131 -- For a renamed object, recurse
4132
4133 elsif Present (Renamed_Object (Entity (C))) then
4134 return
4135 Check_Component (Renamed_Object (Entity (C)), T_OK);
4136
4137 -- If this is safe whatever the target, we are done
4138
4139 elsif not T_OK then
4140 return True;
4141
4142 -- If there is no target or the component is the target,
4143 -- this is not safe.
4144
4145 elsif No (Target_Object)
4146 or else Entity (C) = Target_Object
4147 then
4148 return False;
4149
4150 -- Case of a formal parameter target. This is safe if it
4151 -- is at most as deeply nested as the component.
4152
4153 elsif Is_Formal (Target_Object) then
4154 return SDO (Target_Object) <= SDO (Entity (C));
4155
4156 -- For distinct stand-alone objects, this is safe
4157
4158 else
4159 return True;
4160 end if;
4ff5aa0c 4161
a80b1eb7 4162 -- For anything else than an object, this is not safe
4ff5aa0c 4163
a80b1eb7
EB
4164 else
4165 return False;
4166 end if;
4167 end case;
4ff5aa0c
AC
4168 end Check_Component;
4169
4170 -- Start of processing for Safe_Component
4171
4172 begin
4173 -- If the component appears in an association that may correspond
4174 -- to more than one element, it is not analyzed before expansion
4175 -- into assignments, to avoid side effects. We analyze, but do not
4176 -- resolve the copy, to obtain sufficient entity information for
4177 -- the checks that follow. If component is overloaded we assume
4178 -- an unsafe function call.
4179
4180 if not Analyzed (Comp) then
4181 if Is_Overloaded (Expr) then
4182 return False;
4ff5aa0c
AC
4183
4184 elsif Nkind (Expr) = N_Allocator then
4185
4186 -- For now, too complex to analyze
4187
4188 return False;
4189
bc1146e5
HK
4190 elsif Nkind (Parent (Expr)) = N_Iterated_Component_Association then
4191
4192 -- Ditto for iterated component associations, which in general
4193 -- require an enclosing loop and involve nonstatic expressions.
4ff5aa0c
AC
4194
4195 return False;
4196 end if;
4197
4198 Comp := New_Copy_Tree (Expr);
4199 Set_Parent (Comp, Parent (Expr));
4200 Analyze (Comp);
4201 end if;
4202
4203 if Nkind (Comp) = N_Aggregate then
4204 return Safe_Aggregate (Comp);
4205 else
a80b1eb7 4206 return Check_Component (Comp, False);
4ff5aa0c
AC
4207 end if;
4208 end Safe_Component;
4209
4210 -- Start of processing for In_Place_Assign_OK
4211
4212 begin
e67df677 4213 -- By-copy semantic cannot be guaranteed for controlled objects
4ff5aa0c 4214
e67df677 4215 if Needs_Finalization (Etype (N)) then
4ff5aa0c 4216 return False;
a80b1eb7 4217 end if;
4ff5aa0c 4218
a80b1eb7
EB
4219 Parent_Node := Parent (N);
4220 Parent_Kind := Nkind (Parent_Node);
4ff5aa0c 4221
a80b1eb7
EB
4222 if Parent_Kind = N_Qualified_Expression then
4223 Parent_Node := Parent (Parent_Node);
4224 Parent_Kind := Nkind (Parent_Node);
4225 end if;
4ff5aa0c 4226
a80b1eb7
EB
4227 -- On assignment, sliding can take place, so we cannot do the
4228 -- assignment in place unless the bounds of the aggregate are
4229 -- statically equal to those of the target.
4ff5aa0c 4230
a80b1eb7
EB
4231 -- If the aggregate is given by an others choice, the bounds are
4232 -- derived from the left-hand side, and the assignment is safe if
4233 -- the expression is.
4ff5aa0c 4234
a80b1eb7
EB
4235 if Is_Array
4236 and then Present (Component_Associations (N))
4237 and then not Is_Others_Aggregate (N)
4238 then
4ff5aa0c
AC
4239 Aggr_In := First_Index (Etype (N));
4240
d0e9248d
EB
4241 -- Context is an assignment
4242
a80b1eb7
EB
4243 if Parent_Kind = N_Assignment_Statement then
4244 Obj_In := First_Index (Etype (Name (Parent_Node)));
4ff5aa0c 4245
d0e9248d
EB
4246 -- Context is an allocator. Check the bounds of the aggregate against
4247 -- those of the designated type, except in the case where the type is
4248 -- unconstrained (and then we can directly return true, see below).
4249
4250 else pragma Assert (Parent_Kind = N_Allocator);
4251 declare
4252 Desig_Typ : constant Entity_Id :=
4253 Designated_Type (Etype (Parent_Node));
4254 begin
4255 if not Is_Constrained (Desig_Typ) then
4256 return True;
4257 end if;
4ff5aa0c 4258
d0e9248d
EB
4259 Obj_In := First_Index (Desig_Typ);
4260 end;
4ff5aa0c
AC
4261 end if;
4262
4263 while Present (Aggr_In) loop
7c4f3267
BD
4264 Aggr_Bounds := Get_Index_Bounds (Aggr_In);
4265 Obj_Bounds := Get_Index_Bounds (Obj_In);
4ff5aa0c 4266
a80b1eb7
EB
4267 -- We require static bounds for the target and a static matching
4268 -- of low bound for the aggregate.
4269
7c4f3267
BD
4270 if not Compile_Time_Known_Value (Obj_Bounds.First)
4271 or else not Compile_Time_Known_Value (Obj_Bounds.Last)
4272 or else not Compile_Time_Known_Value (Aggr_Bounds.First)
4273 or else Expr_Value (Aggr_Bounds.First) /=
4274 Expr_Value (Obj_Bounds.First)
4ff5aa0c
AC
4275 then
4276 return False;
4277
4278 -- For an assignment statement we require static matching of
4279 -- bounds. Ditto for an allocator whose qualified expression
4280 -- is a constrained type. If the expression in the allocator
4281 -- is an unconstrained array, we accept an upper bound that
4282 -- is not static, to allow for nonstatic expressions of the
4283 -- base type. Clearly there are further possibilities (with
4284 -- diminishing returns) for safely building arrays in place
4285 -- here.
4286
a80b1eb7
EB
4287 elsif Parent_Kind = N_Assignment_Statement
4288 or else Is_Constrained (Etype (Parent_Node))
4ff5aa0c 4289 then
7c4f3267
BD
4290 if not Compile_Time_Known_Value (Aggr_Bounds.Last)
4291 or else Expr_Value (Aggr_Bounds.Last) /=
4292 Expr_Value (Obj_Bounds.Last)
4ff5aa0c
AC
4293 then
4294 return False;
4295 end if;
4296 end if;
4297
4298 Next_Index (Aggr_In);
4299 Next_Index (Obj_In);
4300 end loop;
4301 end if;
4302
a80b1eb7
EB
4303 -- Now check the component values themselves, except for an allocator
4304 -- for which the target is newly allocated memory.
4ff5aa0c 4305
a80b1eb7
EB
4306 if Parent_Kind = N_Allocator then
4307 return True;
4308 else
4309 return Safe_Aggregate (N);
4310 end if;
4ff5aa0c
AC
4311 end In_Place_Assign_OK;
4312
70482933
RK
4313 ----------------------------
4314 -- Convert_To_Assignments --
4315 ----------------------------
4316
4317 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
4318 Loc : constant Source_Ptr := Sloc (N);
39f346aa 4319 T : Entity_Id;
70482933
RK
4320 Temp : Entity_Id;
4321
f29afe5f 4322 Aggr_Code : List_Id;
fbf5a39b
AC
4323 Instr : Node_Id;
4324 Target_Expr : Node_Id;
4325 Parent_Kind : Node_Kind;
4326 Unc_Decl : Boolean := False;
4327 Parent_Node : Node_Id;
70482933
RK
4328
4329 begin
4a08c95c 4330 pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate);
fa57ac97
ES
4331 pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
4332 pragma Assert (Is_Record_Type (Typ));
4333
70482933
RK
4334 Parent_Node := Parent (N);
4335 Parent_Kind := Nkind (Parent_Node);
4336
4337 if Parent_Kind = N_Qualified_Expression then
d4dfb005 4338 -- Check if we are in an unconstrained declaration because in this
70482933 4339 -- case the current delayed expansion mechanism doesn't work when
d4dfb005 4340 -- the declared object size depends on the initializing expr.
70482933 4341
937e9676
AC
4342 Parent_Node := Parent (Parent_Node);
4343 Parent_Kind := Nkind (Parent_Node);
fbf5a39b 4344
937e9676
AC
4345 if Parent_Kind = N_Object_Declaration then
4346 Unc_Decl :=
4347 not Is_Entity_Name (Object_Definition (Parent_Node))
d4dfb005 4348 or else (Nkind (N) = N_Aggregate
3fc40cd7
PMR
4349 and then
4350 Has_Discriminants
4351 (Entity (Object_Definition (Parent_Node))))
937e9676
AC
4352 or else Is_Class_Wide_Type
4353 (Entity (Object_Definition (Parent_Node)));
4354 end if;
70482933
RK
4355 end if;
4356
3b9fa2df
ES
4357 -- Just set the Delay flag in the cases where the transformation will be
4358 -- done top down from above.
fbf5a39b 4359
f037632e 4360 if
fa57ac97 4361 -- Internal aggregate (transformed when expanding the parent)
8196b58e
MP
4362 -- excluding the Container aggregate as these are transformed to
4363 -- procedure call later.
0f95b178 4364
8196b58e
MP
4365 (Parent_Kind in
4366 N_Component_Association | N_Aggregate | N_Extension_Aggregate
4367 and then not Is_Container_Aggregate (Parent_Node))
0f95b178 4368
fa57ac97 4369 -- Allocator (see Convert_Aggr_In_Allocator)
70482933 4370
fa57ac97 4371 or else Parent_Kind = N_Allocator
0f95b178 4372
fa57ac97
ES
4373 -- Object declaration (see Convert_Aggr_In_Object_Decl)
4374
4375 or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
4376
4377 -- Safe assignment (see Convert_Aggr_Assignments). So far only the
4378 -- assignments in init procs are taken into account.
4379
4380 or else (Parent_Kind = N_Assignment_Statement
4381 and then Inside_Init_Proc)
4382
bdc193ba
AC
4383 -- (Ada 2005) An inherently limited type in a return statement, which
4384 -- will be handled in a build-in-place fashion, and may be rewritten
4385 -- as an extended return and have its own finalization machinery.
4386 -- In the case of a simple return, the aggregate needs to be delayed
4387 -- until the scope for the return statement has been created, so
4388 -- that any finalization chain will be associated with that scope.
4389 -- For extended returns, we delay expansion to avoid the creation
4390 -- of an unwanted transient scope that could result in premature
a9bbfbd0 4391 -- finalization of the return object (which is built in place
bdc193ba 4392 -- within the caller's scope).
fa57ac97 4393
d4dfb005 4394 or else Is_Build_In_Place_Aggregate_Return (N)
70482933
RK
4395 then
4396 Set_Expansion_Delayed (N);
4397 return;
4398 end if;
4399
a9bbfbd0
AC
4400 -- Otherwise, if a transient scope is required, create it now. If we
4401 -- are within an initialization procedure do not create such, because
4402 -- the target of the assignment must not be declared within a local
4403 -- block, and because cleanup will take place on return from the
4404 -- initialization procedure.
937e9676 4405
a9bbfbd0
AC
4406 -- Should the condition be more restrictive ???
4407
4408 if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then
6560f851 4409 Establish_Transient_Scope (N, Manage_Sec_Stack => False);
70482933
RK
4410 end if;
4411
bc1146e5
HK
4412 -- If the aggregate is nonlimited, create a temporary, since aggregates
4413 -- have "by copy" semantics. If it is limited and context is an
4ff5aa0c
AC
4414 -- assignment, this is a subaggregate for an enclosing aggregate being
4415 -- expanded. It must be built in place, so use target of the current
4416 -- assignment.
70482933 4417
3b9fa2df 4418 if Is_Limited_Type (Typ)
e67df677 4419 and then Parent_Kind = N_Assignment_Statement
3b9fa2df 4420 then
e67df677
EB
4421 Target_Expr := New_Copy_Tree (Name (Parent_Node));
4422 Insert_Actions (Parent_Node,
df3e68b1 4423 Build_Record_Aggr_Code (N, Typ, Target_Expr));
e67df677 4424 Rewrite (Parent_Node, Make_Null_Statement (Loc));
70482933 4425
a80b1eb7
EB
4426 -- Do not declare a temporary to initialize an aggregate assigned to
4427 -- a target when in-place assignment is possible, i.e. preserving the
4ff5aa0c
AC
4428 -- by-copy semantic of aggregates. This avoids large stack usage and
4429 -- generates more efficient code.
e64ac631 4430
e67df677 4431 elsif Parent_Kind = N_Assignment_Statement
a80b1eb7 4432 and then In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)))
e64ac631 4433 then
e67df677
EB
4434 declare
4435 Lhs : constant Node_Id := Name (Parent_Node);
4436 begin
4437 -- Apply discriminant check if required
4438
4439 if Has_Discriminants (Etype (N)) then
4440 Apply_Discriminant_Check (N, Etype (Lhs), Lhs);
4441 end if;
4442
4443 -- The check just above may have replaced the aggregate with a CE
4444
4a08c95c 4445 if Nkind (N) in N_Aggregate | N_Extension_Aggregate then
e67df677
EB
4446 Target_Expr := New_Copy_Tree (Lhs);
4447 Insert_Actions (Parent_Node,
4448 Build_Record_Aggr_Code (N, Typ, Target_Expr));
4449 Rewrite (Parent_Node, Make_Null_Statement (Loc));
4450 end if;
4451 end;
e64ac631 4452
3b9fa2df 4453 else
faf387e1 4454 Temp := Make_Temporary (Loc, 'A', N);
70482933 4455
39f346aa
ES
4456 -- If the type inherits unknown discriminants, use the view with
4457 -- known discriminants if available.
4458
4459 if Has_Unknown_Discriminants (Typ)
36a66365 4460 and then Present (Underlying_Record_View (Typ))
39f346aa
ES
4461 then
4462 T := Underlying_Record_View (Typ);
4463 else
4464 T := Typ;
4465 end if;
4466
3b9fa2df
ES
4467 Instr :=
4468 Make_Object_Declaration (Loc,
4469 Defining_Identifier => Temp,
39f346aa 4470 Object_Definition => New_Occurrence_Of (T, Loc));
3b9fa2df
ES
4471
4472 Set_No_Initialization (Instr);
4473 Insert_Action (N, Instr);
39f346aa 4474 Initialize_Discriminants (Instr, T);
f29afe5f 4475
3b9fa2df 4476 Target_Expr := New_Occurrence_Of (Temp, Loc);
f29afe5f
AC
4477 Aggr_Code := Build_Record_Aggr_Code (N, T, Target_Expr);
4478
4479 -- Save the last assignment statement associated with the aggregate
4480 -- when building a controlled object. This reference is utilized by
4481 -- the finalization machinery when marking an object as successfully
4482 -- initialized.
4483
4484 if Needs_Finalization (T) then
4485 Set_Last_Aggregate_Assignment (Temp, Last (Aggr_Code));
4486 end if;
4487
4488 Insert_Actions (N, Aggr_Code);
3b9fa2df 4489 Rewrite (N, New_Occurrence_Of (Temp, Loc));
39f346aa 4490 Analyze_And_Resolve (N, T);
3b9fa2df 4491 end if;
70482933
RK
4492 end Convert_To_Assignments;
4493
07fc65c4
GB
4494 ---------------------------
4495 -- Convert_To_Positional --
4496 ---------------------------
4497
4498 procedure Convert_To_Positional
c42006e9
AC
4499 (N : Node_Id;
4500 Handle_Bit_Packed : Boolean := False)
07fc65c4 4501 is
c42006e9 4502 Typ : constant Entity_Id := Etype (N);
b748c3d1 4503 Dims : constant Nat := Number_Dimensions (Typ);
eaf6e63a 4504 Max_Others_Replicate : constant Nat := Max_Aggregate_Size (N);
07fc65c4 4505
0f95b178
JM
4506 Static_Components : Boolean := True;
4507
4508 procedure Check_Static_Components;
3b9fa2df
ES
4509 -- Check whether all components of the aggregate are compile-time known
4510 -- values, and can be passed as is to the back-end without further
4511 -- expansion.
0f95b178 4512
fbf5a39b 4513 function Flatten
b748c3d1
EB
4514 (N : Node_Id;
4515 Dims : Nat;
4516 Ix : Node_Id;
4517 Ixb : Node_Id) return Boolean;
c2ba82ad
EB
4518 -- Convert the aggregate into a purely positional form if possible after
4519 -- checking that the bounds of all dimensions are known to be static.
fbf5a39b 4520
b748c3d1
EB
4521 function Is_Flat (N : Node_Id; Dims : Nat) return Boolean;
4522 -- Return True if the aggregate N is flat (which is not trivial in the
4523 -- case of multidimensional aggregates).
fbf5a39b 4524
b748c3d1 4525 function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean;
f1e2bf65
EB
4526 -- Return True if N, an element of a component association list, i.e.
4527 -- N_Component_Association or N_Iterated_Component_Association, has a
4528 -- compile-time known value and can be passed as is to the back-end
4529 -- without further expansion.
4530 -- An Iterated_Component_Association is treated as nonstatic in most
4531 -- cases for now, so there are possibilities for optimization.
4532
0f95b178
JM
4533 -----------------------------
4534 -- Check_Static_Components --
4535 -----------------------------
4536
bdc193ba
AC
4537 -- Could use some comments in this body ???
4538
0f95b178 4539 procedure Check_Static_Components is
f1e2bf65
EB
4540 Assoc : Node_Id;
4541 Expr : Node_Id;
0f95b178
JM
4542
4543 begin
4544 Static_Components := True;
4545
4546 if Nkind (N) = N_String_Literal then
4547 null;
4548
4549 elsif Present (Expressions (N)) then
4550 Expr := First (Expressions (N));
4551 while Present (Expr) loop
4552 if Nkind (Expr) /= N_Aggregate
4553 or else not Compile_Time_Known_Aggregate (Expr)
4554 or else Expansion_Delayed (Expr)
4555 then
4556 Static_Components := False;
4557 exit;
4558 end if;
4559
4560 Next (Expr);
4561 end loop;
4562 end if;
4563
4564 if Nkind (N) = N_Aggregate
21d7ef70 4565 and then Present (Component_Associations (N))
0f95b178 4566 then
f1e2bf65
EB
4567 Assoc := First (Component_Associations (N));
4568 while Present (Assoc) loop
b748c3d1 4569 if not Is_Static_Element (Assoc, Dims) then
0f95b178
JM
4570 Static_Components := False;
4571 exit;
4572 end if;
4573
f1e2bf65 4574 Next (Assoc);
0f95b178
JM
4575 end loop;
4576 end if;
4577 end Check_Static_Components;
4578
fbf5a39b
AC
4579 -------------
4580 -- Flatten --
4581 -------------
4582
4583 function Flatten
b748c3d1
EB
4584 (N : Node_Id;
4585 Dims : Nat;
4586 Ix : Node_Id;
4587 Ixb : Node_Id) return Boolean
fbf5a39b
AC
4588 is
4589 Loc : constant Source_Ptr := Sloc (N);
4590 Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb));
4591 Lo : constant Node_Id := Type_Low_Bound (Etype (Ix));
4592 Hi : constant Node_Id := Type_High_Bound (Etype (Ix));
fbf5a39b 4593
b748c3d1
EB
4594 function Cannot_Flatten_Next_Aggr (Expr : Node_Id) return Boolean;
4595 -- Return true if Expr is an aggregate for the next dimension that
4596 -- cannot be recursively flattened.
4597
4598 ------------------------------
4599 -- Cannot_Flatten_Next_Aggr --
4600 ------------------------------
4601
4602 function Cannot_Flatten_Next_Aggr (Expr : Node_Id) return Boolean is
4603 begin
4604 return Nkind (Expr) = N_Aggregate
4605 and then Present (Next_Index (Ix))
4606 and then not
4607 Flatten (Expr, Dims - 1, Next_Index (Ix), Next_Index (Ixb));
4608 end Cannot_Flatten_Next_Aggr;
4609
4610 -- Local variables
4611
4612 Lov : Uint;
4613 Hiv : Uint;
4614 Others_Present : Boolean;
4615
4616 -- Start of processing for Flatten
3f5a8fee 4617
6e937c1c 4618 begin
fbf5a39b
AC
4619 if Nkind (Original_Node (N)) = N_String_Literal then
4620 return True;
4621 end if;
07fc65c4 4622
0f95b178
JM
4623 if not Compile_Time_Known_Value (Lo)
4624 or else not Compile_Time_Known_Value (Hi)
4625 then
4626 return False;
4627 end if;
07fc65c4 4628
fbf5a39b
AC
4629 Lov := Expr_Value (Lo);
4630 Hiv := Expr_Value (Hi);
07fc65c4 4631
3f5a8fee
AC
4632 -- Check if there is an others choice
4633
b748c3d1
EB
4634 Others_Present := False;
4635
3f5a8fee 4636 if Present (Component_Associations (N)) then
10c257af
ES
4637 if Is_Empty_List (Component_Associations (N)) then
4638 -- an expanded null array aggregate
4639 return False;
4640 end if;
4641
3f5a8fee
AC
4642 declare
4643 Assoc : Node_Id;
4644 Choice : Node_Id;
4645
4646 begin
4647 Assoc := First (Component_Associations (N));
4648 while Present (Assoc) loop
9f8d1e5c
AC
4649
4650 -- If this is a box association, flattening is in general
4651 -- not possible because at this point we cannot tell if the
4652 -- default is static or even exists.
4653
4654 if Box_Present (Assoc) then
4655 return False;
00f45f30
AC
4656
4657 elsif Nkind (Assoc) = N_Iterated_Component_Association then
4658 return False;
9f8d1e5c
AC
4659 end if;
4660
00f45f30 4661 Choice := First (Choice_List (Assoc));
3f5a8fee
AC
4662
4663 while Present (Choice) loop
4664 if Nkind (Choice) = N_Others_Choice then
4665 Others_Present := True;
4666 end if;
4667
4668 Next (Choice);
4669 end loop;
4670
4671 Next (Assoc);
4672 end loop;
4673 end;
4674 end if;
4675
4676 -- If the low bound is not known at compile time and others is not
4677 -- present we can proceed since the bounds can be obtained from the
4678 -- aggregate.
4679
fbf5a39b 4680 if Hiv < Lov
36a66365 4681 or else (not Compile_Time_Known_Value (Blo) and then Others_Present)
fbf5a39b
AC
4682 then
4683 return False;
4684 end if;
07fc65c4 4685
3b9fa2df
ES
4686 -- Determine if set of alternatives is suitable for conversion and
4687 -- build an array containing the values in sequence.
07fc65c4 4688
fbf5a39b
AC
4689 declare
4690 Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv))
4691 of Node_Id := (others => Empty);
4692 -- The values in the aggregate sorted appropriately
07fc65c4 4693
fbf5a39b
AC
4694 Vlist : List_Id;
4695 -- Same data as Vals in list form
07fc65c4 4696
fbf5a39b
AC
4697 Rep_Count : Nat;
4698 -- Used to validate Max_Others_Replicate limit
07fc65c4 4699
841dd0f5 4700 Elmt : Node_Id;
b748c3d1 4701 Expr : Node_Id;
841dd0f5
AC
4702 Num : Int := UI_To_Int (Lov);
4703 Choice_Index : Int;
4704 Choice : Node_Id;
4705 Lo, Hi : Node_Id;
07fc65c4 4706
fbf5a39b
AC
4707 begin
4708 if Present (Expressions (N)) then
4709 Elmt := First (Expressions (N));
fbf5a39b 4710 while Present (Elmt) loop
b748c3d1
EB
4711 -- In the case of a multidimensional array, check that the
4712 -- aggregate can be recursively flattened.
4713
4714 if Cannot_Flatten_Next_Aggr (Elmt) then
fbf5a39b
AC
4715 return False;
4716 end if;
07fc65c4 4717
f537fc00 4718 -- Duplicate expression for each index it covers
1541ede1
ES
4719
4720 Vals (Num) := New_Copy_Tree (Elmt);
fbf5a39b 4721 Num := Num + 1;
07fc65c4 4722
fbf5a39b
AC
4723 Next (Elmt);
4724 end loop;
4725 end if;
07fc65c4 4726
fbf5a39b
AC
4727 if No (Component_Associations (N)) then
4728 return True;
4729 end if;
07fc65c4 4730
fbf5a39b 4731 Elmt := First (Component_Associations (N));
07fc65c4 4732
b748c3d1
EB
4733 Component_Loop : while Present (Elmt) loop
4734 Expr := Expression (Elmt);
4735
4736 -- In the case of a multidimensional array, check that the
4737 -- aggregate can be recursively flattened.
4738
4739 if Cannot_Flatten_Next_Aggr (Expr) then
fbf5a39b
AC
4740 return False;
4741 end if;
07fc65c4 4742
00f45f30 4743 Choice := First (Choice_List (Elmt));
fbf5a39b
AC
4744 Choice_Loop : while Present (Choice) loop
4745
4746 -- If we have an others choice, fill in the missing elements
4747 -- subject to the limit established by Max_Others_Replicate.
4748
4749 if Nkind (Choice) = N_Others_Choice then
4750 Rep_Count := 0;
4751
64a87aa5
EB
4752 -- If the expression involves a construct that generates
4753 -- a loop, we must generate individual assignments and
4754 -- no flattening is possible.
4755
b748c3d1 4756 if Nkind (Expr) = N_Quantified_Expression then
1f6237e3
ES
4757 return False;
4758 end if;
4759
fbf5a39b
AC
4760 for J in Vals'Range loop
4761 if No (Vals (J)) then
b748c3d1 4762 Vals (J) := New_Copy_Tree (Expr);
fbf5a39b
AC
4763 Rep_Count := Rep_Count + 1;
4764
4765 -- Check for maximum others replication. Note that
4766 -- we skip this test if either of the restrictions
b748c3d1 4767 -- No_Implicit_Loops or No_Elaboration_Code is
8926d369
AC
4768 -- active, if this is a preelaborable unit or
4769 -- a predefined unit, or if the unit must be
4770 -- placed in data memory. This also ensures that
d9819bbd
AC
4771 -- predefined units get the same level of constant
4772 -- folding in Ada 95 and Ada 2005, where their
4773 -- categorization has changed.
fbf5a39b
AC
4774
4775 declare
4776 P : constant Entity_Id :=
89beb653 4777 Cunit_Entity (Current_Sem_Unit);
fbf5a39b
AC
4778
4779 begin
f1e2bf65
EB
4780 -- Check if duplication is always OK and, if so,
4781 -- continue processing.
7f4c1903 4782
b748c3d1
EB
4783 if Restriction_Active (No_Implicit_Loops) then
4784 null;
4785
4786 -- If duplication is not always OK, continue
4787 -- only if either the element is static or is
4788 -- an aggregate (we already know it is OK).
4789
4790 elsif not Is_Static_Element (Elmt, Dims)
4791 and then Nkind (Expr) /= N_Aggregate
4792 then
4793 return False;
4794
4795 -- Check if duplication is OK for elaboration
4796 -- purposes and, if so, continue processing.
4797
4798 elsif Restriction_Active (No_Elaboration_Code)
d9819bbd
AC
4799 or else
4800 (Ekind (Current_Scope) = E_Package
b748c3d1
EB
4801 and then
4802 Static_Elaboration_Desired (Current_Scope))
fbf5a39b
AC
4803 or else Is_Preelaborated (P)
4804 or else (Ekind (P) = E_Package_Body
4805 and then
b748c3d1 4806 Is_Preelaborated (Spec_Entity (P)))
7f4c1903 4807 or else
8ab31c0c 4808 Is_Predefined_Unit (Get_Source_Unit (P))
fbf5a39b
AC
4809 then
4810 null;
6e937c1c 4811
b748c3d1
EB
4812 -- Otherwise, check that the replication count
4813 -- is not too high.
7f4c1903 4814
b748c3d1 4815 elsif Rep_Count > Max_Others_Replicate then
f1e2bf65 4816 return False;
fbf5a39b
AC
4817 end if;
4818 end;
4819 end if;
4820 end loop;
07fc65c4 4821
861e589e
ES
4822 if Rep_Count = 0
4823 and then Warn_On_Redundant_Constructs
4824 then
4825 Error_Msg_N ("there are no others?r?", Elmt);
4826 end if;
4827
fbf5a39b 4828 exit Component_Loop;
07fc65c4 4829
deeb1604 4830 -- Case of a subtype mark, identifier or expanded name
07fc65c4 4831
deeb1604 4832 elsif Is_Entity_Name (Choice)
fbf5a39b
AC
4833 and then Is_Type (Entity (Choice))
4834 then
4835 Lo := Type_Low_Bound (Etype (Choice));
4836 Hi := Type_High_Bound (Etype (Choice));
07fc65c4 4837
fbf5a39b 4838 -- Case of subtype indication
07fc65c4 4839
fbf5a39b
AC
4840 elsif Nkind (Choice) = N_Subtype_Indication then
4841 Lo := Low_Bound (Range_Expression (Constraint (Choice)));
4842 Hi := High_Bound (Range_Expression (Constraint (Choice)));
4843
4844 -- Case of a range
4845
4846 elsif Nkind (Choice) = N_Range then
4847 Lo := Low_Bound (Choice);
4848 Hi := High_Bound (Choice);
4849
4850 -- Normal subexpression case
4851
4852 else pragma Assert (Nkind (Choice) in N_Subexpr);
4853 if not Compile_Time_Known_Value (Choice) then
4854 return False;
4855
4856 else
841dd0f5 4857 Choice_Index := UI_To_Int (Expr_Value (Choice));
bdc193ba 4858
841dd0f5 4859 if Choice_Index in Vals'Range then
b748c3d1 4860 Vals (Choice_Index) := New_Copy_Tree (Expr);
841dd0f5
AC
4861 goto Continue;
4862
bdc193ba
AC
4863 -- Choice is statically out-of-range, will be
4864 -- rewritten to raise Constraint_Error.
841dd0f5 4865
bdc193ba 4866 else
841dd0f5
AC
4867 return False;
4868 end if;
07fc65c4 4869 end if;
fbf5a39b
AC
4870 end if;
4871
64425dff 4872 -- Range cases merge with Lo,Hi set
fbf5a39b
AC
4873
4874 if not Compile_Time_Known_Value (Lo)
4875 or else
4876 not Compile_Time_Known_Value (Hi)
4877 then
4878 return False;
bdc193ba 4879
fbf5a39b
AC
4880 else
4881 for J in UI_To_Int (Expr_Value (Lo)) ..
4882 UI_To_Int (Expr_Value (Hi))
4883 loop
b748c3d1 4884 Vals (J) := New_Copy_Tree (Expr);
fbf5a39b
AC
4885 end loop;
4886 end if;
07fc65c4 4887
fbf5a39b
AC
4888 <<Continue>>
4889 Next (Choice);
4890 end loop Choice_Loop;
07fc65c4 4891
fbf5a39b
AC
4892 Next (Elmt);
4893 end loop Component_Loop;
07fc65c4 4894
fbf5a39b 4895 -- If we get here the conversion is possible
07fc65c4 4896
fbf5a39b
AC
4897 Vlist := New_List;
4898 for J in Vals'Range loop
4899 Append (Vals (J), Vlist);
4900 end loop;
07fc65c4 4901
fbf5a39b
AC
4902 Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist));
4903 Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N)));
4904 return True;
4905 end;
4906 end Flatten;
07fc65c4 4907
fbf5a39b
AC
4908 -------------
4909 -- Is_Flat --
4910 -------------
07fc65c4 4911
b748c3d1 4912 function Is_Flat (N : Node_Id; Dims : Nat) return Boolean is
fbf5a39b 4913 Elmt : Node_Id;
07fc65c4 4914
fbf5a39b
AC
4915 begin
4916 if Dims = 0 then
4917 return True;
07fc65c4 4918
fbf5a39b
AC
4919 elsif Nkind (N) = N_Aggregate then
4920 if Present (Component_Associations (N)) then
4921 return False;
07fc65c4 4922
fbf5a39b
AC
4923 else
4924 Elmt := First (Expressions (N));
fbf5a39b
AC
4925 while Present (Elmt) loop
4926 if not Is_Flat (Elmt, Dims - 1) then
4927 return False;
07fc65c4 4928 end if;
07fc65c4 4929
fbf5a39b
AC
4930 Next (Elmt);
4931 end loop;
07fc65c4 4932
fbf5a39b
AC
4933 return True;
4934 end if;
4935 else
4936 return True;
4937 end if;
4938 end Is_Flat;
07fc65c4 4939
f1e2bf65
EB
4940 -------------------------
4941 -- Is_Static_Element --
4942 -------------------------
4943
b748c3d1 4944 function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean is
f1e2bf65
EB
4945 Expr : constant Node_Id := Expression (N);
4946
4947 begin
b748c3d1 4948 -- In most cases the interesting expressions are unambiguously static
f1e2bf65 4949
b748c3d1 4950 if Compile_Time_Known_Value (Expr) then
f1e2bf65
EB
4951 return True;
4952
4953 elsif Nkind (N) = N_Iterated_Component_Association then
4954 return False;
4955
4956 elsif Nkind (Expr) = N_Aggregate
4957 and then Compile_Time_Known_Aggregate (Expr)
4958 and then not Expansion_Delayed (Expr)
4959 then
4960 return True;
4961
b748c3d1
EB
4962 -- However, one may write static expressions that are syntactically
4963 -- ambiguous, so preanalyze the expression before checking it again,
4964 -- but only at the innermost level for a multidimensional array.
4965
4966 elsif Dims = 1 then
4967 Preanalyze_And_Resolve (Expr, Component_Type (Typ));
4968 return Compile_Time_Known_Value (Expr);
4969
f1e2bf65
EB
4970 else
4971 return False;
4972 end if;
4973 end Is_Static_Element;
4974
fbf5a39b 4975 -- Start of processing for Convert_To_Positional
07fc65c4 4976
fbf5a39b 4977 begin
6031f544
AC
4978 -- Only convert to positional when generating C in case of an
4979 -- object declaration, this is the only case where aggregates are
4980 -- supported in C.
4981
9f51b855 4982 if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
6031f544
AC
4983 return;
4984 end if;
4985
0ab80019 4986 -- Ada 2005 (AI-287): Do not convert in case of default initialized
c45b6ae0
AC
4987 -- components because in this case will need to call the corresponding
4988 -- IP procedure.
4989
4990 if Has_Default_Init_Comps (N) then
4991 return;
4992 end if;
4993
d7db3f4f
ES
4994 -- A subaggregate may have been flattened but is not known to be
4995 -- Compile_Time_Known. Set that flag in cases that cannot require
4996 -- elaboration code, so that the aggregate can be used as the
4997 -- initial value of a thread-local variable.
4998
b748c3d1 4999 if Is_Flat (N, Dims) then
2a1838cd
EB
5000 if Static_Array_Aggregate (N) then
5001 Set_Compile_Time_Known_Aggregate (N);
d7db3f4f
ES
5002 end if;
5003
fbf5a39b
AC
5004 return;
5005 end if;
5006
36a66365 5007 if Is_Bit_Packed_Array (Typ) and then not Handle_Bit_Packed then
fbf5a39b
AC
5008 return;
5009 end if;
07fc65c4 5010
3b9fa2df
ES
5011 -- Do not convert to positional if controlled components are involved
5012 -- since these require special processing
07fc65c4 5013
fbf5a39b
AC
5014 if Has_Controlled_Component (Typ) then
5015 return;
5016 end if;
07fc65c4 5017
0f95b178
JM
5018 Check_Static_Components;
5019
5020 -- If the size is known, or all the components are static, try to
5021 -- build a fully positional aggregate.
5022
21d7ef70 5023 -- The size of the type may not be known for an aggregate with
0f95b178
JM
5024 -- discriminated array components, but if the components are static
5025 -- it is still possible to verify statically that the length is
5026 -- compatible with the upper bound of the type, and therefore it is
5027 -- worth flattening such aggregates as well.
5028
eaf6e63a 5029 if Aggr_Size_OK (N)
b748c3d1
EB
5030 and then
5031 Flatten (N, Dims, First_Index (Typ), First_Index (Base_Type (Typ)))
643a0839 5032 then
0f95b178
JM
5033 if Static_Components then
5034 Set_Compile_Time_Known_Aggregate (N);
5035 Set_Expansion_Delayed (N, False);
5036 end if;
5037
07fc65c4 5038 Analyze_And_Resolve (N, Typ);
fbf5a39b 5039 end if;
d9819bbd 5040
d74716b3 5041 -- If Static_Elaboration_Desired has been specified, diagnose aggregates
e6807723
AC
5042 -- that will still require initialization code.
5043
d9819bbd
AC
5044 if (Ekind (Current_Scope) = E_Package
5045 and then Static_Elaboration_Desired (Current_Scope))
5046 and then Nkind (Parent (N)) = N_Object_Declaration
5047 then
5048 declare
5049 Expr : Node_Id;
5050
5051 begin
e6807723 5052 if Nkind (N) = N_Aggregate and then Present (Expressions (N)) then
d9819bbd
AC
5053 Expr := First (Expressions (N));
5054 while Present (Expr) loop
c2ba82ad 5055 if not Compile_Time_Known_Value (Expr) then
8926d369 5056 Error_Msg_N
21d7ef70 5057 ("non-static object requires elaboration code??", N);
d9819bbd
AC
5058 exit;
5059 end if;
8926d369 5060
d9819bbd
AC
5061 Next (Expr);
5062 end loop;
5063
5064 if Present (Component_Associations (N)) then
324ac540 5065 Error_Msg_N ("object requires elaboration code??", N);
d9819bbd
AC
5066 end if;
5067 end if;
5068 end;
5069 end if;
07fc65c4
GB
5070 end Convert_To_Positional;
5071
70482933
RK
5072 ----------------------------
5073 -- Expand_Array_Aggregate --
5074 ----------------------------
5075
5076 -- Array aggregate expansion proceeds as follows:
5077
5078 -- 1. If requested we generate code to perform all the array aggregate
5079 -- bound checks, specifically
5080
5081 -- (a) Check that the index range defined by aggregate bounds is
5082 -- compatible with corresponding index subtype.
5083
5084 -- (b) If an others choice is present check that no aggregate
5085 -- index is outside the bounds of the index constraint.
5086
5087 -- (c) For multidimensional arrays make sure that all subaggregates
5088 -- corresponding to the same dimension have the same bounds.
5089
fbf5a39b 5090 -- 2. Check for packed array aggregate which can be converted to a
b465ef6f 5091 -- constant so that the aggregate disappears completely.
fbf5a39b
AC
5092
5093 -- 3. Check case of nested aggregate. Generally nested aggregates are
5094 -- handled during the processing of the parent aggregate.
5095
5096 -- 4. Check if the aggregate can be statically processed. If this is the
70482933
RK
5097 -- case pass it as is to Gigi. Note that a necessary condition for
5098 -- static processing is that the aggregate be fully positional.
5099
bc1146e5 5100 -- 5. If in-place aggregate expansion is possible (i.e. no need to create
70482933
RK
5101 -- a temporary) then mark the aggregate as such and return. Otherwise
5102 -- create a new temporary and generate the appropriate initialization
5103 -- code.
5104
5105 procedure Expand_Array_Aggregate (N : Node_Id) is
5106 Loc : constant Source_Ptr := Sloc (N);
5107
5108 Typ : constant Entity_Id := Etype (N);
5109 Ctyp : constant Entity_Id := Component_Type (Typ);
07fc65c4 5110 -- Typ is the correct constrained array subtype of the aggregate
70482933
RK
5111 -- Ctyp is the corresponding component type.
5112
5113 Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
3cf3e5c6 5114 -- Number of aggregate index dimensions
70482933
RK
5115
5116 Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id;
5117 Aggr_High : array (1 .. Aggr_Dimension) of Node_Id;
3cf3e5c6 5118 -- Low and High bounds of the constraint for each aggregate index
70482933
RK
5119
5120 Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
3cf3e5c6 5121 -- The type of each index
70482933 5122
ac43e11e 5123 In_Place_Assign_OK_For_Declaration : Boolean := False;
bc1146e5 5124 -- True if we are to generate an in-place assignment for a declaration
ac43e11e 5125
70482933
RK
5126 Maybe_In_Place_OK : Boolean;
5127 -- If the type is neither controlled nor packed and the aggregate
5128 -- is the expression in an assignment, assignment in place may be
5129 -- possible, provided other conditions are met on the LHS.
5130
07fc65c4 5131 Others_Present : array (1 .. Aggr_Dimension) of Boolean :=
15f0f591 5132 (others => False);
d74716b3
AC
5133 -- If Others_Present (J) is True, then there is an others choice in one
5134 -- of the subaggregates of N at dimension J.
70482933
RK
5135
5136 procedure Build_Constrained_Type (Positional : Boolean);
5137 -- If the subtype is not static or unconstrained, build a constrained
5138 -- type using the computable sizes of the aggregate and its sub-
5139 -- aggregates.
5140
7c4f3267 5141 procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id);
70482933 5142 -- Checks that the bounds of Aggr_Bounds are within the bounds defined
3424f4c3
PT
5143 -- by Index_Bounds. For null array aggregate (Ada 2022) check that the
5144 -- aggregate bounds define a null range.
70482933
RK
5145
5146 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos);
d74716b3
AC
5147 -- Checks that in a multidimensional array aggregate all subaggregates
5148 -- corresponding to the same dimension have the same bounds. Sub_Aggr is
5149 -- an array subaggregate. Dim is the dimension corresponding to the
5150 -- subaggregate.
70482933
RK
5151
5152 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos);
d74716b3
AC
5153 -- Computes the values of array Others_Present. Sub_Aggr is the array
5154 -- subaggregate we start the computation from. Dim is the dimension
5155 -- corresponding to the subaggregate.
70482933 5156
70482933 5157 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
d74716b3 5158 -- Checks that if an others choice is present in any subaggregate, no
70482933 5159 -- aggregate index is outside the bounds of the index constraint.
d74716b3
AC
5160 -- Sub_Aggr is an array subaggregate. Dim is the dimension corresponding
5161 -- to the subaggregate.
70482933 5162
8da337c5
AC
5163 function Safe_Left_Hand_Side (N : Node_Id) return Boolean;
5164 -- In addition to Maybe_In_Place_OK, in order for an aggregate to be
5165 -- built directly into the target of the assignment it must be free
6537318f 5166 -- of side effects. N is the LHS of an assignment.
8da337c5 5167
fe43084c
ES
5168 procedure Two_Pass_Aggregate_Expansion (N : Node_Id);
5169 -- If the aggregate consists only of iterated associations then the
5170 -- aggregate is constructed in two steps:
5171 -- a) Build an expression to compute the number of elements
5172 -- generated by each iterator, and use the expression to allocate
5173 -- the destination aggregate.
5174 -- b) Generate the loops corresponding to each iterator to insert
5175 -- the elements in their proper positions.
5176
70482933
RK
5177 ----------------------------
5178 -- Build_Constrained_Type --
5179 ----------------------------
5180
5181 procedure Build_Constrained_Type (Positional : Boolean) is
c8def50f 5182 Agg_Type : constant Entity_Id := Make_Temporary (Loc, 'A');
fbf5a39b 5183 Decl : Node_Id;
c8def50f 5184 Indexes : constant List_Id := New_List;
b3143037 5185 Num : Nat;
fbf5a39b 5186 Sub_Agg : Node_Id;
70482933
RK
5187
5188 begin
70482933
RK
5189 -- If the aggregate is purely positional, all its subaggregates
5190 -- have the same size. We collect the dimensions from the first
5191 -- subaggregate at each level.
5192
5193 if Positional then
5194 Sub_Agg := N;
5195
c8def50f 5196 for D in 1 .. Aggr_Dimension loop
c8c37d2b 5197 Num := List_Length (Expressions (Sub_Agg));
70482933 5198
deeb1604 5199 Append_To (Indexes,
70482933 5200 Make_Range (Loc,
c8def50f 5201 Low_Bound => Make_Integer_Literal (Loc, Uint_1),
191fcb3a 5202 High_Bound => Make_Integer_Literal (Loc, Num)));
c8c37d2b
PT
5203
5204 Sub_Agg := First (Expressions (Sub_Agg));
70482933
RK
5205 end loop;
5206
5207 else
3b9fa2df
ES
5208 -- We know the aggregate type is unconstrained and the aggregate
5209 -- is not processable by the back end, therefore not necessarily
5210 -- positional. Retrieve each dimension bounds (computed earlier).
70482933 5211
c8def50f 5212 for D in 1 .. Aggr_Dimension loop
37368818 5213 Append_To (Indexes,
70482933 5214 Make_Range (Loc,
37368818
RD
5215 Low_Bound => Aggr_Low (D),
5216 High_Bound => Aggr_High (D)));
70482933
RK
5217 end loop;
5218 end if;
5219
5220 Decl :=
5221 Make_Full_Type_Declaration (Loc,
5222 Defining_Identifier => Agg_Type,
bdc193ba 5223 Type_Definition =>
70482933 5224 Make_Constrained_Array_Definition (Loc,
deeb1604
AC
5225 Discrete_Subtype_Definitions => Indexes,
5226 Component_Definition =>
a397db96 5227 Make_Component_Definition (Loc,
a397db96
AC
5228 Subtype_Indication =>
5229 New_Occurrence_Of (Component_Type (Typ), Loc))));
70482933
RK
5230
5231 Insert_Action (N, Decl);
5232 Analyze (Decl);
5233 Set_Etype (N, Agg_Type);
5234 Set_Is_Itype (Agg_Type);
5235 Freeze_Itype (Agg_Type, N);
5236 end Build_Constrained_Type;
5237
5238 ------------------
5239 -- Check_Bounds --
5240 ------------------
5241
7c4f3267
BD
5242 procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id) is
5243 Aggr_Bounds : constant Range_Nodes :=
5244 Get_Index_Bounds (Aggr_Bounds_Node);
5245 Ind_Bounds : constant Range_Nodes :=
5246 Get_Index_Bounds (Index_Bounds_Node);
70482933 5247
c8def50f 5248 Cond : Node_Id;
70482933
RK
5249
5250 begin
3424f4c3
PT
5251 -- For a null array aggregate check that high bound (i.e., low
5252 -- bound predecessor) exists. Fail if low bound is low bound of
5253 -- base subtype (in all cases, including modular).
5254
5255 if Is_Null_Aggregate (N) then
5256 Insert_Action (N,
5257 Make_Raise_Constraint_Error (Loc,
5258 Condition =>
5259 Make_Op_Eq (Loc,
5260 New_Copy_Tree (Aggr_Bounds.First),
5261 New_Copy_Tree
5262 (Type_Low_Bound (Base_Type (Etype (Ind_Bounds.First))))),
5263 Reason => CE_Range_Check_Failed));
5264 return;
5265 end if;
5266
70482933 5267 -- Generate the following test:
bdc193ba 5268
70482933 5269 -- [constraint_error when
7c4f3267
BD
5270 -- Aggr_Bounds.First <= Aggr_Bounds.Last and then
5271 -- (Aggr_Bounds.First < Ind_Bounds.First
5272 -- or else Aggr_Bounds.Last > Ind_Bounds.Last)]
3b9fa2df 5273
641d3093 5274 -- As an optimization try to see if some tests are trivially vacuous
70482933
RK
5275 -- because we are comparing an expression against itself.
5276
7c4f3267
BD
5277 if Aggr_Bounds.First = Ind_Bounds.First
5278 and then Aggr_Bounds.Last = Ind_Bounds.Last
5279 then
70482933
RK
5280 Cond := Empty;
5281
7c4f3267 5282 elsif Aggr_Bounds.Last = Ind_Bounds.Last then
70482933
RK
5283 Cond :=
5284 Make_Op_Lt (Loc,
7c4f3267
BD
5285 Left_Opnd =>
5286 Duplicate_Subexpr_Move_Checks (Aggr_Bounds.First),
5287 Right_Opnd =>
5288 Duplicate_Subexpr_Move_Checks (Ind_Bounds.First));
70482933 5289
7c4f3267 5290 elsif Aggr_Bounds.First = Ind_Bounds.First then
70482933
RK
5291 Cond :=
5292 Make_Op_Gt (Loc,
7c4f3267
BD
5293 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Bounds.Last),
5294 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Bounds.Last));
70482933
RK
5295
5296 else
5297 Cond :=
5298 Make_Or_Else (Loc,
5299 Left_Opnd =>
5300 Make_Op_Lt (Loc,
7c4f3267
BD
5301 Left_Opnd =>
5302 Duplicate_Subexpr_Move_Checks (Aggr_Bounds.First),
5303 Right_Opnd =>
5304 Duplicate_Subexpr_Move_Checks (Ind_Bounds.First)),
70482933
RK
5305
5306 Right_Opnd =>
5307 Make_Op_Gt (Loc,
7c4f3267
BD
5308 Left_Opnd => Duplicate_Subexpr (Aggr_Bounds.Last),
5309 Right_Opnd => Duplicate_Subexpr (Ind_Bounds.Last)));
70482933
RK
5310 end if;
5311
5312 if Present (Cond) then
5313 Cond :=
5314 Make_And_Then (Loc,
5315 Left_Opnd =>
5316 Make_Op_Le (Loc,
7c4f3267
BD
5317 Left_Opnd =>
5318 Duplicate_Subexpr_Move_Checks (Aggr_Bounds.First),
5319 Right_Opnd =>
5320 Duplicate_Subexpr_Move_Checks (Aggr_Bounds.Last)),
70482933
RK
5321
5322 Right_Opnd => Cond);
5323
5324 Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False);
5325 Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False);
5326 Insert_Action (N,
07fc65c4
GB
5327 Make_Raise_Constraint_Error (Loc,
5328 Condition => Cond,
8fdafe44 5329 Reason => CE_Range_Check_Failed));
70482933
RK
5330 end if;
5331 end Check_Bounds;
5332
5333 ----------------------------
5334 -- Check_Same_Aggr_Bounds --
5335 ----------------------------
5336
5337 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
8ba0b4cf
PT
5338 Sub_Bounds : constant Range_Nodes :=
5339 Get_Index_Bounds (Aggregate_Bounds (Sub_Aggr));
10c257af
ES
5340 Sub_Lo : Node_Id renames Sub_Bounds.First;
5341 Sub_Hi : Node_Id renames Sub_Bounds.Last;
d74716b3 5342 -- The bounds of this specific subaggregate
70482933
RK
5343
5344 Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
5345 Aggr_Hi : constant Node_Id := Aggr_High (Dim);
5346 -- The bounds of the aggregate for this dimension
5347
5348 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
3cf3e5c6 5349 -- The index type for this dimension.xxx
70482933 5350
8ba0b4cf 5351 Cond : Node_Id;
fbf5a39b
AC
5352 Assoc : Node_Id;
5353 Expr : Node_Id;
70482933
RK
5354
5355 begin
5356 -- If index checks are on generate the test
3b9fa2df 5357
70482933
RK
5358 -- [constraint_error when
5359 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
3b9fa2df 5360
70482933
RK
5361 -- As an optimization try to see if some tests are trivially vacuos
5362 -- because we are comparing an expression against itself. Also for
5363 -- the first dimension the test is trivially vacuous because there
5364 -- is just one aggregate for dimension 1.
5365
5366 if Index_Checks_Suppressed (Ind_Typ) then
5367 Cond := Empty;
5368
bdc193ba 5369 elsif Dim = 1 or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi)
70482933
RK
5370 then
5371 Cond := Empty;
5372
5373 elsif Aggr_Hi = Sub_Hi then
5374 Cond :=
5375 Make_Op_Ne (Loc,
fbf5a39b
AC
5376 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
5377 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo));
70482933
RK
5378
5379 elsif Aggr_Lo = Sub_Lo then
5380 Cond :=
5381 Make_Op_Ne (Loc,
fbf5a39b
AC
5382 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
5383 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi));
70482933
RK
5384
5385 else
5386 Cond :=
5387 Make_Or_Else (Loc,
5388 Left_Opnd =>
5389 Make_Op_Ne (Loc,
fbf5a39b
AC
5390 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
5391 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)),
70482933
RK
5392
5393 Right_Opnd =>
5394 Make_Op_Ne (Loc,
5395 Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
5396 Right_Opnd => Duplicate_Subexpr (Sub_Hi)));
5397 end if;
5398
5399 if Present (Cond) then
5400 Insert_Action (N,
07fc65c4
GB
5401 Make_Raise_Constraint_Error (Loc,
5402 Condition => Cond,
5403 Reason => CE_Length_Check_Failed));
70482933
RK
5404 end if;
5405
d74716b3 5406 -- Now look inside the subaggregate to see if there is more work
70482933
RK
5407
5408 if Dim < Aggr_Dimension then
5409
5410 -- Process positional components
5411
5412 if Present (Expressions (Sub_Aggr)) then
5413 Expr := First (Expressions (Sub_Aggr));
5414 while Present (Expr) loop
5415 Check_Same_Aggr_Bounds (Expr, Dim + 1);
5416 Next (Expr);
5417 end loop;
5418 end if;
5419
5420 -- Process component associations
5421
5422 if Present (Component_Associations (Sub_Aggr)) then
5423 Assoc := First (Component_Associations (Sub_Aggr));
5424 while Present (Assoc) loop
5425 Expr := Expression (Assoc);
5426 Check_Same_Aggr_Bounds (Expr, Dim + 1);
5427 Next (Assoc);
5428 end loop;
5429 end if;
5430 end if;
5431 end Check_Same_Aggr_Bounds;
5432
5433 ----------------------------
5434 -- Compute_Others_Present --
5435 ----------------------------
5436
5437 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is
fbf5a39b
AC
5438 Assoc : Node_Id;
5439 Expr : Node_Id;
70482933
RK
5440
5441 begin
5442 if Present (Component_Associations (Sub_Aggr)) then
5443 Assoc := Last (Component_Associations (Sub_Aggr));
07fc65c4 5444
10c257af
ES
5445 if Present (Assoc)
5446 and then Nkind (First (Choice_List (Assoc))) = N_Others_Choice
5447 then
70482933 5448 Others_Present (Dim) := True;
e84d25c9
ES
5449
5450 -- An others_clause may be superfluous if previous components
5451 -- cover the full given range of a constrained array. In such
5452 -- a case an others_clause does not contribute any additional
5453 -- components and has not been analyzed. We analyze it now to
5454 -- detect type errors in the expression, even though no code
5455 -- will be generated for it.
5456
5457 if Dim = Aggr_Dimension
5458 and then Nkind (Assoc) /= N_Iterated_Component_Association
5459 and then not Analyzed (Expression (Assoc))
5460 and then not Box_Present (Assoc)
5461 then
5462 Preanalyze_And_Resolve (Expression (Assoc), Ctyp);
5463 end if;
70482933
RK
5464 end if;
5465 end if;
5466
d74716b3 5467 -- Now look inside the subaggregate to see if there is more work
70482933
RK
5468
5469 if Dim < Aggr_Dimension then
5470
5471 -- Process positional components
5472
5473 if Present (Expressions (Sub_Aggr)) then
5474 Expr := First (Expressions (Sub_Aggr));
5475 while Present (Expr) loop
5476 Compute_Others_Present (Expr, Dim + 1);
5477 Next (Expr);
5478 end loop;
5479 end if;
5480
5481 -- Process component associations
5482
5483 if Present (Component_Associations (Sub_Aggr)) then
5484 Assoc := First (Component_Associations (Sub_Aggr));
5485 while Present (Assoc) loop
5486 Expr := Expression (Assoc);
5487 Compute_Others_Present (Expr, Dim + 1);
5488 Next (Assoc);
5489 end loop;
5490 end if;
5491 end if;
5492 end Compute_Others_Present;
5493
70482933
RK
5494 ------------------
5495 -- Others_Check --
5496 ------------------
5497
5498 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is
5499 Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
5500 Aggr_Hi : constant Node_Id := Aggr_High (Dim);
3cf3e5c6 5501 -- The bounds of the aggregate for this dimension
70482933
RK
5502
5503 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
3cf3e5c6 5504 -- The index type for this dimension
70482933
RK
5505
5506 Need_To_Check : Boolean := False;
5507
5508 Choices_Lo : Node_Id := Empty;
5509 Choices_Hi : Node_Id := Empty;
d74716b3 5510 -- The lowest and highest discrete choices for a named subaggregate
70482933
RK
5511
5512 Nb_Choices : Int := -1;
d74716b3 5513 -- The number of discrete non-others choices in this subaggregate
70482933
RK
5514
5515 Nb_Elements : Uint := Uint_0;
5516 -- The number of elements in a positional aggregate
5517
5518 Cond : Node_Id := Empty;
5519
5520 Assoc : Node_Id;
5521 Choice : Node_Id;
5522 Expr : Node_Id;
5523
5524 begin
5525 -- Check if we have an others choice. If we do make sure that this
d74716b3 5526 -- subaggregate contains at least one element in addition to the
70482933
RK
5527 -- others choice.
5528
5529 if Range_Checks_Suppressed (Ind_Typ) then
5530 Need_To_Check := False;
5531
5532 elsif Present (Expressions (Sub_Aggr))
5533 and then Present (Component_Associations (Sub_Aggr))
5534 then
10c257af
ES
5535 Need_To_Check :=
5536 not (Is_Empty_List (Expressions (Sub_Aggr))
5537 and then Is_Empty_List
5538 (Component_Associations (Sub_Aggr)));
70482933
RK
5539
5540 elsif Present (Component_Associations (Sub_Aggr)) then
5541 Assoc := Last (Component_Associations (Sub_Aggr));
5542
00f45f30 5543 if Nkind (First (Choice_List (Assoc))) /= N_Others_Choice then
70482933
RK
5544 Need_To_Check := False;
5545
5546 else
3b9fa2df
ES
5547 -- Count the number of discrete choices. Start with -1 because
5548 -- the others choice does not count.
70482933 5549
bdc193ba
AC
5550 -- Is there some reason we do not use List_Length here ???
5551
70482933
RK
5552 Nb_Choices := -1;
5553 Assoc := First (Component_Associations (Sub_Aggr));
5554 while Present (Assoc) loop
00f45f30 5555 Choice := First (Choice_List (Assoc));
70482933
RK
5556 while Present (Choice) loop
5557 Nb_Choices := Nb_Choices + 1;
5558 Next (Choice);
5559 end loop;
5560
5561 Next (Assoc);
5562 end loop;
5563
5564 -- If there is only an others choice nothing to do
5565
5566 Need_To_Check := (Nb_Choices > 0);
5567 end if;
5568
5569 else
5570 Need_To_Check := False;
5571 end if;
5572
d74716b3 5573 -- If we are dealing with a positional subaggregate with an others
3b9fa2df 5574 -- choice then compute the number or positional elements.
70482933
RK
5575
5576 if Need_To_Check and then Present (Expressions (Sub_Aggr)) then
5577 Expr := First (Expressions (Sub_Aggr));
5578 Nb_Elements := Uint_0;
5579 while Present (Expr) loop
5580 Nb_Elements := Nb_Elements + 1;
5581 Next (Expr);
5582 end loop;
5583
5584 -- If the aggregate contains discrete choices and an others choice
5585 -- compute the smallest and largest discrete choice values.
5586
5587 elsif Need_To_Check then
5588 Compute_Choices_Lo_And_Choices_Hi : declare
07fc65c4 5589
70482933
RK
5590 Table : Case_Table_Type (1 .. Nb_Choices);
5591 -- Used to sort all the different choice values
5592
07fc65c4 5593 J : Pos := 1;
70482933
RK
5594
5595 begin
5596 Assoc := First (Component_Associations (Sub_Aggr));
5597 while Present (Assoc) loop
00f45f30 5598 Choice := First (Choice_List (Assoc));
70482933
RK
5599 while Present (Choice) loop
5600 if Nkind (Choice) = N_Others_Choice then
5601 exit;
5602 end if;
5603
7c4f3267
BD
5604 declare
5605 Bounds : constant Range_Nodes :=
5606 Get_Index_Bounds (Choice);
5607 begin
5608 Table (J).Choice_Lo := Bounds.First;
5609 Table (J).Choice_Hi := Bounds.Last;
5610 end;
70482933 5611
07fc65c4 5612 J := J + 1;
70482933
RK
5613 Next (Choice);
5614 end loop;
5615
5616 Next (Assoc);
5617 end loop;
5618
5619 -- Sort the discrete choices
5620
5621 Sort_Case_Table (Table);
5622
5623 Choices_Lo := Table (1).Choice_Lo;
5624 Choices_Hi := Table (Nb_Choices).Choice_Hi;
5625 end Compute_Choices_Lo_And_Choices_Hi;
5626 end if;
5627
d74716b3 5628 -- If no others choice in this subaggregate, or the aggregate
70482933
RK
5629 -- comprises only an others choice, nothing to do.
5630
5631 if not Need_To_Check then
5632 Cond := Empty;
5633
3b9fa2df
ES
5634 -- If we are dealing with an aggregate containing an others choice
5635 -- and positional components, we generate the following test:
5636
70482933
RK
5637 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
5638 -- Ind_Typ'Pos (Aggr_Hi)
5639 -- then
5640 -- raise Constraint_Error;
5641 -- end if;
5642
6a987d78
EB
5643 -- in the general case, but the following simpler test:
5644
5645 -- [constraint_error when
5646 -- Aggr_Lo + (Nb_Elements - 1) > Aggr_Hi];
5647
5648 -- instead if the index type is a signed integer.
5649
70482933 5650 elsif Nb_Elements > Uint_0 then
6a987d78
EB
5651 if Nb_Elements = Uint_1 then
5652 Cond :=
5653 Make_Op_Gt (Loc,
5654 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
5655 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi));
5656
5657 elsif Is_Signed_Integer_Type (Ind_Typ) then
5658 Cond :=
5659 Make_Op_Gt (Loc,
5660 Left_Opnd =>
5661 Make_Op_Add (Loc,
5662 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
5663 Right_Opnd =>
5664 Make_Integer_Literal (Loc, Nb_Elements - 1)),
5665 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi));
70482933 5666
6a987d78
EB
5667 else
5668 Cond :=
5669 Make_Op_Gt (Loc,
5670 Left_Opnd =>
5671 Make_Op_Add (Loc,
5672 Left_Opnd =>
5673 Make_Attribute_Reference (Loc,
5674 Prefix => New_Occurrence_Of (Ind_Typ, Loc),
5675 Attribute_Name => Name_Pos,
5676 Expressions =>
5677 New_List
5678 (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
5679 Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
5680
5681 Right_Opnd =>
5682 Make_Attribute_Reference (Loc,
5683 Prefix => New_Occurrence_Of (Ind_Typ, Loc),
5684 Attribute_Name => Name_Pos,
5685 Expressions => New_List (
5686 Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
5687 end if;
70482933 5688
3b9fa2df
ES
5689 -- If we are dealing with an aggregate containing an others choice
5690 -- and discrete choices we generate the following test:
5691
70482933
RK
5692 -- [constraint_error when
5693 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
5694
5695 else
5696 Cond :=
5697 Make_Or_Else (Loc,
5698 Left_Opnd =>
5699 Make_Op_Lt (Loc,
bdc193ba
AC
5700 Left_Opnd => Duplicate_Subexpr_Move_Checks (Choices_Lo),
5701 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo)),
70482933
RK
5702
5703 Right_Opnd =>
5704 Make_Op_Gt (Loc,
bdc193ba
AC
5705 Left_Opnd => Duplicate_Subexpr (Choices_Hi),
5706 Right_Opnd => Duplicate_Subexpr (Aggr_Hi)));
70482933
RK
5707 end if;
5708
5709 if Present (Cond) then
5710 Insert_Action (N,
07fc65c4
GB
5711 Make_Raise_Constraint_Error (Loc,
5712 Condition => Cond,
5713 Reason => CE_Length_Check_Failed));
641d3093
TQ
5714 -- Questionable reason code, shouldn't that be a
5715 -- CE_Range_Check_Failed ???
70482933
RK
5716 end if;
5717
d74716b3 5718 -- Now look inside the subaggregate to see if there is more work
70482933
RK
5719
5720 if Dim < Aggr_Dimension then
5721
5722 -- Process positional components
5723
5724 if Present (Expressions (Sub_Aggr)) then
5725 Expr := First (Expressions (Sub_Aggr));
5726 while Present (Expr) loop
5727 Others_Check (Expr, Dim + 1);
5728 Next (Expr);
5729 end loop;
5730 end if;
5731
5732 -- Process component associations
5733
5734 if Present (Component_Associations (Sub_Aggr)) then
5735 Assoc := First (Component_Associations (Sub_Aggr));
5736 while Present (Assoc) loop
5737 Expr := Expression (Assoc);
5738 Others_Check (Expr, Dim + 1);
5739 Next (Assoc);
5740 end loop;
5741 end if;
5742 end if;
5743 end Others_Check;
5744
8da337c5
AC
5745 -------------------------
5746 -- Safe_Left_Hand_Side --
5747 -------------------------
5748
5749 function Safe_Left_Hand_Side (N : Node_Id) return Boolean is
deeb1604
AC
5750 function Is_Safe_Index (Indx : Node_Id) return Boolean;
5751 -- If the left-hand side includes an indexed component, check that
d74716b3 5752 -- the indexes are free of side effects.
deeb1604
AC
5753
5754 -------------------
5755 -- Is_Safe_Index --
5756 -------------------
5757
5758 function Is_Safe_Index (Indx : Node_Id) return Boolean is
5759 begin
5760 if Is_Entity_Name (Indx) then
5761 return True;
5762
5763 elsif Nkind (Indx) = N_Integer_Literal then
5764 return True;
5765
5766 elsif Nkind (Indx) = N_Function_Call
5767 and then Is_Entity_Name (Name (Indx))
36a66365 5768 and then Has_Pragma_Pure_Function (Entity (Name (Indx)))
deeb1604
AC
5769 then
5770 return True;
5771
5772 elsif Nkind (Indx) = N_Type_Conversion
5773 and then Is_Safe_Index (Expression (Indx))
5774 then
5775 return True;
5776
5777 else
5778 return False;
5779 end if;
5780 end Is_Safe_Index;
5781
5782 -- Start of processing for Safe_Left_Hand_Side
5783
8da337c5
AC
5784 begin
5785 if Is_Entity_Name (N) then
5786 return True;
5787
4a08c95c 5788 elsif Nkind (N) in N_Explicit_Dereference | N_Selected_Component
8da337c5
AC
5789 and then Safe_Left_Hand_Side (Prefix (N))
5790 then
5791 return True;
5792
5793 elsif Nkind (N) = N_Indexed_Component
5794 and then Safe_Left_Hand_Side (Prefix (N))
36a66365 5795 and then Is_Safe_Index (First (Expressions (N)))
8da337c5
AC
5796 then
5797 return True;
deeb1604
AC
5798
5799 elsif Nkind (N) = N_Unchecked_Type_Conversion then
5800 return Safe_Left_Hand_Side (Expression (N));
5801
8da337c5
AC
5802 else
5803 return False;
5804 end if;
5805 end Safe_Left_Hand_Side;
5806
fe43084c
ES
5807 ----------------------------------
5808 -- Two_Pass_Aggregate_Expansion --
5809 ----------------------------------
5810
5811 procedure Two_Pass_Aggregate_Expansion (N : Node_Id) is
5812 Loc : constant Source_Ptr := Sloc (N);
5813 Comp_Type : constant Entity_Id := Etype (N);
5814 Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N);
5815 Index_Type : constant Entity_Id := Etype (First_Index (Etype (N)));
5816 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N);
5817 TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N);
5818
5819 Assoc : Node_Id := First (Component_Associations (N));
5820 Incr : Node_Id;
5821 Iter : Node_Id;
5822 New_Comp : Node_Id;
5823 One_Loop : Node_Id;
5824
5825 Size_Expr_Code : List_Id;
5826 Insertion_Code : List_Id := New_List;
5827
5828 begin
5829 Size_Expr_Code := New_List (
5830 Make_Object_Declaration (Loc,
5831 Defining_Identifier => Size_Id,
5832 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
5833 Expression => Make_Integer_Literal (Loc, 0)));
5834
5835 -- First pass: execute the iterators to count the number of elements
5836 -- that will be generated.
5837
5838 while Present (Assoc) loop
5839 Iter := Iterator_Specification (Assoc);
5840 Incr := Make_Assignment_Statement (Loc,
5841 Name => New_Occurrence_Of (Size_Id, Loc),
5842 Expression =>
5843 Make_Op_Add (Loc,
5844 Left_Opnd => New_Occurrence_Of (Size_Id, Loc),
5845 Right_Opnd => Make_Integer_Literal (Loc, 1)));
5846
f3561c06 5847 One_Loop := Make_Implicit_Loop_Statement (N,
fe43084c
ES
5848 Iteration_Scheme =>
5849 Make_Iteration_Scheme (Loc,
08613129 5850 Iterator_Specification => New_Copy_Tree (Iter)),
fe43084c
ES
5851 Statements => New_List (Incr));
5852
5853 Append (One_Loop, Size_Expr_Code);
5854 Next (Assoc);
5855 end loop;
5856
5857 Insert_Actions (N, Size_Expr_Code);
5858
5859 -- Build a constrained subtype with the calculated length
5860 -- and declare the proper bounded aggregate object.
5861 -- The index type is some discrete type, so the bounds of the
5862 -- constructed array are computed as T'Val (T'Pos (ineger bound));
5863
5864 declare
5865 Pos_Lo : constant Node_Id :=
5866 Make_Attribute_Reference (Loc,
5867 Prefix => New_Occurrence_Of (Index_Type, Loc),
5868 Attribute_Name => Name_Pos,
5869 Expressions => New_List (
5870 Make_Attribute_Reference (Loc,
5871 Prefix => New_Occurrence_Of (Index_Type, Loc),
5872 Attribute_Name => Name_First)));
5873
5874 Aggr_Lo : constant Node_Id :=
5875 Make_Attribute_Reference (Loc,
5876 Prefix => New_Occurrence_Of (Index_Type, Loc),
5877 Attribute_Name => Name_Val,
5878 Expressions => New_List (New_Copy_Tree (Pos_Lo)));
5879
5880 -- Hi = Index_type'Pos (Lo + Size -1).
5881
5882 Pos_Hi : constant Node_Id :=
5883 Make_Op_Add (Loc,
5884 Left_Opnd => New_Copy_Tree (Pos_Lo),
5885 Right_Opnd =>
5886 Make_Op_Subtract (Loc,
5887 Left_Opnd => New_Occurrence_Of (Size_Id, Loc),
5888 Right_Opnd => Make_Integer_Literal (Loc, 1)));
5889
5890 -- Corresponding index value
5891
5892 Aggr_Hi : constant Node_Id :=
5893 Make_Attribute_Reference (Loc,
5894 Prefix => New_Occurrence_Of (Index_Type, Loc),
5895 Attribute_Name => Name_Val,
5896 Expressions => New_List (New_Copy_Tree (Pos_Hi)));
5897
5898 SubE : constant Entity_Id := Make_Temporary (Loc, 'T');
5899 SubD : constant Node_Id :=
5900 Make_Subtype_Declaration (Loc,
5901 Defining_Identifier => SubE,
5902 Subtype_Indication =>
5903 Make_Subtype_Indication (Loc,
5904 Subtype_Mark =>
5905 New_Occurrence_Of (Etype (Comp_Type), Loc),
5906 Constraint =>
5907 Make_Index_Or_Discriminant_Constraint
5908 (Loc,
5909 Constraints =>
5910 New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi)))));
5911
5912 -- Create a temporary array of the above subtype which
5913 -- will be used to capture the aggregate assignments.
5914
5915 TmpD : constant Node_Id :=
5916 Make_Object_Declaration (Loc,
5917 Defining_Identifier => TmpE,
5918 Object_Definition => New_Occurrence_Of (SubE, Loc));
5919 begin
5920 Insert_Actions (N, New_List (SubD, TmpD));
5921 end;
5922
5923 -- Second pass: use the iterators to generate the elements of the
5924 -- aggregate. Insertion index starts at Index_Type'First. We
5925 -- assume that the second evaluation of each iterator generates
5926 -- the same number of elements as the first pass, and consider
5927 -- that the execution is erroneous (even if the RM does not state
5928 -- this explicitly) if the number of elements generated differs
5929 -- between first and second pass.
5930
5931 Assoc := First (Component_Associations (N));
5932
5933 -- Initialize insertion position to first array component.
5934
5935 Insertion_Code := New_List (
5936 Make_Object_Declaration (Loc,
5937 Defining_Identifier => Index_Id,
5938 Object_Definition =>
5939 New_Occurrence_Of (Index_Type, Loc),
5940 Expression =>
5941 Make_Attribute_Reference (Loc,
5942 Prefix => New_Occurrence_Of (Index_Type, Loc),
5943 Attribute_Name => Name_First)));
5944
5945 while Present (Assoc) loop
5946 Iter := Iterator_Specification (Assoc);
5947 New_Comp := Make_Assignment_Statement (Loc,
5948 Name =>
5949 Make_Indexed_Component (Loc,
5950 Prefix => New_Occurrence_Of (TmpE, Loc),
5951 Expressions =>
5952 New_List (New_Occurrence_Of (Index_Id, Loc))),
d983abeb 5953 Expression => Copy_Separate_Tree (Expression (Assoc)));
fe43084c
ES
5954
5955 -- Advance index position for insertion.
5956
5957 Incr := Make_Assignment_Statement (Loc,
5958 Name => New_Occurrence_Of (Index_Id, Loc),
5959 Expression =>
5960 Make_Attribute_Reference (Loc,
5961 Prefix =>
5962 New_Occurrence_Of (Index_Type, Loc),
5963 Attribute_Name => Name_Succ,
5964 Expressions =>
5965 New_List (New_Occurrence_Of (Index_Id, Loc))));
5966
8b1a5da3
ES
5967 -- Add guard to skip last increment when upper bound is reached.
5968
5969 Incr := Make_If_Statement (Loc,
5970 Condition =>
5971 Make_Op_Ne (Loc,
5972 Left_Opnd => New_Occurrence_Of (Index_Id, Loc),
5973 Right_Opnd =>
5974 Make_Attribute_Reference (Loc,
5975 Prefix => New_Occurrence_Of (Index_Type, Loc),
5976 Attribute_Name => Name_Last)),
5977 Then_Statements => New_List (Incr));
5978
f3561c06 5979 One_Loop := Make_Implicit_Loop_Statement (N,
fe43084c
ES
5980 Iteration_Scheme =>
5981 Make_Iteration_Scheme (Loc,
08613129 5982 Iterator_Specification => Copy_Separate_Tree (Iter)),
fe43084c
ES
5983 Statements => New_List (New_Comp, Incr));
5984
5985 Append (One_Loop, Insertion_Code);
5986 Next (Assoc);
5987 end loop;
5988
5989 Insert_Actions (N, Insertion_Code);
5990
5991 -- Depending on context this may not work for build-in-place
5992 -- arrays ???
5993
5994 Rewrite (N, New_Occurrence_Of (TmpE, Loc));
5995
5996 end Two_Pass_Aggregate_Expansion;
5997
8da337c5 5998 -- Local variables
70482933
RK
5999
6000 Tmp : Entity_Id;
fbf5a39b 6001 -- Holds the temporary aggregate value
70482933
RK
6002
6003 Tmp_Decl : Node_Id;
fbf5a39b 6004 -- Holds the declaration of Tmp
70482933
RK
6005
6006 Aggr_Code : List_Id;
6007 Parent_Node : Node_Id;
6008 Parent_Kind : Node_Kind;
6009
6010 -- Start of processing for Expand_Array_Aggregate
6011
6012 begin
6013 -- Do not touch the special aggregates of attributes used for Asm calls
6014
6015 if Is_RTE (Ctyp, RE_Asm_Input_Operand)
6016 or else Is_RTE (Ctyp, RE_Asm_Output_Operand)
6017 then
6018 return;
4a1bfefb 6019
fe43084c 6020 elsif Present (Component_Associations (N))
8b1a5da3
ES
6021 and then Nkind (First (Component_Associations (N))) =
6022 N_Iterated_Component_Association
6023 and then
6024 Present (Iterator_Specification (First (Component_Associations (N))))
fe43084c
ES
6025 then
6026 Two_Pass_Aggregate_Expansion (N);
6027 return;
6028
f5655e4a
AC
6029 -- Do not attempt expansion if error already detected. We may reach this
6030 -- point in spite of previous errors when compiling with -gnatq, to
6031 -- force all possible errors (this is the usual ACATS mode).
6032
6033 elsif Error_Posted (N) then
6034 return;
70482933
RK
6035 end if;
6036
07fc65c4 6037 -- If the semantic analyzer has determined that aggregate N will raise
e7c0dd39 6038 -- Constraint_Error at run time, then the aggregate node has been
07fc65c4
GB
6039 -- replaced with an N_Raise_Constraint_Error node and we should
6040 -- never get here.
70482933
RK
6041
6042 pragma Assert (not Raises_Constraint_Error (N));
6043
3cf3e5c6 6044 -- STEP 1a
fbf5a39b
AC
6045
6046 -- Check that the index range defined by aggregate bounds is
6047 -- compatible with corresponding index subtype.
70482933
RK
6048
6049 Index_Compatibility_Check : declare
6050 Aggr_Index_Range : Node_Id := First_Index (Typ);
6051 -- The current aggregate index range
6052
6053 Index_Constraint : Node_Id := First_Index (Etype (Typ));
6054 -- The corresponding index constraint against which we have to
6055 -- check the above aggregate index range.
6056
6057 begin
6058 Compute_Others_Present (N, 1);
6059
6060 for J in 1 .. Aggr_Dimension loop
bdc193ba
AC
6061 -- There is no need to emit a check if an others choice is present
6062 -- for this array aggregate dimension since in this case one of
d74716b3 6063 -- N's subaggregates has taken its bounds from the context and
bdc193ba 6064 -- these bounds must have been checked already. In addition all
d74716b3
AC
6065 -- subaggregates corresponding to the same dimension must all have
6066 -- the same bounds (checked in (c) below).
70482933
RK
6067
6068 if not Range_Checks_Suppressed (Etype (Index_Constraint))
6069 and then not Others_Present (J)
6070 then
3b9fa2df
ES
6071 -- We don't use Checks.Apply_Range_Check here because it emits
6072 -- a spurious check. Namely it checks that the range defined by
d74716b3 6073 -- the aggregate bounds is nonempty. But we know this already
3b9fa2df 6074 -- if we get here.
70482933
RK
6075
6076 Check_Bounds (Aggr_Index_Range, Index_Constraint);
6077 end if;
6078
3b9fa2df
ES
6079 -- Save the low and high bounds of the aggregate index as well as
6080 -- the index type for later use in checks (b) and (c) below.
70482933 6081
10c257af
ES
6082 Get_Index_Bounds
6083 (Aggr_Index_Range, L => Aggr_Low (J), H => Aggr_High (J));
70482933
RK
6084
6085 Aggr_Index_Typ (J) := Etype (Index_Constraint);
6086
6087 Next_Index (Aggr_Index_Range);
6088 Next_Index (Index_Constraint);
6089 end loop;
6090 end Index_Compatibility_Check;
6091
3cf3e5c6 6092 -- STEP 1b
fbf5a39b 6093
3b9fa2df
ES
6094 -- If an others choice is present check that no aggregate index is
6095 -- outside the bounds of the index constraint.
70482933
RK
6096
6097 Others_Check (N, 1);
6098
3cf3e5c6 6099 -- STEP 1c
fbf5a39b
AC
6100
6101 -- For multidimensional arrays make sure that all subaggregates
6102 -- corresponding to the same dimension have the same bounds.
70482933
RK
6103
6104 if Aggr_Dimension > 1 then
6105 Check_Same_Aggr_Bounds (N, 1);
6106 end if;
6107
688a9b51
RD
6108 -- STEP 1d
6109
6110 -- If we have a default component value, or simple initialization is
6111 -- required for the component type, then we replace <> in component
6112 -- associations by the required default value.
6113
6114 declare
6115 Default_Val : Node_Id;
6116 Assoc : Node_Id;
6117
6118 begin
6119 if (Present (Default_Aspect_Component_Value (Typ))
6120 or else Needs_Simple_Initialization (Ctyp))
6121 and then Present (Component_Associations (N))
6122 then
6123 Assoc := First (Component_Associations (N));
6124 while Present (Assoc) loop
6125 if Nkind (Assoc) = N_Component_Association
6126 and then Box_Present (Assoc)
6127 then
6128 Set_Box_Present (Assoc, False);
6129
6130 if Present (Default_Aspect_Component_Value (Typ)) then
6131 Default_Val := Default_Aspect_Component_Value (Typ);
6132 else
6133 Default_Val := Get_Simple_Init_Val (Ctyp, N);
6134 end if;
6135
6136 Set_Expression (Assoc, New_Copy_Tree (Default_Val));
6137 Analyze_And_Resolve (Expression (Assoc), Ctyp);
6138 end if;
6139
6140 Next (Assoc);
6141 end loop;
6142 end if;
6143 end;
6144
3cf3e5c6 6145 -- STEP 2
70482933 6146
3b9fa2df
ES
6147 -- Here we test for is packed array aggregate that we can handle at
6148 -- compile time. If so, return with transformation done. Note that we do
6149 -- this even if the aggregate is nested, because once we have done this
a90bd866 6150 -- processing, there is no more nested aggregate.
fbf5a39b
AC
6151
6152 if Packed_Array_Aggregate_Handled (N) then
6153 return;
6154 end if;
6155
6156 -- At this point we try to convert to positional form
70482933 6157
c42006e9 6158 Convert_To_Positional (N);
70482933 6159
23a9215f 6160 -- If the result is no longer an aggregate (e.g. it may be a string
fbf5a39b
AC
6161 -- literal, or a temporary which has the needed value), then we are
6162 -- done, since there is no longer a nested aggregate.
6163
70482933
RK
6164 if Nkind (N) /= N_Aggregate then
6165 return;
6166
5eeeed5e
AC
6167 -- We are also done if the result is an analyzed aggregate, indicating
6168 -- that Convert_To_Positional succeeded and reanalyzed the rewritten
6169 -- aggregate.
fbf5a39b 6170
dc67cfea 6171 elsif Analyzed (N) and then Is_Rewrite_Substitution (N) then
70482933
RK
6172 return;
6173 end if;
6174
fa57ac97
ES
6175 -- If all aggregate components are compile-time known and the aggregate
6176 -- has been flattened, nothing left to do. The same occurs if the
b465ef6f 6177 -- aggregate is used to initialize the components of a statically
fa57ac97 6178 -- allocated dispatch table.
0f95b178 6179
fa57ac97
ES
6180 if Compile_Time_Known_Aggregate (N)
6181 or else Is_Static_Dispatch_Table_Aggregate (N)
6182 then
0f95b178
JM
6183 Set_Expansion_Delayed (N, False);
6184 return;
6185 end if;
6186
fbf5a39b
AC
6187 -- Now see if back end processing is possible
6188
70482933
RK
6189 if Backend_Processing_Possible (N) then
6190
6191 -- If the aggregate is static but the constraints are not, build
6192 -- a static subtype for the aggregate, so that Gigi can place it
6193 -- in static memory. Perform an unchecked_conversion to the non-
6194 -- static type imposed by the context.
6195
6196 declare
6197 Itype : constant Entity_Id := Etype (N);
6198 Index : Node_Id;
6199 Needs_Type : Boolean := False;
6200
6201 begin
6202 Index := First_Index (Itype);
70482933 6203 while Present (Index) loop
edab6088 6204 if not Is_OK_Static_Subtype (Etype (Index)) then
70482933
RK
6205 Needs_Type := True;
6206 exit;
6207 else
6208 Next_Index (Index);
6209 end if;
6210 end loop;
6211
6212 if Needs_Type then
6213 Build_Constrained_Type (Positional => True);
6214 Rewrite (N, Unchecked_Convert_To (Itype, N));
6215 Analyze (N);
6216 end if;
6217 end;
6218
6219 return;
6220 end if;
6221
3cf3e5c6 6222 -- STEP 3
fbf5a39b 6223
5ed4ba15
AC
6224 -- Delay expansion for nested aggregates: it will be taken care of when
6225 -- the parent aggregate is expanded.
70482933
RK
6226
6227 Parent_Node := Parent (N);
6228 Parent_Kind := Nkind (Parent_Node);
6229
6230 if Parent_Kind = N_Qualified_Expression then
6231 Parent_Node := Parent (Parent_Node);
6232 Parent_Kind := Nkind (Parent_Node);
6233 end if;
6234
6235 if Parent_Kind = N_Aggregate
6236 or else Parent_Kind = N_Extension_Aggregate
6237 or else Parent_Kind = N_Component_Association
6238 or else (Parent_Kind = N_Object_Declaration
4844a259 6239 and then (Needs_Finalization (Typ)
ea588d41 6240 or else Is_Special_Return_Object
4844a259 6241 (Defining_Identifier (Parent_Node))))
70482933
RK
6242 or else (Parent_Kind = N_Assignment_Statement
6243 and then Inside_Init_Proc)
6244 then
2a1838cd
EB
6245 Set_Expansion_Delayed (N, not Static_Array_Aggregate (N));
6246 return;
70482933
RK
6247 end if;
6248
3cf3e5c6 6249 -- STEP 4
70482933 6250
bc1146e5 6251 -- Check whether in-place aggregate expansion is possible
70482933
RK
6252
6253 -- For object declarations we build the aggregate in place, unless
d2a60e59 6254 -- the array is bit-packed.
70482933
RK
6255
6256 -- For assignments we do the assignment in place if all the component
d2a60e59
ES
6257 -- associations have compile-time known values, or are default-
6258 -- initialized limited components, e.g. tasks. For other cases we
f037632e
BD
6259 -- create a temporary. A full analysis for safety of in-place assignment
6260 -- is delicate.
70482933 6261
6f639c98
ES
6262 -- For allocators we assign to the designated object in place if the
6263 -- aggregate meets the same conditions as other in-place assignments.
6264 -- In this case the aggregate may not come from source but was created
6265 -- for default initialization, e.g. with Initialize_Scalars.
6266
70482933 6267 if Requires_Transient_Scope (Typ) then
6560f851 6268 Establish_Transient_Scope (N, Manage_Sec_Stack => False);
70482933
RK
6269 end if;
6270
92a68a04 6271 -- An array of limited components is built in place
d2a60e59
ES
6272
6273 if Is_Limited_Type (Typ) then
6274 Maybe_In_Place_OK := True;
6275
6276 elsif Has_Default_Init_Comps (N) then
c45b6ae0 6277 Maybe_In_Place_OK := False;
6f639c98
ES
6278
6279 elsif Is_Bit_Packed_Array (Typ)
6280 or else Has_Controlled_Component (Typ)
6281 then
6282 Maybe_In_Place_OK := False;
6283
a80b1eb7 6284 elsif Parent_Kind = N_Assignment_Statement then
c45b6ae0 6285 Maybe_In_Place_OK :=
a80b1eb7 6286 In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)));
6f639c98 6287
a80b1eb7
EB
6288 elsif Parent_Kind = N_Allocator then
6289 Maybe_In_Place_OK := In_Place_Assign_OK (N);
6290
6291 else
6292 Maybe_In_Place_OK := False;
c45b6ae0 6293 end if;
70482933 6294
36c73552
AC
6295 -- If this is an array of tasks, it will be expanded into build-in-place
6296 -- assignments. Build an activation chain for the tasks now.
a38ff9b1 6297
c8def50f 6298 if Has_Task (Typ) then
a38ff9b1
ES
6299 Build_Activation_Chain_Entity (N);
6300 end if;
6301
cf6956bb 6302 -- Perform in-place expansion of aggregate in an object declaration.
f3d42000
AC
6303 -- Note: actions generated for the aggregate will be captured in an
6304 -- expression-with-actions statement so that they can be transferred
6305 -- to freeze actions later if there is an address clause for the
6306 -- object. (Note: we don't use a block statement because this would
6307 -- cause generated freeze nodes to be elaborated in the wrong scope).
cf6956bb 6308
d2a60e59
ES
6309 -- Arrays of limited components must be built in place. The code
6310 -- previously excluded controlled components but this is an old
6311 -- oversight: the rules in 7.6 (17) are clear.
5ed4ba15 6312
d4e4e88a 6313 if Comes_From_Source (Parent_Node)
3386e3ae
AC
6314 and then Parent_Kind = N_Object_Declaration
6315 and then Present (Expression (Parent_Node))
6316 and then not
6732c403 6317 Must_Slide (N, Etype (Defining_Identifier (Parent_Node)), Typ)
3386e3ae 6318 and then not Is_Bit_Packed_Array (Typ)
70482933 6319 then
ac43e11e 6320 In_Place_Assign_OK_For_Declaration := True;
5ed4ba15
AC
6321 Tmp := Defining_Identifier (Parent_Node);
6322 Set_No_Initialization (Parent_Node);
6323 Set_Expression (Parent_Node, Empty);
70482933 6324
ac43e11e
AC
6325 -- Set kind and type of the entity, for use in the analysis
6326 -- of the subsequent assignments. If the nominal type is not
70482933
RK
6327 -- constrained, build a subtype from the known bounds of the
6328 -- aggregate. If the declaration has a subtype mark, use it,
6329 -- otherwise use the itype of the aggregate.
6330
2e02ab86 6331 Mutate_Ekind (Tmp, E_Variable);
ac43e11e 6332
70482933
RK
6333 if not Is_Constrained (Typ) then
6334 Build_Constrained_Type (Positional => False);
ac43e11e 6335
5ed4ba15
AC
6336 elsif Is_Entity_Name (Object_Definition (Parent_Node))
6337 and then Is_Constrained (Entity (Object_Definition (Parent_Node)))
70482933 6338 then
5ed4ba15 6339 Set_Etype (Tmp, Entity (Object_Definition (Parent_Node)));
ac43e11e 6340
70482933
RK
6341 else
6342 Set_Size_Known_At_Compile_Time (Typ, False);
6343 Set_Etype (Tmp, Typ);
6344 end if;
6345
a80b1eb7 6346 elsif Maybe_In_Place_OK and then Parent_Kind = N_Allocator then
6f639c98
ES
6347 Set_Expansion_Delayed (N);
6348 return;
6349
d2a60e59
ES
6350 -- Limited arrays in return statements are expanded when
6351 -- enclosing construct is expanded.
6352
6353 elsif Maybe_In_Place_OK
a80b1eb7 6354 and then Parent_Kind = N_Simple_Return_Statement
d2a60e59
ES
6355 then
6356 Set_Expansion_Delayed (N);
6357 return;
6358
6537318f
ES
6359 -- In the remaining cases the aggregate appears in the RHS of an
6360 -- assignment, which may be part of the expansion of an object
41a7b948 6361 -- declaration. If the aggregate is an actual in a call, itself
6537318f 6362 -- possibly in a RHS, building it in the target is not possible.
6f639c98 6363
70482933 6364 elsif Maybe_In_Place_OK
6537318f 6365 and then Nkind (Parent_Node) not in N_Subprogram_Call
a80b1eb7 6366 and then Safe_Left_Hand_Side (Name (Parent_Node))
70482933 6367 then
a80b1eb7 6368 Tmp := Name (Parent_Node);
70482933
RK
6369
6370 if Etype (Tmp) /= Etype (N) then
6371 Apply_Length_Check (N, Etype (Tmp));
fbf5a39b
AC
6372
6373 if Nkind (N) = N_Raise_Constraint_Error then
6374
6375 -- Static error, nothing further to expand
6376
6377 return;
6378 end if;
70482933
RK
6379 end if;
6380
36a66365
AC
6381 -- If a slice assignment has an aggregate with a single others_choice,
6382 -- the assignment can be done in place even if bounds are not static,
6383 -- by converting it into a loop over the discrete range of the slice.
6384
70482933 6385 elsif Maybe_In_Place_OK
a80b1eb7 6386 and then Nkind (Name (Parent_Node)) = N_Slice
36a66365 6387 and then Is_Others_Aggregate (N)
70482933 6388 then
a80b1eb7 6389 Tmp := Name (Parent_Node);
70482933 6390
36a66365
AC
6391 -- Set type of aggregate to be type of lhs in assignment, in order
6392 -- to suppress redundant length checks.
6393
6394 Set_Etype (N, Etype (Tmp));
70482933 6395
fbf5a39b
AC
6396 -- Step 5
6397
bc1146e5 6398 -- In-place aggregate expansion is not possible
fbf5a39b 6399
70482933 6400 else
07fc65c4 6401 Maybe_In_Place_OK := False;
faf387e1 6402 Tmp := Make_Temporary (Loc, 'A', N);
70482933 6403 Tmp_Decl :=
bdc193ba
AC
6404 Make_Object_Declaration (Loc,
6405 Defining_Identifier => Tmp,
6406 Object_Definition => New_Occurrence_Of (Typ, Loc));
70482933
RK
6407 Set_No_Initialization (Tmp_Decl, True);
6408
6409 -- If we are within a loop, the temporary will be pushed on the
6560f851
HK
6410 -- stack at each iteration. If the aggregate is the expression
6411 -- for an allocator, it will be immediately copied to the heap
6412 -- and can be reclaimed at once. We create a transient scope
6413 -- around the aggregate for this purpose.
70482933
RK
6414
6415 if Ekind (Current_Scope) = E_Loop
a80b1eb7 6416 and then Parent_Kind = N_Allocator
70482933 6417 then
6560f851 6418 Establish_Transient_Scope (N, Manage_Sec_Stack => False);
9f6cee82
EB
6419
6420 -- If the parent is an assignment for which no controlled actions
6421 -- should take place, prevent the temporary from being finalized.
6422
6423 elsif Parent_Kind = N_Assignment_Statement
6424 and then No_Ctrl_Actions (Parent_Node)
6425 then
6426 Mutate_Ekind (Tmp, E_Variable);
6427 Set_Is_Ignored_Transient (Tmp);
70482933
RK
6428 end if;
6429
6430 Insert_Action (N, Tmp_Decl);
6431 end if;
6432
36c73552
AC
6433 -- Construct and insert the aggregate code. We can safely suppress index
6434 -- checks because this code is guaranteed not to raise CE on index
6435 -- checks. However we should *not* suppress all checks.
70482933 6436
07fc65c4
GB
6437 declare
6438 Target : Node_Id;
6439
6440 begin
6441 if Nkind (Tmp) = N_Defining_Identifier then
e4494292 6442 Target := New_Occurrence_Of (Tmp, Loc);
07fc65c4
GB
6443
6444 else
d2a60e59
ES
6445 if Has_Default_Init_Comps (N)
6446 and then not Maybe_In_Place_OK
6447 then
0ab80019 6448 -- Ada 2005 (AI-287): This case has not been analyzed???
c45b6ae0 6449
9bc856dd 6450 raise Program_Error;
c45b6ae0
AC
6451 end if;
6452
0da2c8ac 6453 -- Name in assignment is explicit dereference
07fc65c4
GB
6454
6455 Target := New_Copy (Tmp);
6456 end if;
6457
bc1146e5 6458 -- If we are to generate an in-place assignment for a declaration or
ac43e11e
AC
6459 -- an assignment statement, and the assignment can be done directly
6460 -- by the back end, then do not expand further.
6461
bc1146e5 6462 -- ??? We can also do that if in-place expansion is not possible but
ac43e11e
AC
6463 -- then we could go into an infinite recursion.
6464
6465 if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK)
a1e1820b 6466 and then not CodePeer_Mode
c63a2ad6 6467 and then not Modify_Tree_For_C
ac43e11e 6468 and then not Possible_Bit_Aligned_Component (Target)
6b6bce61 6469 and then not Is_Possibly_Unaligned_Slice (Target)
ac43e11e
AC
6470 and then Aggr_Assignment_OK_For_Backend (N)
6471 then
ac43e11e 6472
742084ad
MP
6473 -- In the case of an assignment using an access with the
6474 -- Designated_Storage_Model aspect with a Copy_To procedure,
6475 -- insert a temporary and have the back end handle the assignment
6476 -- to it. Copy the result to the original target.
6477
6478 if Parent_Kind = N_Assignment_Statement
6479 and then Nkind (Name (Parent_Node)) = N_Explicit_Dereference
6480 and then Has_Designated_Storage_Model_Aspect
6481 (Etype (Prefix (Name (Parent_Node))))
6482 and then Present (Storage_Model_Copy_To
6483 (Storage_Model_Object
6484 (Etype (Prefix (Name (Parent_Node))))))
6485 then
ca4bff3a
EB
6486 Aggr_Code := Build_Assignment_With_Temporary
6487 (Target, Typ, New_Copy_Tree (N));
6488
742084ad
MP
6489 else
6490 if Maybe_In_Place_OK then
6491 return;
6492 end if;
6493
ca4bff3a
EB
6494 Aggr_Code := New_List (
6495 Make_Assignment_Statement (Loc,
6496 Name => Target,
6497 Expression => New_Copy_Tree (N)));
742084ad 6498 end if;
ca4bff3a 6499
d6e8719d 6500 else
ac43e11e
AC
6501 Aggr_Code :=
6502 Build_Array_Aggr_Code (N,
6503 Ctype => Ctyp,
6504 Index => First_Index (Typ),
6505 Into => Target,
6506 Scalar_Comp => Is_Scalar_Type (Ctyp));
6507 end if;
4ac2bbbd
AC
6508
6509 -- Save the last assignment statement associated with the aggregate
6510 -- when building a controlled object. This reference is utilized by
6511 -- the finalization machinery when marking an object as successfully
6512 -- initialized.
6513
6514 if Needs_Finalization (Typ)
6515 and then Is_Entity_Name (Target)
6516 and then Present (Entity (Target))
4a08c95c 6517 and then Ekind (Entity (Target)) in E_Constant | E_Variable
4ac2bbbd
AC
6518 then
6519 Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
6520 end if;
07fc65c4 6521 end;
70482933 6522
6782b1ef
AC
6523 -- If the aggregate is the expression in a declaration, the expanded
6524 -- code must be inserted after it. The defining entity might not come
6525 -- from source if this is part of an inlined body, but the declaration
6526 -- itself will.
fff7a6d9 6527 -- The test below looks very specialized and kludgy???
6782b1ef
AC
6528
6529 if Comes_From_Source (Tmp)
6530 or else
6531 (Nkind (Parent (N)) = N_Object_Declaration
6532 and then Comes_From_Source (Parent (N))
6533 and then Tmp = Defining_Entity (Parent (N)))
6534 then
fff7a6d9 6535 if Parent_Kind /= N_Object_Declaration or else Is_Frozen (Tmp) then
cf6956bb 6536 Insert_Actions_After (Parent_Node, Aggr_Code);
fff7a6d9
AC
6537 else
6538 declare
6539 Comp_Stmt : constant Node_Id :=
6540 Make_Compound_Statement
6541 (Sloc (Parent_Node), Actions => Aggr_Code);
6542 begin
6543 Insert_Action_After (Parent_Node, Comp_Stmt);
6544 Set_Initialization_Statements (Tmp, Comp_Stmt);
6545 end;
6546 end if;
70482933
RK
6547 else
6548 Insert_Actions (N, Aggr_Code);
6549 end if;
6550
07fc65c4
GB
6551 -- If the aggregate has been assigned in place, remove the original
6552 -- assignment.
6553
a80b1eb7
EB
6554 if Parent_Kind = N_Assignment_Statement and then Maybe_In_Place_OK then
6555 Rewrite (Parent_Node, Make_Null_Statement (Loc));
70482933 6556
a80b1eb7
EB
6557 -- Or else, if a temporary was created, replace the aggregate with it
6558
6559 elsif Parent_Kind /= N_Object_Declaration
6560 or else Tmp /= Defining_Identifier (Parent_Node)
70482933
RK
6561 then
6562 Rewrite (N, New_Occurrence_Of (Tmp, Loc));
6563 Analyze_And_Resolve (N, Typ);
6564 end if;
6565 end Expand_Array_Aggregate;
6566
6567 ------------------------
6568 -- Expand_N_Aggregate --
6569 ------------------------
6570
6571 procedure Expand_N_Aggregate (N : Node_Id) is
74580e1b 6572 T : constant Entity_Id := Etype (N);
70482933 6573 begin
354c3840
AC
6574 -- Record aggregate case
6575
74580e1b
PT
6576 if Is_Record_Type (T)
6577 and then not Is_Private_Type (T)
fe3463cc 6578 then
70482933 6579 Expand_Record_Aggregate (N);
354c3840 6580
74580e1b 6581 elsif Has_Aspect (T, Aspect_Aggregate) then
745f5698
ES
6582 Expand_Container_Aggregate (N);
6583
354c3840
AC
6584 -- Array aggregate case
6585
70482933 6586 else
354c3840
AC
6587 -- A special case, if we have a string subtype with bounds 1 .. N,
6588 -- where N is known at compile time, and the aggregate is of the
49eef89f
AC
6589 -- form (others => 'x'), with a single choice and no expressions,
6590 -- and N is less than 80 (an arbitrary limit for now), then replace
6591 -- the aggregate by the equivalent string literal (but do not mark
a90bd866 6592 -- it as static since it is not).
354c3840
AC
6593
6594 -- Note: this entire circuit is redundant with respect to code in
6595 -- Expand_Array_Aggregate that collapses others choices to positional
6596 -- form, but there are two problems with that circuit:
6597
6598 -- a) It is limited to very small cases due to ill-understood
b465ef6f 6599 -- interactions with bootstrapping. That limit is removed by
354c3840
AC
6600 -- use of the No_Implicit_Loops restriction.
6601
77a40ec1 6602 -- b) It incorrectly ends up with the resulting expressions being
354c3840
AC
6603 -- considered static when they are not. For example, the
6604 -- following test should fail:
6605
6606 -- pragma Restrictions (No_Implicit_Loops);
6607 -- package NonSOthers4 is
6608 -- B : constant String (1 .. 6) := (others => 'A');
6609 -- DH : constant String (1 .. 8) := B & "BB";
6610 -- X : Integer;
6611 -- pragma Export (C, X, Link_Name => DH);
6612 -- end;
6613
6614 -- But it succeeds (DH looks static to pragma Export)
6615
a90bd866 6616 -- To be sorted out ???
354c3840
AC
6617
6618 if Present (Component_Associations (N)) then
6619 declare
6620 CA : constant Node_Id := First (Component_Associations (N));
6621 MX : constant := 80;
6622
6623 begin
10c257af
ES
6624 if Present (CA)
6625 and then Nkind (First (Choice_List (CA))) = N_Others_Choice
354c3840 6626 and then Nkind (Expression (CA)) = N_Character_Literal
49eef89f 6627 and then No (Expressions (N))
354c3840
AC
6628 then
6629 declare
53f2aaf0
PT
6630 X : constant Node_Id := First_Index (T);
6631 EC : constant Node_Id := Expression (CA);
6632 CV : constant Uint := Char_Literal_Value (EC);
6633 CC : constant Char_Code := UI_To_CC (CV);
354c3840
AC
6634
6635 begin
6636 if Nkind (X) = N_Range
6637 and then Compile_Time_Known_Value (Low_Bound (X))
6638 and then Expr_Value (Low_Bound (X)) = 1
6639 and then Compile_Time_Known_Value (High_Bound (X))
6640 then
6641 declare
6642 Hi : constant Uint := Expr_Value (High_Bound (X));
6643
6644 begin
6645 if Hi <= MX then
6646 Start_String;
6647
6648 for J in 1 .. UI_To_Int (Hi) loop
53f2aaf0 6649 Store_String_Char (CC);
354c3840
AC
6650 end loop;
6651
6652 Rewrite (N,
6653 Make_String_Literal (Sloc (N),
6654 Strval => End_String));
6655
53f2aaf0
PT
6656 if In_Character_Range (CC) then
6657 null;
6658 elsif In_Wide_Character_Range (CC) then
354c3840 6659 Set_Has_Wide_Character (N);
53f2aaf0
PT
6660 else
6661 Set_Has_Wide_Wide_Character (N);
354c3840
AC
6662 end if;
6663
6664 Analyze_And_Resolve (N, T);
6665 Set_Is_Static_Expression (N, False);
6666 return;
6667 end if;
6668 end;
6669 end if;
6670 end;
6671 end if;
6672 end;
6673 end if;
6674
6675 -- Not that special case, so normal expansion of array aggregate
6676
70482933
RK
6677 Expand_Array_Aggregate (N);
6678 end if;
bdc193ba 6679
fbf5a39b
AC
6680 exception
6681 when RE_Not_Available =>
6682 return;
70482933
RK
6683 end Expand_N_Aggregate;
6684
745f5698
ES
6685 --------------------------------
6686 -- Expand_Container_Aggregate --
6687 --------------------------------
6688
6689 procedure Expand_Container_Aggregate (N : Node_Id) is
ce59f39f
GD
6690 Loc : constant Source_Ptr := Sloc (N);
6691 Typ : constant Entity_Id := Etype (N);
6692 Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
745f5698
ES
6693
6694 Empty_Subp : Node_Id := Empty;
6695 Add_Named_Subp : Node_Id := Empty;
6696 Add_Unnamed_Subp : Node_Id := Empty;
6697 New_Indexed_Subp : Node_Id := Empty;
6698 Assign_Indexed_Subp : Node_Id := Empty;
6699
ce59f39f
GD
6700 Aggr_Code : constant List_Id := New_List;
6701 Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N);
745f5698 6702
4f6ebe2a 6703 Comp : Node_Id;
745f5698 6704 Decl : Node_Id;
08c8883f 6705 Default : Node_Id;
ce59f39f 6706 Init_Stat : Node_Id;
08c8883f
ES
6707 Siz : Int;
6708
13112239
ES
6709 -- The following are used when the size of the aggregate is not
6710 -- static and requires a dynamic evaluation.
6711 Siz_Decl : Node_Id;
6712 Siz_Exp : Node_Id := Empty;
6713 Count_Type : Entity_Id;
6714
08c8883f
ES
6715 function Aggregate_Size return Int;
6716 -- Compute number of entries in aggregate, including choices
13112239 6717 -- that cover a range or subtype, as well as iterated constructs.
08c8883f 6718 -- Return -1 if the size is not known statically, in which case
13112239
ES
6719 -- allocate a default size for the aggregate, or build an expression
6720 -- to estimate the size dynamically.
6721
6722 function Build_Siz_Exp (Comp : Node_Id) return Int;
6723 -- When the aggregate contains a single Iterated_Component_Association
6724 -- or Element_Association with non-static bounds, build an expression
6725 -- to be used as the allocated size of the container. This may be an
6726 -- overestimate if a filter is present, but is a safe approximation.
fe43084c
ES
6727 -- If bounds are dynamic the aggregate is created in two passes, and
6728 -- the first generates a loop for the sole purpose of computing the
41a7b948 6729 -- number of elements that will be generated on the second pass.
ce59f39f 6730
7a21651f
ES
6731 procedure Expand_Iterated_Component (Comp : Node_Id);
6732 -- Handle iterated_component_association and iterated_Element
6733 -- association by generating a loop over the specified range,
6734 -- given either by a loop parameter specification or an iterator
6735 -- specification.
6736
08c8883f
ES
6737 --------------------
6738 -- Aggregate_Size --
6739 --------------------
6740
6741 function Aggregate_Size return Int is
6742 Comp : Node_Id;
6743 Choice : Node_Id;
6744 Lo, Hi : Node_Id;
ef7a3876 6745 Siz : Int;
08c8883f
ES
6746
6747 procedure Add_Range_Size;
13112239
ES
6748 -- Compute number of components specified by a component association
6749 -- given by a range or subtype name.
6750
6751 --------------------
6752 -- Add_Range_Size --
6753 --------------------
08c8883f
ES
6754
6755 procedure Add_Range_Size is
6756 begin
13112239
ES
6757 -- The bounds of the discrete range are integers or enumeration
6758 -- literals
6759
08c8883f
ES
6760 if Nkind (Lo) = N_Integer_Literal then
6761 Siz := Siz + UI_To_Int (Intval (Hi))
13112239
ES
6762 - UI_To_Int (Intval (Lo)) + 1;
6763 else
6764 Siz := Siz + UI_To_Int (Enumeration_Pos (Hi))
6765 - UI_To_Int (Enumeration_Pos (Lo)) + 1;
08c8883f
ES
6766 end if;
6767 end Add_Range_Size;
6768
6769 begin
ef7a3876 6770 -- Aggregate is either all positional or all named
13112239 6771
ef7a3876 6772 Siz := List_Length (Expressions (N));
08c8883f
ES
6773
6774 if Present (Component_Associations (N)) then
6775 Comp := First (Component_Associations (N));
13112239
ES
6776 -- If there is a single component association it can be
6777 -- an iterated component with dynamic bounds or an element
6778 -- iterator over an iterable object. If it is an array
6779 -- we can use the attribute Length to get its size;
6780 -- for a predefined container the function Length plays
6781 -- the same role. There is no available mechanism for
6782 -- user-defined containers. For now we treat all of these
6783 -- as dynamic.
6784
6785 if List_Length (Component_Associations (N)) = 1
6786 and then Nkind (Comp) in N_Iterated_Component_Association |
6787 N_Iterated_Element_Association
6788 then
6789 return Build_Siz_Exp (Comp);
daaf0179
ES
6790 end if;
6791
13112239
ES
6792 -- Otherwise all associations must specify static sizes.
6793
08c8883f
ES
6794 while Present (Comp) loop
6795 Choice := First (Choice_List (Comp));
6796
6797 while Present (Choice) loop
6798 Analyze (Choice);
6799
6800 if Nkind (Choice) = N_Range then
6801 Lo := Low_Bound (Choice);
6802 Hi := High_Bound (Choice);
13112239 6803 Add_Range_Size;
08c8883f
ES
6804
6805 elsif Is_Entity_Name (Choice)
6806 and then Is_Type (Entity (Choice))
6807 then
6808 Lo := Type_Low_Bound (Entity (Choice));
6809 Hi := Type_High_Bound (Entity (Choice));
13112239 6810 Add_Range_Size;
08c8883f
ES
6811
6812 Rewrite (Choice,
6813 Make_Range (Loc,
6814 New_Copy_Tree (Lo),
6815 New_Copy_Tree (Hi)));
6816
6817 else
6818 -- Single choice (syntax excludes a subtype
6819 -- indication).
6820
6821 Siz := Siz + 1;
6822 end if;
6823
6824 Next (Choice);
6825 end loop;
6826 Next (Comp);
6827 end loop;
6828 end if;
6829
6830 return Siz;
6831 end Aggregate_Size;
6832
13112239
ES
6833 -------------------
6834 -- Build_Siz_Exp --
6835 -------------------
6836
6837 function Build_Siz_Exp (Comp : Node_Id) return Int is
6838 Lo, Hi : Node_Id;
6839 begin
6840 if Nkind (Comp) = N_Range then
6841 Lo := Low_Bound (Comp);
6842 Hi := High_Bound (Comp);
6843 Analyze (Lo);
6844 Analyze (Hi);
6845
6846 -- Compute static size when possible.
6847
6848 if Is_Static_Expression (Lo)
6849 and then Is_Static_Expression (Hi)
6850 then
6851 if Nkind (Lo) = N_Integer_Literal then
6852 Siz := UI_To_Int (Intval (Hi)) - UI_To_Int (Intval (Lo)) + 1;
6853 else
6854 Siz := UI_To_Int (Enumeration_Pos (Hi))
6855 - UI_To_Int (Enumeration_Pos (Lo)) + 1;
6856 end if;
6857 return Siz;
6858
6859 else
6860 Siz_Exp :=
6861 Make_Op_Add (Sloc (Comp),
6862 Left_Opnd =>
6863 Make_Op_Subtract (Sloc (Comp),
6864 Left_Opnd => New_Copy_Tree (Hi),
6865 Right_Opnd => New_Copy_Tree (Lo)),
6866 Right_Opnd =>
6867 Make_Integer_Literal (Loc, 1));
6868 return -1;
6869 end if;
6870
6871 elsif Nkind (Comp) = N_Iterated_Component_Association then
6872 return Build_Siz_Exp (First (Discrete_Choices (Comp)));
6873
6874 elsif Nkind (Comp) = N_Iterated_Element_Association then
fe43084c
ES
6875 return -1;
6876
8b1a5da3 6877 -- ??? Need to create code for a loop and add to generated code,
fe43084c
ES
6878 -- as is done for array aggregates with iterated element
6879 -- associations, instead of using Append operations.
13112239
ES
6880
6881 else
6882 return -1;
6883 end if;
6884 end Build_Siz_Exp;
6885
4f6ebe2a
ES
6886 -------------------------------
6887 -- Expand_Iterated_Component --
6888 -------------------------------
6889
6890 procedure Expand_Iterated_Component (Comp : Node_Id) is
6891 Expr : constant Node_Id := Expression (Comp);
4f6ebe2a 6892
c0bab60b
ES
6893 Key_Expr : Node_Id := Empty;
6894 Loop_Id : Entity_Id;
4f6ebe2a
ES
6895 L_Range : Node_Id;
6896 L_Iteration_Scheme : Node_Id;
6897 Loop_Stat : Node_Id;
f3f1debe 6898 Params : List_Id;
4f6ebe2a
ES
6899 Stats : List_Id;
6900
6901 begin
c0bab60b
ES
6902 if Nkind (Comp) = N_Iterated_Element_Association then
6903 Key_Expr := Key_Expression (Comp);
6904
6905 -- We create a new entity as loop identifier in all cases,
6906 -- as is done for generated loops elsewhere, as the loop
6907 -- structure has been previously analyzed.
6908
6909 if Present (Iterator_Specification (Comp)) then
6910
fe43084c 6911 -- Either an Iterator_Specification or a Loop_Parameter_
c0bab60b
ES
6912 -- Specification is present.
6913
6914 L_Iteration_Scheme :=
6915 Make_Iteration_Scheme (Loc,
6916 Iterator_Specification => Iterator_Specification (Comp));
6917 Loop_Id :=
6918 Make_Defining_Identifier (Loc,
6919 Chars => Chars (Defining_Identifier
6920 (Iterator_Specification (Comp))));
6921 Set_Defining_Identifier
6922 (Iterator_Specification (L_Iteration_Scheme), Loop_Id);
6923
6924 else
6925 L_Iteration_Scheme :=
6926 Make_Iteration_Scheme (Loc,
6927 Loop_Parameter_Specification =>
6928 Loop_Parameter_Specification (Comp));
6929 Loop_Id :=
f3f1debe
ES
6930 Make_Defining_Identifier (Loc,
6931 Chars => Chars (Defining_Identifier
6932 (Loop_Parameter_Specification (Comp))));
c0bab60b 6933 Set_Defining_Identifier
f3f1debe
ES
6934 (Loop_Parameter_Specification
6935 (L_Iteration_Scheme), Loop_Id);
c0bab60b 6936 end if;
f3f1debe 6937 else
c0bab60b 6938
f3f1debe 6939 -- Iterated_Component_Association.
8092c199 6940
f3f1debe 6941 if Present (Iterator_Specification (Comp)) then
d983abeb
PT
6942 Loop_Id :=
6943 Make_Defining_Identifier (Loc,
6944 Chars => Chars (Defining_Identifier
6945 (Iterator_Specification (Comp))));
f3f1debe
ES
6946 L_Iteration_Scheme :=
6947 Make_Iteration_Scheme (Loc,
6948 Iterator_Specification => Iterator_Specification (Comp));
6949
6950 else
41a7b948 6951 -- Loop_Parameter_Specification is parsed with a choice list.
f3f1debe
ES
6952 -- where the range is the first (and only) choice.
6953
d983abeb
PT
6954 Loop_Id :=
6955 Make_Defining_Identifier (Loc,
6956 Chars => Chars (Defining_Identifier (Comp)));
f3f1debe
ES
6957 L_Range := Relocate_Node (First (Discrete_Choices (Comp)));
6958
6959 L_Iteration_Scheme :=
6960 Make_Iteration_Scheme (Loc,
6961 Loop_Parameter_Specification =>
6962 Make_Loop_Parameter_Specification (Loc,
6963 Defining_Identifier => Loop_Id,
6964 Discrete_Subtype_Definition => L_Range));
6965 end if;
8092c199 6966 end if;
4f6ebe2a 6967
0b4034c0
GD
6968 -- Build insertion statement. For a positional aggregate, only the
6969 -- expression is needed. For a named aggregate, the loop variable,
6970 -- whose type is that of the key, is an additional parameter for
6971 -- the insertion operation.
c0bab60b
ES
6972 -- If a Key_Expression is present, it serves as the additional
6973 -- parameter. Otherwise the key is given by the loop parameter
6974 -- itself.
4f6ebe2a 6975
13112239
ES
6976 if Present (Add_Unnamed_Subp)
6977 and then No (Add_Named_Subp)
6978 then
4f6ebe2a
ES
6979 Stats := New_List
6980 (Make_Procedure_Call_Statement (Loc,
0b4034c0
GD
6981 Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc),
6982 Parameter_Associations =>
6983 New_List (New_Occurrence_Of (Temp, Loc),
4f6ebe2a
ES
6984 New_Copy_Tree (Expr))));
6985 else
c0bab60b
ES
6986 -- Named or indexed aggregate, for which a key is present,
6987 -- possibly with a specified key_expression.
6988
6989 if Present (Key_Expr) then
f3f1debe
ES
6990 Params := New_List (New_Occurrence_Of (Temp, Loc),
6991 New_Copy_Tree (Key_Expr),
6992 New_Copy_Tree (Expr));
c0bab60b 6993 else
f3f1debe
ES
6994 Params := New_List (New_Occurrence_Of (Temp, Loc),
6995 New_Occurrence_Of (Loop_Id, Loc),
6996 New_Copy_Tree (Expr));
c0bab60b 6997 end if;
f3f1debe
ES
6998
6999 Stats := New_List
7000 (Make_Procedure_Call_Statement (Loc,
7001 Name => New_Occurrence_Of (Entity (Add_Named_Subp), Loc),
7002 Parameter_Associations => Params));
4f6ebe2a
ES
7003 end if;
7004
d43fbe01
PT
7005 Loop_Stat := Make_Implicit_Loop_Statement
7006 (Node => N,
7007 Identifier => Empty,
7008 Iteration_Scheme => L_Iteration_Scheme,
7009 Statements => Stats);
4f6ebe2a 7010 Append (Loop_Stat, Aggr_Code);
7a21651f 7011
4f6ebe2a
ES
7012 end Expand_Iterated_Component;
7013
00b21aa9 7014 -- Start of processing for Expand_Container_Aggregate
08c8883f 7015
745f5698
ES
7016 begin
7017 Parse_Aspect_Aggregate (Asp,
7018 Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
7019 New_Indexed_Subp, Assign_Indexed_Subp);
08c8883f
ES
7020
7021 -- The constructor for bounded containers is a function with
7022 -- a parameter that sets the size of the container. If the
13112239
ES
7023 -- size cannot be determined statically we use a default value
7024 -- or a dynamic expression.
08c8883f
ES
7025
7026 Siz := Aggregate_Size;
7a21651f 7027
08c8883f
ES
7028 if Ekind (Entity (Empty_Subp)) = E_Function
7029 and then Present (First_Formal (Entity (Empty_Subp)))
7030 then
7031 Default := Default_Value (First_Formal (Entity (Empty_Subp)));
13112239
ES
7032
7033 -- If aggregate size is not static, we can use default value
7034 -- of formal parameter for allocation. We assume that this
08c8883f 7035 -- (implementation-dependent) value is static, even though
13112239
ES
7036 -- the AI does not require it.
7037
7038 -- Create declaration for size: a constant literal in the simple
7039 -- case, an expression if iterated component associations may be
7040 -- involved, the default otherwise.
08c8883f 7041
13112239
ES
7042 Count_Type := Etype (First_Formal (Entity (Empty_Subp)));
7043 if Siz = -1 then
7044 if No (Siz_Exp) then
7045 Siz := UI_To_Int (Intval (Default));
7046 Siz_Exp := Make_Integer_Literal (Loc, Siz);
7047
7048 else
7049 Siz_Exp := Make_Type_Conversion (Loc,
7050 Subtype_Mark =>
7051 New_Occurrence_Of (Count_Type, Loc),
7052 Expression => Siz_Exp);
7053 end if;
7054
7055 else
7056 Siz_Exp := Make_Integer_Literal (Loc, Siz);
08c8883f
ES
7057 end if;
7058
13112239
ES
7059 Siz_Decl := Make_Object_Declaration (Loc,
7060 Defining_Identifier => Make_Temporary (Loc, 'S', N),
7061 Object_Definition =>
7062 New_Occurrence_Of (Count_Type, Loc),
7063 Expression => Siz_Exp);
7064 Append (Siz_Decl, Aggr_Code);
7065
7066 if Nkind (Siz_Exp) = N_Integer_Literal then
7067 Init_Stat :=
7068 Make_Object_Declaration (Loc,
7069 Defining_Identifier => Temp,
7070 Object_Definition => New_Occurrence_Of (Typ, Loc),
7071 Expression => Make_Function_Call (Loc,
7072 Name => New_Occurrence_Of (Entity (Empty_Subp), Loc),
7073 Parameter_Associations =>
7074 New_List
7075 (New_Occurrence_Of
7076 (Defining_Identifier (Siz_Decl), Loc))));
7077
7078 else
7079 Init_Stat :=
7080 Make_Object_Declaration (Loc,
7081 Defining_Identifier => Temp,
7082 Object_Definition => New_Occurrence_Of (Typ, Loc),
7083 Expression => Make_Function_Call (Loc,
7084 Name =>
7085 New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
7086 Parameter_Associations =>
7087 New_List (
7088 Make_Integer_Literal (Loc, 1),
7089 New_Occurrence_Of
7090 (Defining_Identifier (Siz_Decl), Loc))));
7091 end if;
08c8883f
ES
7092
7093 Append (Init_Stat, Aggr_Code);
7094
13112239
ES
7095 -- Size is dynamic: Create declaration for object, and intitialize
7096 -- with a call to the null container, or an assignment to it.
08c8883f
ES
7097
7098 else
7099 Decl :=
7100 Make_Object_Declaration (Loc,
7101 Defining_Identifier => Temp,
7102 Object_Definition => New_Occurrence_Of (Typ, Loc));
7103
7104 Insert_Action (N, Decl);
13112239
ES
7105
7106 -- The Empty entity is either a parameterless function, or
7107 -- a constant.
7108
08c8883f
ES
7109 if Ekind (Entity (Empty_Subp)) = E_Function then
7110 Init_Stat := Make_Assignment_Statement (Loc,
7111 Name => New_Occurrence_Of (Temp, Loc),
7112 Expression => Make_Function_Call (Loc,
7113 Name => New_Occurrence_Of (Entity (Empty_Subp), Loc)));
13112239 7114
08c8883f
ES
7115 else
7116 Init_Stat := Make_Assignment_Statement (Loc,
7117 Name => New_Occurrence_Of (Temp, Loc),
7118 Expression => New_Occurrence_Of (Entity (Empty_Subp), Loc));
7119 end if;
7120
7121 Append (Init_Stat, Aggr_Code);
7122 end if;
745f5698 7123
7a21651f
ES
7124 ---------------------------
7125 -- Positional aggregate --
7126 ---------------------------
745f5698 7127
08c8883f
ES
7128 -- If the aggregate is positional the aspect must include
7129 -- an Add_Unnamed subprogram.
7130
13112239 7131 if Present (Add_Unnamed_Subp) then
4f6ebe2a
ES
7132 if Present (Expressions (N)) then
7133 declare
7134 Insert : constant Entity_Id := Entity (Add_Unnamed_Subp);
7135 Comp : Node_Id;
7136 Stat : Node_Id;
7137
7138 begin
7139 Comp := First (Expressions (N));
7140 while Present (Comp) loop
7141 Stat := Make_Procedure_Call_Statement (Loc,
7142 Name => New_Occurrence_Of (Insert, Loc),
7143 Parameter_Associations =>
7144 New_List (New_Occurrence_Of (Temp, Loc),
0b4034c0 7145 New_Copy_Tree (Comp)));
4f6ebe2a
ES
7146 Append (Stat, Aggr_Code);
7147 Next (Comp);
7148 end loop;
7149 end;
7150 end if;
7151
13112239
ES
7152 -- Indexed aggregates are handled below. Unnamed aggregates
7153 -- such as sets may include iterated component associations.
4f6ebe2a 7154
13112239
ES
7155 if No (New_Indexed_Subp) then
7156 Comp := First (Component_Associations (N));
7157 while Present (Comp) loop
7158 if Nkind (Comp) = N_Iterated_Component_Association then
7159 Expand_Iterated_Component (Comp);
7160 end if;
7161 Next (Comp);
7162 end loop;
7163 end if;
4f6ebe2a 7164
7a21651f
ES
7165 ---------------------
7166 -- Named_Aggregate --
7167 ---------------------
7168
4f6ebe2a 7169 elsif Present (Add_Named_Subp) then
ce59f39f 7170 declare
4f6ebe2a 7171 Insert : constant Entity_Id := Entity (Add_Named_Subp);
ce59f39f 7172 Stat : Node_Id;
4f6ebe2a 7173 Key : Node_Id;
ce59f39f 7174 begin
4f6ebe2a
ES
7175 Comp := First (Component_Associations (N));
7176
0b4034c0 7177 -- Each component association may contain several choices;
4f6ebe2a
ES
7178 -- generate an insertion statement for each.
7179
ce59f39f 7180 while Present (Comp) loop
c0bab60b
ES
7181 if Nkind (Comp) in N_Iterated_Component_Association
7182 | N_Iterated_Element_Association
7183 then
4f6ebe2a
ES
7184 Expand_Iterated_Component (Comp);
7185 else
7186 Key := First (Choices (Comp));
7187
7188 while Present (Key) loop
7189 Stat := Make_Procedure_Call_Statement (Loc,
7190 Name => New_Occurrence_Of (Insert, Loc),
7191 Parameter_Associations =>
7192 New_List (New_Occurrence_Of (Temp, Loc),
0b4034c0
GD
7193 New_Copy_Tree (Key),
7194 New_Copy_Tree (Expression (Comp))));
4f6ebe2a
ES
7195 Append (Stat, Aggr_Code);
7196
7197 Next (Key);
7198 end loop;
7199 end if;
7200
ce59f39f
GD
7201 Next (Comp);
7202 end loop;
7203 end;
08c8883f 7204 end if;
7a21651f
ES
7205
7206 -----------------------
7207 -- Indexed_Aggregate --
7208 -----------------------
7209
08c8883f
ES
7210 -- For an indexed aggregate there must be an Assigned_Indexeed
7211 -- subprogram. Note that unlike array aggregates, a container
7212 -- aggregate must be fully positional or fully indexed. In the
7213 -- first case the expansion has already taken place.
13112239
ES
7214 -- TBA: the keys for an indexed aggregate must provide a dense
7215 -- range with no repetitions.
08c8883f
ES
7216
7217 if Present (Assign_Indexed_Subp)
7218 and then Present (Component_Associations (N))
7219 then
7a21651f
ES
7220 declare
7221 Insert : constant Entity_Id := Entity (Assign_Indexed_Subp);
7222 Index_Type : constant Entity_Id :=
7223 Etype (Next_Formal (First_Formal (Insert)));
7224
7a21651f
ES
7225 function Expand_Range_Component
7226 (Rng : Node_Id;
7227 Expr : Node_Id) return Node_Id;
7228 -- Transform a component assoication with a range into an
7229 -- explicit loop. If the choice is a subtype name, it is
7230 -- rewritten as a range with the corresponding bounds, which
7231 -- are known to be static.
7232
7233 Comp : Node_Id;
7234 Index : Node_Id;
7235 Pos : Int := 0;
7236 Stat : Node_Id;
7237 Key : Node_Id;
7a21651f
ES
7238
7239 -----------------------------
7240 -- Expand_Raange_Component --
7241 -----------------------------
7242
7243 function Expand_Range_Component
7244 (Rng : Node_Id;
7245 Expr : Node_Id) return Node_Id
7246 is
7247 Loop_Id : constant Entity_Id :=
7248 Make_Temporary (Loc, 'T');
7249
7250 L_Iteration_Scheme : Node_Id;
7251 Stats : List_Id;
7252
7253 begin
7254 L_Iteration_Scheme :=
7255 Make_Iteration_Scheme (Loc,
7256 Loop_Parameter_Specification =>
7257 Make_Loop_Parameter_Specification (Loc,
7258 Defining_Identifier => Loop_Id,
7259 Discrete_Subtype_Definition => New_Copy_Tree (Rng)));
7260
7261 Stats := New_List
7262 (Make_Procedure_Call_Statement (Loc,
7263 Name =>
7264 New_Occurrence_Of (Entity (Assign_Indexed_Subp), Loc),
7265 Parameter_Associations =>
7266 New_List (New_Occurrence_Of (Temp, Loc),
7267 New_Occurrence_Of (Loop_Id, Loc),
7268 New_Copy_Tree (Expr))));
7269
7270 return Make_Implicit_Loop_Statement
7271 (Node => N,
7272 Identifier => Empty,
7273 Iteration_Scheme => L_Iteration_Scheme,
7274 Statements => Stats);
7275 end Expand_Range_Component;
7276
7a21651f 7277 begin
08c8883f 7278 if Siz > 0 then
7a21651f
ES
7279
7280 -- Modify the call to the constructor to allocate the
7281 -- required size for the aggregwte : call the provided
7282 -- constructor rather than the Empty aggregate.
7283
d43fbe01 7284 Index := Make_Op_Add (Loc,
7a21651f 7285 Left_Opnd => New_Copy_Tree (Type_Low_Bound (Index_Type)),
08c8883f 7286 Right_Opnd => Make_Integer_Literal (Loc, Siz - 1));
7a21651f
ES
7287
7288 Set_Expression (Init_Stat,
7289 Make_Function_Call (Loc,
7290 Name =>
7291 New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
7292 Parameter_Associations =>
7293 New_List (
7294 New_Copy_Tree (Type_Low_Bound (Index_Type)),
7295 Index)));
7296 end if;
7297
7298 if Present (Expressions (N)) then
7299 Comp := First (Expressions (N));
7300
7301 while Present (Comp) loop
7302
7303 -- Compute index position for successive components
7304 -- in the list of expressions, and use the indexed
7305 -- assignment procedure for each.
7306
7307 Index := Make_Op_Add (Loc,
7308 Left_Opnd => Type_Low_Bound (Index_Type),
7309 Right_Opnd => Make_Integer_Literal (Loc, Pos));
7310
7311 Stat := Make_Procedure_Call_Statement (Loc,
7312 Name => New_Occurrence_Of (Insert, Loc),
7313 Parameter_Associations =>
7314 New_List (New_Occurrence_Of (Temp, Loc),
7315 Index,
7316 New_Copy_Tree (Comp)));
7317
7318 Pos := Pos + 1;
7319
7320 Append (Stat, Aggr_Code);
7321 Next (Comp);
7322 end loop;
7323 end if;
7324
7325 if Present (Component_Associations (N)) then
7326 Comp := First (Component_Associations (N));
7327
7328 -- The choice may be a static value, or a range with
7329 -- static bounds.
7330
7331 while Present (Comp) loop
7332 if Nkind (Comp) = N_Component_Association then
7333 Key := First (Choices (Comp));
7334 while Present (Key) loop
7335
7336 -- If the expression is a box, the corresponding
7337 -- component (s) is left uninitialized.
7338
7339 if Box_Present (Comp) then
7340 goto Next_Key;
7341
7342 elsif Nkind (Key) = N_Range then
7343
7344 -- Create loop for tne specified range,
7345 -- with copies of the expression.
7346
7347 Stat :=
7348 Expand_Range_Component (Key, Expression (Comp));
7349
7350 else
7351 Stat := Make_Procedure_Call_Statement (Loc,
7352 Name => New_Occurrence_Of
7353 (Entity (Assign_Indexed_Subp), Loc),
7354 Parameter_Associations =>
7355 New_List (New_Occurrence_Of (Temp, Loc),
7356 New_Copy_Tree (Key),
7357 New_Copy_Tree (Expression (Comp))));
7358 end if;
7359
7360 Append (Stat, Aggr_Code);
7361
7362 <<Next_Key>>
7363 Next (Key);
7364 end loop;
08c8883f 7365
7a21651f 7366 else
08c8883f
ES
7367 -- Iterated component association. Discard
7368 -- positional insertion procedure.
7369
7370 Add_Named_Subp := Assign_Indexed_Subp;
7371 Add_Unnamed_Subp := Empty;
7372 Expand_Iterated_Component (Comp);
7a21651f 7373 end if;
08c8883f 7374
7a21651f
ES
7375 Next (Comp);
7376 end loop;
7377 end if;
7378 end;
ce59f39f 7379 end if;
4f6ebe2a 7380
ce59f39f
GD
7381 Insert_Actions (N, Aggr_Code);
7382 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7383 Analyze_And_Resolve (N, Typ);
745f5698
ES
7384 end Expand_Container_Aggregate;
7385
9eb8d5b4
AC
7386 ------------------------------
7387 -- Expand_N_Delta_Aggregate --
7388 ------------------------------
7389
7390 procedure Expand_N_Delta_Aggregate (N : Node_Id) is
9313a26a 7391 Loc : constant Source_Ptr := Sloc (N);
c78efe92 7392 Typ : constant Entity_Id := Etype (Expression (N));
9eb8d5b4
AC
7393 Decl : Node_Id;
7394
7395 begin
9313a26a
AC
7396 Decl :=
7397 Make_Object_Declaration (Loc,
7398 Defining_Identifier => Make_Temporary (Loc, 'T'),
7399 Object_Definition => New_Occurrence_Of (Typ, Loc),
7400 Expression => New_Copy_Tree (Expression (N)));
9eb8d5b4
AC
7401
7402 if Is_Array_Type (Etype (N)) then
7403 Expand_Delta_Array_Aggregate (N, New_List (Decl));
7404 else
7405 Expand_Delta_Record_Aggregate (N, New_List (Decl));
7406 end if;
7407 end Expand_N_Delta_Aggregate;
7408
7409 ----------------------------------
7410 -- Expand_Delta_Array_Aggregate --
7411 ----------------------------------
7412
7413 procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id) is
9313a26a
AC
7414 Loc : constant Source_Ptr := Sloc (N);
7415 Temp : constant Entity_Id := Defining_Identifier (First (Deltas));
7416 Assoc : Node_Id;
7417
9eb8d5b4
AC
7418 function Generate_Loop (C : Node_Id) return Node_Id;
7419 -- Generate a loop containing individual component assignments for
7420 -- choices that are ranges, subtype indications, subtype names, and
7421 -- iterated component associations.
7422
9313a26a
AC
7423 -------------------
7424 -- Generate_Loop --
7425 -------------------
7426
9eb8d5b4
AC
7427 function Generate_Loop (C : Node_Id) return Node_Id is
7428 Sl : constant Source_Ptr := Sloc (C);
7429 Ix : Entity_Id;
7430
7431 begin
7432 if Nkind (Parent (C)) = N_Iterated_Component_Association then
7433 Ix :=
7434 Make_Defining_Identifier (Loc,
7435 Chars => (Chars (Defining_Identifier (Parent (C)))));
7436 else
7437 Ix := Make_Temporary (Sl, 'I');
7438 end if;
7439
7440 return
f3561c06 7441 Make_Implicit_Loop_Statement (C,
9313a26a
AC
7442 Iteration_Scheme =>
7443 Make_Iteration_Scheme (Sl,
7444 Loop_Parameter_Specification =>
7445 Make_Loop_Parameter_Specification (Sl,
7446 Defining_Identifier => Ix,
7447 Discrete_Subtype_Definition => New_Copy_Tree (C))),
7448
7449 Statements => New_List (
7450 Make_Assignment_Statement (Sl,
7451 Name =>
7452 Make_Indexed_Component (Sl,
9eb8d5b4
AC
7453 Prefix => New_Occurrence_Of (Temp, Sl),
7454 Expressions => New_List (New_Occurrence_Of (Ix, Sl))),
9313a26a
AC
7455 Expression => New_Copy_Tree (Expression (Assoc)))),
7456 End_Label => Empty);
9eb8d5b4
AC
7457 end Generate_Loop;
7458
9313a26a
AC
7459 -- Local variables
7460
7461 Choice : Node_Id;
7462
7463 -- Start of processing for Expand_Delta_Array_Aggregate
7464
9eb8d5b4
AC
7465 begin
7466 Assoc := First (Component_Associations (N));
7467 while Present (Assoc) loop
7468 Choice := First (Choice_List (Assoc));
7469 if Nkind (Assoc) = N_Iterated_Component_Association then
7470 while Present (Choice) loop
7471 Append_To (Deltas, Generate_Loop (Choice));
7472 Next (Choice);
7473 end loop;
7474
7475 else
7476 while Present (Choice) loop
7477
7478 -- Choice can be given by a range, a subtype indication, a
7479 -- subtype name, a scalar value, or an entity.
7480
7481 if Nkind (Choice) = N_Range
7482 or else (Is_Entity_Name (Choice)
9313a26a 7483 and then Is_Type (Entity (Choice)))
9eb8d5b4
AC
7484 then
7485 Append_To (Deltas, Generate_Loop (Choice));
7486
7487 elsif Nkind (Choice) = N_Subtype_Indication then
7488 Append_To (Deltas,
7489 Generate_Loop (Range_Expression (Constraint (Choice))));
7490
7491 else
7492 Append_To (Deltas,
9313a26a
AC
7493 Make_Assignment_Statement (Sloc (Choice),
7494 Name =>
7495 Make_Indexed_Component (Sloc (Choice),
7496 Prefix => New_Occurrence_Of (Temp, Loc),
7497 Expressions => New_List (New_Copy_Tree (Choice))),
7498 Expression => New_Copy_Tree (Expression (Assoc))));
9eb8d5b4
AC
7499 end if;
7500
7501 Next (Choice);
7502 end loop;
7503 end if;
7504
7505 Next (Assoc);
7506 end loop;
7507
7508 Insert_Actions (N, Deltas);
7509 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7510 end Expand_Delta_Array_Aggregate;
7511
7512 -----------------------------------
7513 -- Expand_Delta_Record_Aggregate --
7514 -----------------------------------
7515
7516 procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id) is
7517 Loc : constant Source_Ptr := Sloc (N);
7518 Temp : constant Entity_Id := Defining_Identifier (First (Deltas));
7519 Assoc : Node_Id;
7520 Choice : Node_Id;
7521
7522 begin
7523 Assoc := First (Component_Associations (N));
7524
7525 while Present (Assoc) loop
7526 Choice := First (Choice_List (Assoc));
7527 while Present (Choice) loop
7528 Append_To (Deltas,
9313a26a
AC
7529 Make_Assignment_Statement (Sloc (Choice),
7530 Name =>
7531 Make_Selected_Component (Sloc (Choice),
7532 Prefix => New_Occurrence_Of (Temp, Loc),
7533 Selector_Name => Make_Identifier (Loc, Chars (Choice))),
7534 Expression => New_Copy_Tree (Expression (Assoc))));
9eb8d5b4
AC
7535 Next (Choice);
7536 end loop;
7537
7538 Next (Assoc);
7539 end loop;
7540
7541 Insert_Actions (N, Deltas);
7542 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7543 end Expand_Delta_Record_Aggregate;
7544
70482933
RK
7545 ----------------------------------
7546 -- Expand_N_Extension_Aggregate --
7547 ----------------------------------
7548
7549 -- If the ancestor part is an expression, add a component association for
7550 -- the parent field. If the type of the ancestor part is not the direct
d4dfb005
BD
7551 -- parent of the expected type, build recursively the needed ancestors.
7552 -- If the ancestor part is a subtype_mark, replace aggregate with a
7553 -- declaration for a temporary of the expected type, followed by
7554 -- individual assignments to the given components.
70482933
RK
7555
7556 procedure Expand_N_Extension_Aggregate (N : Node_Id) is
70482933 7557 A : constant Node_Id := Ancestor_Part (N);
3fc40cd7 7558 Loc : constant Source_Ptr := Sloc (N);
70482933
RK
7559 Typ : constant Entity_Id := Etype (N);
7560
7561 begin
fbf5a39b 7562 -- If the ancestor is a subtype mark, an init proc must be called
70482933
RK
7563 -- on the resulting object which thus has to be materialized in
7564 -- the front-end
7565
7566 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
7567 Convert_To_Assignments (N, Typ);
7568
7569 -- The extension aggregate is transformed into a record aggregate
7570 -- of the following form (c1 and c2 are inherited components)
7571
7572 -- (Exp with c3 => a, c4 => b)
0877856b 7573 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c3 => a, c4 => b)
70482933
RK
7574
7575 else
7576 Set_Etype (N, Typ);
7577
1f110335 7578 if Tagged_Type_Expansion then
70482933 7579 Expand_Record_Aggregate (N,
a9d8907c
JM
7580 Orig_Tag =>
7581 New_Occurrence_Of
7582 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc),
70482933 7583 Parent_Expr => A);
5c34e9cd
AC
7584
7585 -- No tag is needed in the case of a VM
7586
0f95b178 7587 else
5c34e9cd 7588 Expand_Record_Aggregate (N, Parent_Expr => A);
70482933
RK
7589 end if;
7590 end if;
fbf5a39b
AC
7591
7592 exception
7593 when RE_Not_Available =>
7594 return;
70482933
RK
7595 end Expand_N_Extension_Aggregate;
7596
7597 -----------------------------
7598 -- Expand_Record_Aggregate --
7599 -----------------------------
7600
7601 procedure Expand_Record_Aggregate
7602 (N : Node_Id;
7603 Orig_Tag : Node_Id := Empty;
7604 Parent_Expr : Node_Id := Empty)
7605 is
fbf5a39b
AC
7606 Loc : constant Source_Ptr := Sloc (N);
7607 Comps : constant List_Id := Component_Associations (N);
7608 Typ : constant Entity_Id := Etype (N);
7609 Base_Typ : constant Entity_Id := Base_Type (Typ);
70482933 7610
0f95b178
JM
7611 Static_Components : Boolean := True;
7612 -- Flag to indicate whether all components are compile-time known,
7613 -- and the aggregate can be constructed statically and handled by
d4dfb005 7614 -- the back-end. Set to False by Component_OK_For_Backend.
70482933 7615
54740d7d
AC
7616 procedure Build_Back_End_Aggregate;
7617 -- Build a proper aggregate to be handled by the back-end
7618
f6205414
AC
7619 function Compile_Time_Known_Composite_Value (N : Node_Id) return Boolean;
7620 -- Returns true if N is an expression of composite type which can be
7621 -- fully evaluated at compile time without raising constraint error.
7622 -- Such expressions can be passed as is to Gigi without any expansion.
7623 --
7624 -- This returns true for N_Aggregate with Compile_Time_Known_Aggregate
7625 -- set and constants whose expression is such an aggregate, recursively.
7626
d4dfb005 7627 function Component_OK_For_Backend return Boolean;
b465ef6f 7628 -- Check for presence of a component which makes it impossible for the
0f95b178
JM
7629 -- backend to process the aggregate, thus requiring the use of a series
7630 -- of assignment statements. Cases checked for are a nested aggregate
7631 -- needing Late_Expansion, the presence of a tagged component which may
7632 -- need tag adjustment, and a bit unaligned component reference.
4a76b687
ES
7633 --
7634 -- We also force expansion into assignments if a component is of a
7635 -- mutable type (including a private type with discriminants) because
7636 -- in that case the size of the component to be copied may be smaller
7637 -- than the side of the target, and there is no simple way for gigi
7638 -- to compute the size of the object to be copied.
7639 --
7640 -- NOTE: This is part of the ongoing work to define precisely the
7641 -- interface between front-end and back-end handling of aggregates.
7642 -- In general it is desirable to pass aggregates as they are to gigi,
7643 -- in order to minimize elaboration code. This is one case where the
7644 -- semantics of Ada complicate the analysis and lead to anomalies in
7645 -- the gcc back-end if the aggregate is not expanded into assignments.
d4dfb005
BD
7646 --
7647 -- NOTE: This sets the global Static_Components to False in most, but
7648 -- not all, cases when it returns False.
70482933 7649
9b7924dd
AC
7650 function Has_Per_Object_Constraint (L : List_Id) return Boolean;
7651 -- Return True if any element of L has Has_Per_Object_Constraint set.
7652 -- L should be the Choices component of an N_Component_Association.
7653
57a8057a
AC
7654 function Has_Visible_Private_Ancestor (Id : E) return Boolean;
7655 -- If any ancestor of the current type is private, the aggregate
b465ef6f 7656 -- cannot be built in place. We cannot rely on Has_Private_Ancestor,
57a8057a
AC
7657 -- because it will not be set when type and its parent are in the
7658 -- same scope, and the parent component needs expansion.
7659
7660 function Top_Level_Aggregate (N : Node_Id) return Node_Id;
7661 -- For nested aggregates return the ultimate enclosing aggregate; for
7662 -- non-nested aggregates return N.
7663
54740d7d
AC
7664 ------------------------------
7665 -- Build_Back_End_Aggregate --
7666 ------------------------------
f6205414 7667
54740d7d 7668 procedure Build_Back_End_Aggregate is
4f94fa11
AC
7669 Comp : Entity_Id;
7670 New_Comp : Node_Id;
7671 Tag_Value : Node_Id;
57a8057a
AC
7672
7673 begin
0f95b178
JM
7674 if Nkind (N) = N_Aggregate then
7675
3b9fa2df
ES
7676 -- If the aggregate is static and can be handled by the back-end,
7677 -- nothing left to do.
0f95b178
JM
7678
7679 if Static_Components then
7680 Set_Compile_Time_Known_Aggregate (N);
7681 Set_Expansion_Delayed (N, False);
7682 end if;
7683 end if;
7684
07fc65c4 7685 -- If no discriminants, nothing special to do
70482933 7686
07fc65c4 7687 if not Has_Discriminants (Typ) then
70482933
RK
7688 null;
7689
07fc65c4
GB
7690 -- Case of discriminants present
7691
70482933
RK
7692 elsif Is_Derived_Type (Typ) then
7693
138fc6f1
HK
7694 -- For untagged types, non-stored discriminants are replaced with
7695 -- stored discriminants, which are the ones that gigi uses to
7696 -- describe the type and its components.
70482933 7697
07fc65c4 7698 Generate_Aggregate_For_Derived_Type : declare
fbf5a39b 7699 procedure Prepend_Stored_Values (T : Entity_Id);
3b9fa2df
ES
7700 -- Scan the list of stored discriminants of the type, and add
7701 -- their values to the aggregate being built.
07fc65c4
GB
7702
7703 ---------------------------
fbf5a39b 7704 -- Prepend_Stored_Values --
07fc65c4
GB
7705 ---------------------------
7706
fbf5a39b 7707 procedure Prepend_Stored_Values (T : Entity_Id) is
54740d7d
AC
7708 Discr : Entity_Id;
7709 First_Comp : Node_Id := Empty;
7710
07fc65c4 7711 begin
54740d7d
AC
7712 Discr := First_Stored_Discriminant (T);
7713 while Present (Discr) loop
07fc65c4
GB
7714 New_Comp :=
7715 Make_Component_Association (Loc,
138fc6f1 7716 Choices => New_List (
54740d7d 7717 New_Occurrence_Of (Discr, Loc)),
07fc65c4 7718 Expression =>
bdc193ba
AC
7719 New_Copy_Tree
7720 (Get_Discriminant_Value
54740d7d 7721 (Discr,
07fc65c4
GB
7722 Typ,
7723 Discriminant_Constraint (Typ))));
7724
7725 if No (First_Comp) then
7726 Prepend_To (Component_Associations (N), New_Comp);
7727 else
7728 Insert_After (First_Comp, New_Comp);
7729 end if;
7730
7731 First_Comp := New_Comp;
54740d7d 7732 Next_Stored_Discriminant (Discr);
07fc65c4 7733 end loop;
fbf5a39b 7734 end Prepend_Stored_Values;
07fc65c4 7735
54740d7d
AC
7736 -- Local variables
7737
7738 Constraints : constant List_Id := New_List;
7739
7740 Discr : Entity_Id;
7741 Decl : Node_Id;
7742 Num_Disc : Nat := 0;
81a0f4a3 7743 Num_Stor : Nat := 0;
54740d7d 7744
07fc65c4 7745 -- Start of processing for Generate_Aggregate_For_Derived_Type
70482933
RK
7746
7747 begin
3b9fa2df 7748 -- Remove the associations for the discriminant of derived type
70482933 7749
54740d7d
AC
7750 declare
7751 First_Comp : Node_Id;
70482933 7752
54740d7d
AC
7753 begin
7754 First_Comp := First (Component_Associations (N));
7755 while Present (First_Comp) loop
7756 Comp := First_Comp;
7757 Next (First_Comp);
7758
7759 if Ekind (Entity (First (Choices (Comp)))) =
7760 E_Discriminant
7761 then
7762 Remove (Comp);
7763 Num_Disc := Num_Disc + 1;
7764 end if;
7765 end loop;
7766 end;
70482933 7767
fbf5a39b
AC
7768 -- Insert stored discriminant associations in the correct
7769 -- order. If there are more stored discriminants than new
3b9fa2df
ES
7770 -- discriminants, there is at least one new discriminant that
7771 -- constrains more than one of the stored discriminants. In
7772 -- this case we need to construct a proper subtype of the
7773 -- parent type, in order to supply values to all the
fbf5a39b
AC
7774 -- components. Otherwise there is one-one correspondence
7775 -- between the constraints and the stored discriminants.
70482933 7776
54740d7d
AC
7777 Discr := First_Stored_Discriminant (Base_Type (Typ));
7778 while Present (Discr) loop
81a0f4a3 7779 Num_Stor := Num_Stor + 1;
54740d7d 7780 Next_Stored_Discriminant (Discr);
70482933 7781 end loop;
07fc65c4 7782
fbf5a39b 7783 -- Case of more stored discriminants than new discriminants
07fc65c4 7784
81a0f4a3 7785 if Num_Stor > Num_Disc then
07fc65c4 7786
3b9fa2df
ES
7787 -- Create a proper subtype of the parent type, which is the
7788 -- proper implementation type for the aggregate, and convert
7789 -- it to the intended target type.
07fc65c4 7790
54740d7d
AC
7791 Discr := First_Stored_Discriminant (Base_Type (Typ));
7792 while Present (Discr) loop
07fc65c4 7793 New_Comp :=
37368818
RD
7794 New_Copy_Tree
7795 (Get_Discriminant_Value
54740d7d 7796 (Discr,
bdc193ba
AC
7797 Typ,
7798 Discriminant_Constraint (Typ)));
138fc6f1 7799
07fc65c4 7800 Append (New_Comp, Constraints);
54740d7d 7801 Next_Stored_Discriminant (Discr);
07fc65c4
GB
7802 end loop;
7803
7804 Decl :=
7805 Make_Subtype_Declaration (Loc,
191fcb3a 7806 Defining_Identifier => Make_Temporary (Loc, 'T'),
bdc193ba 7807 Subtype_Indication =>
07fc65c4
GB
7808 Make_Subtype_Indication (Loc,
7809 Subtype_Mark =>
7810 New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
bdc193ba 7811 Constraint =>
07fc65c4
GB
7812 Make_Index_Or_Discriminant_Constraint
7813 (Loc, Constraints)));
7814
7815 Insert_Action (N, Decl);
fbf5a39b 7816 Prepend_Stored_Values (Base_Type (Typ));
07fc65c4
GB
7817
7818 Set_Etype (N, Defining_Identifier (Decl));
7819 Set_Analyzed (N);
7820
7821 Rewrite (N, Unchecked_Convert_To (Typ, N));
7822 Analyze (N);
7823
7824 -- Case where we do not have fewer new discriminants than
3b9fa2df
ES
7825 -- stored discriminants, so in this case we can simply use the
7826 -- stored discriminants of the subtype.
07fc65c4
GB
7827
7828 else
fbf5a39b 7829 Prepend_Stored_Values (Typ);
07fc65c4
GB
7830 end if;
7831 end Generate_Aggregate_For_Derived_Type;
70482933
RK
7832 end if;
7833
7834 if Is_Tagged_Type (Typ) then
7835
22243c12 7836 -- In the tagged case, _parent and _tag component must be created
70482933 7837
22243c12
RD
7838 -- Reset Null_Present unconditionally. Tagged records always have
7839 -- at least one field (the tag or the parent).
70482933
RK
7840
7841 Set_Null_Record_Present (N, False);
7842
7843 -- When the current aggregate comes from the expansion of an
7844 -- extension aggregate, the parent expr is replaced by an
22243c12 7845 -- aggregate formed by selected components of this expr.
70482933 7846
36a66365 7847 if Present (Parent_Expr) and then Is_Empty_List (Comps) then
5277cab6 7848 Comp := First_Component_Or_Discriminant (Typ);
70482933
RK
7849 while Present (Comp) loop
7850
70482933
RK
7851 -- Skip all expander-generated components
7852
bdc193ba 7853 if not Comes_From_Source (Original_Record_Component (Comp))
70482933
RK
7854 then
7855 null;
7856
7857 else
7858 New_Comp :=
7859 Make_Selected_Component (Loc,
bdc193ba 7860 Prefix =>
70482933
RK
7861 Unchecked_Convert_To (Typ,
7862 Duplicate_Subexpr (Parent_Expr, True)),
70482933
RK
7863 Selector_Name => New_Occurrence_Of (Comp, Loc));
7864
7865 Append_To (Comps,
7866 Make_Component_Association (Loc,
54740d7d
AC
7867 Choices => New_List (
7868 New_Occurrence_Of (Comp, Loc)),
37368818 7869 Expression => New_Comp));
70482933
RK
7870
7871 Analyze_And_Resolve (New_Comp, Etype (Comp));
7872 end if;
7873
5277cab6 7874 Next_Component_Or_Discriminant (Comp);
70482933
RK
7875 end loop;
7876 end if;
7877
7878 -- Compute the value for the Tag now, if the type is a root it
7879 -- will be included in the aggregate right away, otherwise it will
22243c12 7880 -- be propagated to the parent aggregate.
70482933
RK
7881
7882 if Present (Orig_Tag) then
7883 Tag_Value := Orig_Tag;
54740d7d 7884
1f110335 7885 elsif not Tagged_Type_Expansion then
70482933 7886 Tag_Value := Empty;
54740d7d 7887
70482933 7888 else
a9d8907c
JM
7889 Tag_Value :=
7890 New_Occurrence_Of
7891 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
70482933
RK
7892 end if;
7893
7894 -- For a derived type, an aggregate for the parent is formed with
7895 -- all the inherited components.
7896
7897 if Is_Derived_Type (Typ) then
70482933
RK
7898 declare
7899 First_Comp : Node_Id;
7900 Parent_Comps : List_Id;
7901 Parent_Aggr : Node_Id;
7902 Parent_Name : Node_Id;
7903
7904 begin
54740d7d 7905 First_Comp := First (Component_Associations (N));
70482933 7906 Parent_Comps := New_List;
567bf449
EB
7907
7908 -- First skip the discriminants
7909
7910 while Present (First_Comp)
7911 and then Ekind (Entity (First (Choices (First_Comp))))
7912 = E_Discriminant
7913 loop
7914 Next (First_Comp);
7915 end loop;
7916
7917 -- Then remove the inherited component association from the
7918 -- aggregate and store them in the parent aggregate
7919
70482933 7920 while Present (First_Comp)
36a66365
AC
7921 and then
7922 Scope (Original_Record_Component
7923 (Entity (First (Choices (First_Comp))))) /=
7924 Base_Typ
70482933
RK
7925 loop
7926 Comp := First_Comp;
7927 Next (First_Comp);
7928 Remove (Comp);
7929 Append (Comp, Parent_Comps);
7930 end loop;
7931
36a66365
AC
7932 Parent_Aggr :=
7933 Make_Aggregate (Loc,
7934 Component_Associations => Parent_Comps);
70482933
RK
7935 Set_Etype (Parent_Aggr, Etype (Base_Type (Typ)));
7936
7937 -- Find the _parent component
7938
7939 Comp := First_Component (Typ);
7940 while Chars (Comp) /= Name_uParent loop
99859ea7 7941 Next_Component (Comp);
70482933
RK
7942 end loop;
7943
7944 Parent_Name := New_Occurrence_Of (Comp, Loc);
7945
7946 -- Insert the parent aggregate
7947
7948 Prepend_To (Component_Associations (N),
7949 Make_Component_Association (Loc,
7950 Choices => New_List (Parent_Name),
7951 Expression => Parent_Aggr));
7952
7953 -- Expand recursively the parent propagating the right Tag
7954
22243c12
RD
7955 Expand_Record_Aggregate
7956 (Parent_Aggr, Tag_Value, Parent_Expr);
1b6897ce
AC
7957
7958 -- The ancestor part may be a nested aggregate that has
7959 -- delayed expansion: recheck now.
7960
d4dfb005 7961 if not Component_OK_For_Backend then
1b6897ce
AC
7962 Convert_To_Assignments (N, Typ);
7963 end if;
70482933
RK
7964 end;
7965
7966 -- For a root type, the tag component is added (unless compiling
0f95b178 7967 -- for the VMs, where tags are implicit).
70482933 7968
1f110335 7969 elsif Tagged_Type_Expansion then
70482933
RK
7970 declare
7971 Tag_Name : constant Node_Id :=
138fc6f1
HK
7972 New_Occurrence_Of
7973 (First_Tag_Component (Typ), Loc);
70482933
RK
7974 Typ_Tag : constant Entity_Id := RTE (RE_Tag);
7975 Conv_Node : constant Node_Id :=
138fc6f1 7976 Unchecked_Convert_To (Typ_Tag, Tag_Value);
70482933
RK
7977
7978 begin
7979 Set_Etype (Conv_Node, Typ_Tag);
7980 Prepend_To (Component_Associations (N),
7981 Make_Component_Association (Loc,
7982 Choices => New_List (Tag_Name),
7983 Expression => Conv_Node));
7984 end;
7985 end if;
7986 end if;
54740d7d
AC
7987 end Build_Back_End_Aggregate;
7988
7989 ----------------------------------------
7990 -- Compile_Time_Known_Composite_Value --
7991 ----------------------------------------
7992
7993 function Compile_Time_Known_Composite_Value
7994 (N : Node_Id) return Boolean
7995 is
7996 begin
7997 -- If we have an entity name, then see if it is the name of a
7998 -- constant and if so, test the corresponding constant value.
7999
8000 if Is_Entity_Name (N) then
8001 declare
8002 E : constant Entity_Id := Entity (N);
8003 V : Node_Id;
8004 begin
8005 if Ekind (E) /= E_Constant then
8006 return False;
8007 else
8008 V := Constant_Value (E);
8009 return Present (V)
8010 and then Compile_Time_Known_Composite_Value (V);
8011 end if;
8012 end;
8013
8014 -- We have a value, see if it is compile time known
8015
8016 else
8017 if Nkind (N) = N_Aggregate then
8018 return Compile_Time_Known_Aggregate (N);
8019 end if;
8020
8021 -- All other types of values are not known at compile time
8022
8023 return False;
8024 end if;
8025
8026 end Compile_Time_Known_Composite_Value;
8027
d4dfb005
BD
8028 ------------------------------
8029 -- Component_OK_For_Backend --
8030 ------------------------------
54740d7d 8031
d4dfb005 8032 function Component_OK_For_Backend return Boolean is
54740d7d
AC
8033 C : Node_Id;
8034 Expr_Q : Node_Id;
8035
8036 begin
54740d7d
AC
8037 C := First (Comps);
8038 while Present (C) loop
8039
8040 -- If the component has box initialization, expansion is needed
8041 -- and component is not ready for backend.
8042
8043 if Box_Present (C) then
d4dfb005 8044 return False;
54740d7d
AC
8045 end if;
8046
4f061cf2 8047 Expr_Q := Unqualify (Expression (C));
54740d7d 8048
f4c26077
ES
8049 -- Return False for array components whose bounds raise
8050 -- constraint error.
8051
8052 declare
61770974 8053 Comp : constant Entity_Id := First (Choices (C));
f4c26077
ES
8054 Indx : Node_Id;
8055
8056 begin
f4c26077
ES
8057 if Present (Etype (Comp))
8058 and then Is_Array_Type (Etype (Comp))
8059 then
8060 Indx := First_Index (Etype (Comp));
f4c26077 8061 while Present (Indx) loop
61770974
HK
8062 if Nkind (Type_Low_Bound (Etype (Indx))) =
8063 N_Raise_Constraint_Error
8064 or else Nkind (Type_High_Bound (Etype (Indx))) =
8065 N_Raise_Constraint_Error
f4c26077
ES
8066 then
8067 return False;
8068 end if;
8069
99859ea7 8070 Next_Index (Indx);
f4c26077
ES
8071 end loop;
8072 end if;
8073 end;
8074
d4dfb005 8075 -- Return False if the aggregate has any associations for tagged
54740d7d
AC
8076 -- components that may require tag adjustment.
8077
8078 -- These are cases where the source expression may have a tag that
8079 -- could differ from the component tag (e.g., can occur for type
8080 -- conversions and formal parameters). (Tag adjustment not needed
8081 -- if Tagged_Type_Expansion because object tags are implicit in
8082 -- the machine.)
8083
8084 if Is_Tagged_Type (Etype (Expr_Q))
61770974
HK
8085 and then
8086 (Nkind (Expr_Q) = N_Type_Conversion
8087 or else
8088 (Is_Entity_Name (Expr_Q)
bb6a856b 8089 and then Is_Formal (Entity (Expr_Q))))
54740d7d
AC
8090 and then Tagged_Type_Expansion
8091 then
8092 Static_Components := False;
d4dfb005 8093 return False;
54740d7d
AC
8094
8095 elsif Is_Delayed_Aggregate (Expr_Q) then
8096 Static_Components := False;
d4dfb005 8097 return False;
54740d7d 8098
1f6237e3
ES
8099 elsif Nkind (Expr_Q) = N_Quantified_Expression then
8100 Static_Components := False;
8101 return False;
8102
54740d7d
AC
8103 elsif Possible_Bit_Aligned_Component (Expr_Q) then
8104 Static_Components := False;
d4dfb005 8105 return False;
54740d7d
AC
8106
8107 elsif Modify_Tree_For_C
8108 and then Nkind (C) = N_Component_Association
8109 and then Has_Per_Object_Constraint (Choices (C))
8110 then
8111 Static_Components := False;
d4dfb005 8112 return False;
54740d7d
AC
8113
8114 elsif Modify_Tree_For_C
8115 and then Nkind (Expr_Q) = N_Identifier
8116 and then Is_Array_Type (Etype (Expr_Q))
8117 then
8118 Static_Components := False;
d4dfb005 8119 return False;
b276ab7a
AC
8120
8121 elsif Modify_Tree_For_C
8122 and then Nkind (Expr_Q) = N_Type_Conversion
8123 and then Is_Array_Type (Etype (Expr_Q))
8124 then
8125 Static_Components := False;
d4dfb005 8126 return False;
54740d7d
AC
8127 end if;
8128
8129 if Is_Elementary_Type (Etype (Expr_Q)) then
8130 if not Compile_Time_Known_Value (Expr_Q) then
8131 Static_Components := False;
8132 end if;
8133
8134 elsif not Compile_Time_Known_Composite_Value (Expr_Q) then
8135 Static_Components := False;
8136
8137 if Is_Private_Type (Etype (Expr_Q))
8138 and then Has_Discriminants (Etype (Expr_Q))
8139 then
d4dfb005 8140 return False;
54740d7d
AC
8141 end if;
8142 end if;
8143
8144 Next (C);
8145 end loop;
8146
d4dfb005
BD
8147 return True;
8148 end Component_OK_For_Backend;
54740d7d
AC
8149
8150 -------------------------------
8151 -- Has_Per_Object_Constraint --
8152 -------------------------------
8153
8154 function Has_Per_Object_Constraint (L : List_Id) return Boolean is
8155 N : Node_Id := First (L);
8156 begin
8157 while Present (N) loop
8158 if Is_Entity_Name (N)
8159 and then Present (Entity (N))
8160 and then Has_Per_Object_Constraint (Entity (N))
8161 then
8162 return True;
8163 end if;
8164
8165 Next (N);
8166 end loop;
8167
8168 return False;
8169 end Has_Per_Object_Constraint;
8170
8171 -----------------------------------
8172 -- Has_Visible_Private_Ancestor --
8173 -----------------------------------
8174
8175 function Has_Visible_Private_Ancestor (Id : E) return Boolean is
8176 R : constant Entity_Id := Root_Type (Id);
8177 T1 : Entity_Id := Id;
8178
8179 begin
8180 loop
8181 if Is_Private_Type (T1) then
8182 return True;
8183
8184 elsif T1 = R then
8185 return False;
8186
8187 else
8188 T1 := Etype (T1);
8189 end if;
8190 end loop;
8191 end Has_Visible_Private_Ancestor;
4f94fa11
AC
8192
8193 -------------------------
8194 -- Top_Level_Aggregate --
8195 -------------------------
8196
8197 function Top_Level_Aggregate (N : Node_Id) return Node_Id is
8198 Aggr : Node_Id;
8199
8200 begin
8201 Aggr := N;
8202 while Present (Parent (Aggr))
4a08c95c
AC
8203 and then Nkind (Parent (Aggr)) in
8204 N_Aggregate | N_Component_Association
4f94fa11
AC
8205 loop
8206 Aggr := Parent (Aggr);
8207 end loop;
8208
8209 return Aggr;
8210 end Top_Level_Aggregate;
8211
8212 -- Local variables
8213
8214 Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N);
8215
8216 -- Start of processing for Expand_Record_Aggregate
8217
8218 begin
4f94fa11
AC
8219 -- No special management required for aggregates used to initialize
8220 -- statically allocated dispatch tables
8221
c061e99b 8222 if Is_Static_Dispatch_Table_Aggregate (N) then
4f94fa11 8223 return;
e1dfbb03
SB
8224
8225 -- Case pattern aggregates need to remain as aggregates
8226
8227 elsif Is_Case_Choice_Pattern (N) then
8228 return;
70482933 8229 end if;
0f95b178 8230
8973b987 8231 -- If the pragma Aggregate_Individually_Assign is set, always convert to
efc00a88
PB
8232 -- assignments.
8233
8234 if Aggregate_Individually_Assign then
8235 Convert_To_Assignments (N, Typ);
8236
4f94fa11
AC
8237 -- Ada 2005 (AI-318-2): We need to convert to assignments if components
8238 -- are build-in-place function calls. The assignments will each turn
8239 -- into a build-in-place function call. If components are all static,
d4dfb005 8240 -- we can pass the aggregate to the back end regardless of limitedness.
4f94fa11
AC
8241
8242 -- Extension aggregates, aggregates in extended return statements, and
8243 -- aggregates for C++ imported types must be expanded.
8244
efc00a88 8245 elsif Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
4a08c95c
AC
8246 if Nkind (Parent (N)) not in
8247 N_Component_Association | N_Object_Declaration
4f94fa11
AC
8248 then
8249 Convert_To_Assignments (N, Typ);
8250
8251 elsif Nkind (N) = N_Extension_Aggregate
8252 or else Convention (Typ) = Convention_CPP
8253 then
8254 Convert_To_Assignments (N, Typ);
8255
8256 elsif not Size_Known_At_Compile_Time (Typ)
d4dfb005 8257 or else not Component_OK_For_Backend
4f94fa11
AC
8258 or else not Static_Components
8259 then
8260 Convert_To_Assignments (N, Typ);
8261
8262 -- In all other cases, build a proper aggregate to be handled by
23a9215f 8263 -- the back-end.
4f94fa11
AC
8264
8265 else
54740d7d 8266 Build_Back_End_Aggregate;
4f94fa11
AC
8267 end if;
8268
8269 -- Gigi doesn't properly handle temporaries of variable size so we
8270 -- generate it in the front-end
8271
8272 elsif not Size_Known_At_Compile_Time (Typ)
8273 and then Tagged_Type_Expansion
8274 then
8275 Convert_To_Assignments (N, Typ);
8276
8277 -- An aggregate used to initialize a controlled object must be turned
8278 -- into component assignments as the components themselves may require
8279 -- finalization actions such as adjustment.
8280
8281 elsif Needs_Finalization (Typ) then
8282 Convert_To_Assignments (N, Typ);
8283
8284 -- Ada 2005 (AI-287): In case of default initialized components we
8285 -- convert the aggregate into assignments.
8286
8287 elsif Has_Default_Init_Comps (N) then
8288 Convert_To_Assignments (N, Typ);
8289
8290 -- Check components
8291
d4dfb005 8292 elsif not Component_OK_For_Backend then
4f94fa11
AC
8293 Convert_To_Assignments (N, Typ);
8294
8295 -- If an ancestor is private, some components are not inherited and we
8296 -- cannot expand into a record aggregate.
8297
8298 elsif Has_Visible_Private_Ancestor (Typ) then
8299 Convert_To_Assignments (N, Typ);
8300
8301 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
8302 -- is not able to handle the aggregate for Late_Request.
8303
8304 elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
8305 Convert_To_Assignments (N, Typ);
8306
8307 -- If the tagged types covers interface types we need to initialize all
8308 -- hidden components containing pointers to secondary dispatch tables.
8309
8310 elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then
8311 Convert_To_Assignments (N, Typ);
8312
8313 -- If some components are mutable, the size of the aggregate component
8314 -- may be distinct from the default size of the type component, so
8315 -- we need to expand to insure that the back-end copies the proper
8316 -- size of the data. However, if the aggregate is the initial value of
8317 -- a constant, the target is immutable and might be built statically
8318 -- if components are appropriate.
8319
8320 elsif Has_Mutable_Components (Typ)
8321 and then
8322 (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration
8323 or else not Constant_Present (Parent (Top_Level_Aggr))
8324 or else not Static_Components)
8325 then
8326 Convert_To_Assignments (N, Typ);
8327
8328 -- If the type involved has bit aligned components, then we are not sure
8329 -- that the back end can handle this case correctly.
8330
8331 elsif Type_May_Have_Bit_Aligned_Components (Typ) then
8332 Convert_To_Assignments (N, Typ);
8333
8334 -- When generating C, only generate an aggregate when declaring objects
8335 -- since C does not support aggregates in e.g. assignment statements.
8336
9f51b855 8337 elsif Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
4f94fa11
AC
8338 Convert_To_Assignments (N, Typ);
8339
8340 -- In all other cases, build a proper aggregate to be handled by gigi
8341
8342 else
54740d7d 8343 Build_Back_End_Aggregate;
4f94fa11 8344 end if;
70482933
RK
8345 end Expand_Record_Aggregate;
8346
a80b1eb7
EB
8347 ---------------------
8348 -- Get_Base_Object --
8349 ---------------------
8350
8351 function Get_Base_Object (N : Node_Id) return Entity_Id is
8352 R : Node_Id;
8353
8354 begin
8355 R := Get_Referenced_Object (N);
8356
4a08c95c 8357 while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice
a80b1eb7
EB
8358 loop
8359 R := Get_Referenced_Object (Prefix (R));
8360 end loop;
8361
8362 if Is_Entity_Name (R) and then Is_Object (Entity (R)) then
8363 return Entity (R);
8364 else
8365 return Empty;
8366 end if;
8367 end Get_Base_Object;
8368
65356e64
AC
8369 ----------------------------
8370 -- Has_Default_Init_Comps --
8371 ----------------------------
8372
8373 function Has_Default_Init_Comps (N : Node_Id) return Boolean is
b52e1520 8374 Assoc : Node_Id;
c45b6ae0 8375 Expr : Node_Id;
b52e1520 8376 -- Component association and expression, respectively
bdc193ba 8377
65356e64 8378 begin
4a08c95c 8379 pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate);
c45b6ae0 8380
c5ee5ad2
BD
8381 if Has_Self_Reference (N) then
8382 return True;
8383 end if;
8384
b52e1520
PT
8385 Assoc := First (Component_Associations (N));
8386 while Present (Assoc) loop
8387 -- Each component association has either a box or an expression
c45b6ae0 8388
b52e1520 8389 pragma Assert (Box_Present (Assoc) xor Present (Expression (Assoc)));
65356e64 8390
b52e1520 8391 -- Check if any direct component has default initialized components
c45b6ae0 8392
b52e1520
PT
8393 if Box_Present (Assoc) then
8394 return True;
c45b6ae0 8395
b52e1520 8396 -- Recursive call in case of aggregate expression
c45b6ae0 8397
b52e1520
PT
8398 else
8399 Expr := Expression (Assoc);
8400
8401 if Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
8402 and then Has_Default_Init_Comps (Expr)
8403 then
8404 return True;
8405 end if;
c45b6ae0
AC
8406 end if;
8407
b52e1520 8408 Next (Assoc);
c45b6ae0
AC
8409 end loop;
8410
65356e64
AC
8411 return False;
8412 end Has_Default_Init_Comps;
8413
fc84947c
EB
8414 --------------------------
8415 -- Initialize_Component --
8416 --------------------------
8417
8418 procedure Initialize_Component
8419 (N : Node_Id;
8420 Comp : Node_Id;
8421 Comp_Typ : Entity_Id;
8422 Init_Expr : Node_Id;
be3a8f91
EB
8423 Stmts : List_Id)
8424 is
8425 Init_Expr_Q : constant Node_Id := Unqualify (Init_Expr);
8426 Loc : constant Source_Ptr := Sloc (N);
8427
fc84947c 8428 begin
be3a8f91
EB
8429 -- If the initialization expression of a component with controlled type
8430 -- is a conditional expression that has a function call as one of its
8431 -- dependent expressions, then we need to expand it immediately, so as
8432 -- to trigger the special processing for function calls with controlled
8433 -- type below and avoid a wrong order of initialization, adjustment and
8434 -- finalization in the context of aggregates. For the sake of uniformity
8435 -- we perform this expansion for all conditional expressions.
8436
8437 if Nkind (Init_Expr_Q) = N_If_Expression
8438 and then Present (Comp_Typ)
8439 and then Needs_Finalization (Comp_Typ)
8440 then
8441 declare
8442 Cond : constant Node_Id := First (Expressions (Init_Expr_Q));
8443 Thenx : constant Node_Id := Next (Cond);
8444 Elsex : constant Node_Id := Next (Thenx);
8445 Then_Stmts : constant List_Id := New_List;
8446 Else_Stmts : constant List_Id := New_List;
8447
8448 If_Stmt : Node_Id;
8449
8450 begin
8451 Initialize_Component
8452 (N => N,
8453 Comp => Comp,
8454 Comp_Typ => Comp_Typ,
8455 Init_Expr => Thenx,
8456 Stmts => Then_Stmts);
8457
8458 Initialize_Component
8459 (N => N,
8460 Comp => Comp,
8461 Comp_Typ => Comp_Typ,
8462 Init_Expr => Elsex,
8463 Stmts => Else_Stmts);
8464
8465 If_Stmt :=
8466 Make_Implicit_If_Statement (N,
8467 Condition => Relocate_Node (Cond),
8468 Then_Statements => Then_Stmts,
8469 Else_Statements => Else_Stmts);
8470
8471 Set_From_Conditional_Expression (If_Stmt);
8472 Append_To (Stmts, If_Stmt);
8473 end;
8474
8475 elsif Nkind (Init_Expr_Q) = N_Case_Expression
8476 and then Present (Comp_Typ)
8477 and then Needs_Finalization (Comp_Typ)
8478 then
8479 declare
8480 Alt : Node_Id;
8481 Alt_Stmts : List_Id;
8482 Case_Stmt : Node_Id;
8483
8484 begin
8485 Case_Stmt :=
8486 Make_Case_Statement (Loc,
8487 Expression =>
8488 Relocate_Node (Expression (Init_Expr_Q)),
8489 Alternatives => New_List);
8490
8491 Alt := First (Alternatives (Init_Expr_Q));
8492 while Present (Alt) loop
8493 declare
8494 Alt_Expr : constant Node_Id := Expression (Alt);
8495 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
8496
8497 begin
8498 Alt_Stmts := New_List;
8499
8500 Initialize_Component
8501 (N => N,
8502 Comp => Comp,
8503 Comp_Typ => Comp_Typ,
8504 Init_Expr => Alt_Expr,
8505 Stmts => Alt_Stmts);
8506
8507 Append_To
8508 (Alternatives (Case_Stmt),
8509 Make_Case_Statement_Alternative (Alt_Loc,
8510 Discrete_Choices => Discrete_Choices (Alt),
8511 Statements => Alt_Stmts));
8512 end;
8513
8514 Next (Alt);
8515 end loop;
8516
8517 Set_From_Conditional_Expression (Case_Stmt);
8518 Append_To (Stmts, Case_Stmt);
8519 end;
8520
fc84947c
EB
8521 -- Handle an initialization expression of a controlled type in
8522 -- case it denotes a function call. In general such a scenario
8523 -- will produce a transient scope, but this will lead to wrong
8524 -- order of initialization, adjustment, and finalization in the
8525 -- context of aggregates.
8526
8527 -- Comp := Ctrl_Func_Call;
8528
8529 -- begin -- scope
8530 -- Trans_Obj : ... := Ctrl_Func_Call; -- object
8531 -- Comp := Trans_Obj;
8532 -- Finalize (Trans_Obj);
8533 -- end;
8534 -- Comp._tag := ...;
8535 -- Adjust (Comp (1));
8536
8537 -- In the example above, the call to Finalize occurs too early
8538 -- and as a result it may leave the array component in a bad
8539 -- state. Finalization of the transient object should really
8540 -- happen after adjustment.
8541
8542 -- To avoid this scenario, perform in-place side-effect removal
8543 -- of the function call. This eliminates the transient property
8544 -- of the function result and ensures correct order of actions.
8545
8546 -- Res : ... := Ctrl_Func_Call;
8547 -- Comp := Res;
8548 -- Comp._tag := ...;
8549 -- Adjust (Comp);
8550 -- Finalize (Res);
8551
be3a8f91
EB
8552 elsif Nkind (Init_Expr_Q) /= N_Aggregate
8553 and then Present (Comp_Typ)
fc84947c 8554 and then Needs_Finalization (Comp_Typ)
fc84947c
EB
8555 then
8556 Initialize_Controlled_Component
8557 (N => N,
8558 Comp => Comp,
8559 Comp_Typ => Comp_Typ,
8560 Init_Expr => Init_Expr,
8561 Stmts => Stmts);
8562
8563 -- Otherwise perform simple component initialization
8564
8565 else
8566 Initialize_Simple_Component
8567 (N => N,
8568 Comp => Comp,
8569 Comp_Typ => Comp_Typ,
8570 Init_Expr => Init_Expr,
8571 Stmts => Stmts);
8572 end if;
8573 end Initialize_Component;
8574
8575 -------------------------------------
8576 -- Initialize_Controlled_Component --
8577 -------------------------------------
8578
8579 procedure Initialize_Controlled_Component
8580 (N : Node_Id;
8581 Comp : Node_Id;
8582 Comp_Typ : Entity_Id;
8583 Init_Expr : Node_Id;
8584 Stmts : List_Id)
8585 is
8586 Init_Expr_Q : constant Node_Id := Unqualify (Init_Expr);
8587 Loc : constant Source_Ptr := Sloc (N);
8588
8589 Fin_Call : Node_Id;
8590 Hook_Clear : Node_Id;
8591
8592 In_Place_Expansion : Boolean;
8593 -- Flag set when a nonlimited controlled function call requires
8594 -- in-place expansion.
8595
8596 begin
8597 -- Perform a preliminary analysis and resolution to determine what
8598 -- the initialization expression denotes. Unanalyzed function calls
8599 -- may appear as identifiers or indexed components.
8600
8601 if Nkind (Init_Expr_Q) in N_Function_Call
8602 | N_Identifier
8603 | N_Indexed_Component
8604 and then not Analyzed (Init_Expr)
8605 then
8606 Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
8607 end if;
8608
8609 In_Place_Expansion :=
8610 Nkind (Init_Expr_Q) = N_Function_Call
8611 and then not Is_Build_In_Place_Result_Type (Comp_Typ);
8612
8613 -- The initialization expression is a controlled function call.
8614 -- Perform in-place removal of side effects to avoid creating a
8615 -- transient scope.
8616
8617 -- This in-place expansion is not performed for limited transient
8618 -- objects because the initialization is already done in place.
8619
8620 if In_Place_Expansion then
8621
8622 -- Suppress the removal of side effects by general analysis
8623 -- because this behavior is emulated here. This avoids the
8624 -- generation of a transient scope, which leads to out-of-order
8625 -- adjustment and finalization.
8626
8627 Set_No_Side_Effect_Removal (Init_Expr);
8628
8629 -- Install all hook-related declarations and prepare the clean up
8630 -- statements. The generated code follows the initialization order
8631 -- of individual components and discriminants, rather than being
8632 -- inserted prior to the aggregate. This ensures that a transient
8633 -- component which mentions a discriminant has proper visibility
8634 -- of the discriminant.
8635
8636 Process_Transient_Component
8637 (Loc => Loc,
8638 Comp_Typ => Comp_Typ,
8639 Init_Expr => Init_Expr,
8640 Fin_Call => Fin_Call,
8641 Hook_Clear => Hook_Clear,
8642 Stmts => Stmts);
8643 end if;
8644
8645 -- Use the simple component initialization circuitry to assign the
8646 -- result of the function call to the component. This also performs
8647 -- tag adjustment and [deep] adjustment of the component.
8648
8649 Initialize_Simple_Component
8650 (N => N,
8651 Comp => Comp,
8652 Comp_Typ => Comp_Typ,
8653 Init_Expr => Init_Expr,
8654 Stmts => Stmts);
8655
8656 -- At this point the component is fully initialized. Complete the
8657 -- processing by finalizing the transient function result.
8658
8659 if In_Place_Expansion then
8660 Process_Transient_Component_Completion
8661 (Loc => Loc,
8662 Aggr => N,
8663 Fin_Call => Fin_Call,
8664 Hook_Clear => Hook_Clear,
8665 Stmts => Stmts);
8666 end if;
8667 end Initialize_Controlled_Component;
8668
8669 ---------------------------------
8670 -- Initialize_Simple_Component --
8671 ---------------------------------
8672
8673 procedure Initialize_Simple_Component
8674 (N : Node_Id;
8675 Comp : Node_Id;
8676 Comp_Typ : Node_Id;
8677 Init_Expr : Node_Id;
8678 Stmts : List_Id)
8679 is
8680 Exceptions_OK : constant Boolean :=
8681 not Restriction_Active (No_Exception_Propagation);
8682 Finalization_OK : constant Boolean :=
8683 Present (Comp_Typ)
8684 and then Needs_Finalization (Comp_Typ);
8685 Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
8686 Loc : constant Source_Ptr := Sloc (N);
8687
8688 Adj_Call : Node_Id;
8689 Blk_Stmts : List_Id;
8690 Init_Stmt : Node_Id;
8691
8692 begin
8693 pragma Assert (Nkind (Init_Expr) in N_Subexpr);
8694
8695 -- Protect the initialization statements from aborts. Generate:
8696
8697 -- Abort_Defer;
8698
8699 if Finalization_OK and Abort_Allowed then
8700 if Exceptions_OK then
8701 Blk_Stmts := New_List;
8702 else
8703 Blk_Stmts := Stmts;
8704 end if;
8705
8706 Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
8707
8708 -- Otherwise aborts are not allowed. All generated code is added
8709 -- directly to the input list.
8710
8711 else
8712 Blk_Stmts := Stmts;
8713 end if;
8714
8715 -- Initialize the component. Generate:
8716
8717 -- Comp := Init_Expr;
8718
8719 -- Note that the initialization expression is not duplicated because
8720 -- either only a single component may be initialized by it (record)
8721 -- or it has already been duplicated if need be (array).
8722
8723 Init_Stmt :=
8724 Make_OK_Assignment_Statement (Loc,
8725 Name => New_Copy_Tree (Comp),
8726 Expression => Relocate_Node (Init_Expr));
8727 Set_No_Ctrl_Actions (Init_Stmt);
8728
8729 Append_To (Blk_Stmts, Init_Stmt);
8730
8731 -- Adjust the tag due to a possible view conversion. Generate:
8732
8733 -- Comp._tag := Full_TypeP;
8734
8735 if Tagged_Type_Expansion
8736 and then Present (Comp_Typ)
8737 and then Is_Tagged_Type (Comp_Typ)
8738 then
8739 Append_To (Blk_Stmts,
af10c962
EB
8740 Make_Tag_Assignment_From_Type
8741 (Loc, New_Copy_Tree (Comp), Full_Typ));
fc84947c
EB
8742 end if;
8743
8744 -- Adjust the component. In the case of an array aggregate, controlled
8745 -- subaggregates are not considered because each of their individual
8746 -- elements will receive an adjustment of its own. Generate:
8747
8748 -- [Deep_]Adjust (Comp);
8749
8750 if Finalization_OK
8751 and then not Is_Limited_Type (Comp_Typ)
8752 and then not Is_Build_In_Place_Function_Call (Init_Expr)
8753 and then not
8754 (Is_Array_Type (Etype (N))
8755 and then Is_Array_Type (Comp_Typ)
8756 and then Needs_Finalization (Component_Type (Comp_Typ))
8757 and then Nkind (Unqualify (Init_Expr)) = N_Aggregate)
8758 then
8759 Adj_Call :=
8760 Make_Adjust_Call
8761 (Obj_Ref => New_Copy_Tree (Comp),
8762 Typ => Comp_Typ);
8763
8764 -- Guard against a missing [Deep_]Adjust when the component type
8765 -- was not properly frozen.
8766
8767 if Present (Adj_Call) then
8768 Append_To (Blk_Stmts, Adj_Call);
8769 end if;
8770 end if;
8771
8772 -- Complete the protection of the initialization statements
8773
8774 if Finalization_OK and Abort_Allowed then
8775
8776 -- Wrap the initialization statements in a block to catch a
8777 -- potential exception. Generate:
8778
8779 -- begin
8780 -- Abort_Defer;
8781 -- Comp := Init_Expr;
8782 -- Comp._tag := Full_TypP;
8783 -- [Deep_]Adjust (Comp);
8784 -- at end
8785 -- Abort_Undefer_Direct;
8786 -- end;
8787
8788 if Exceptions_OK then
8789 Append_To (Stmts,
8790 Build_Abort_Undefer_Block (Loc,
8791 Stmts => Blk_Stmts,
8792 Context => N));
8793
8794 -- Otherwise exceptions are not propagated. Generate:
8795
8796 -- Abort_Defer;
8797 -- Comp := Init_Expr;
8798 -- Comp._tag := Full_TypP;
8799 -- [Deep_]Adjust (Comp);
8800 -- Abort_Undefer;
8801
8802 else
8803 Append_To (Blk_Stmts,
8804 Build_Runtime_Call (Loc, RE_Abort_Undefer));
8805 end if;
8806 end if;
8807 end Initialize_Simple_Component;
8808
3fc40cd7
PMR
8809 ----------------------------------------
8810 -- Is_Build_In_Place_Aggregate_Return --
8811 ----------------------------------------
8812
8813 function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is
8814 P : Node_Id := Parent (N);
8815
8816 begin
8817 while Nkind (P) = N_Qualified_Expression loop
8818 P := Parent (P);
8819 end loop;
8820
8821 if Nkind (P) = N_Simple_Return_Statement then
8822 null;
8823
8824 elsif Nkind (Parent (P)) = N_Extended_Return_Statement then
8825 P := Parent (P);
8826
8827 else
8828 return False;
8829 end if;
8830
8831 return
8832 Is_Build_In_Place_Function
8833 (Return_Applies_To (Return_Statement_Entity (P)));
8834 end Is_Build_In_Place_Aggregate_Return;
8835
70482933
RK
8836 --------------------------
8837 -- Is_Delayed_Aggregate --
8838 --------------------------
8839
8840 function Is_Delayed_Aggregate (N : Node_Id) return Boolean is
4f061cf2 8841 Unqual_N : constant Node_Id := Unqualify (N);
fbf5a39b 8842
70482933 8843 begin
4f061cf2
EB
8844 return Nkind (Unqual_N) in N_Aggregate | N_Extension_Aggregate
8845 and then Expansion_Delayed (Unqual_N);
70482933
RK
8846 end Is_Delayed_Aggregate;
8847
9f51b855
JM
8848 --------------------------------
8849 -- Is_CCG_Supported_Aggregate --
8850 --------------------------------
6031f544 8851
9f51b855
JM
8852 function Is_CCG_Supported_Aggregate
8853 (N : Node_Id) return Boolean
8854 is
4ff5aa0c 8855 P : Node_Id := Parent (N);
2401c98f 8856
6031f544 8857 begin
bc1146e5
HK
8858 -- Aggregates are not supported for nonstandard rep clauses, since they
8859 -- may lead to extra padding fields in CCG.
4ff5aa0c 8860
3bcf8298 8861 if Is_Record_Type (Etype (N))
4ff5aa0c
AC
8862 and then Has_Non_Standard_Rep (Etype (N))
8863 then
8864 return False;
8865 end if;
6031f544 8866
4ff5aa0c 8867 while Present (P) and then Nkind (P) = N_Aggregate loop
6031f544
AC
8868 P := Parent (P);
8869 end loop;
8870
d2d56bba 8871 -- Check cases where aggregates are supported by the CCG backend
9f51b855 8872
4ff5aa0c 8873 if Nkind (P) = N_Object_Declaration then
d2d56bba
JM
8874 declare
8875 P_Typ : constant Entity_Id := Etype (Defining_Identifier (P));
9f51b855 8876
d2d56bba
JM
8877 begin
8878 if Is_Record_Type (P_Typ) then
8879 return True;
8880 else
8881 return Compile_Time_Known_Bounds (P_Typ);
8882 end if;
8883 end;
8884
8885 elsif Nkind (P) = N_Qualified_Expression then
8886 if Nkind (Parent (P)) = N_Object_Declaration then
8887 declare
8888 P_Typ : constant Entity_Id :=
8889 Etype (Defining_Identifier (Parent (P)));
8890 begin
8891 if Is_Record_Type (P_Typ) then
8892 return True;
8893 else
8894 return Compile_Time_Known_Bounds (P_Typ);
8895 end if;
8896 end;
8897
8898 elsif Nkind (Parent (P)) = N_Allocator then
8899 return True;
8900 end if;
9f51b855
JM
8901 end if;
8902
6031f544 8903 return False;
9f51b855 8904 end Is_CCG_Supported_Aggregate;
6031f544 8905
fa57ac97
ES
8906 ----------------------------------------
8907 -- Is_Static_Dispatch_Table_Aggregate --
8908 ----------------------------------------
8909
8910 function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean is
8911 Typ : constant Entity_Id := Base_Type (Etype (N));
8912
8913 begin
6214b83b 8914 return Building_Static_Dispatch_Tables
1f110335 8915 and then Tagged_Type_Expansion
fa57ac97
ES
8916
8917 -- Avoid circularity when rebuilding the compiler
8918
3477e0b2
PT
8919 and then not Is_RTU (Cunit_Entity (Get_Source_Unit (N)), Ada_Tags)
8920 and then (Is_RTE (Typ, RE_Dispatch_Table_Wrapper)
fa57ac97 8921 or else
3477e0b2 8922 Is_RTE (Typ, RE_Address_Array)
fa57ac97 8923 or else
3477e0b2 8924 Is_RTE (Typ, RE_Type_Specific_Data)
fa57ac97 8925 or else
3477e0b2 8926 Is_RTE (Typ, RE_Tag_Table)
fa57ac97 8927 or else
3477e0b2 8928 Is_RTE (Typ, RE_Object_Specific_Data)
c7cb99f8 8929 or else
3477e0b2 8930 Is_RTE (Typ, RE_Interface_Data)
fa57ac97 8931 or else
3477e0b2 8932 Is_RTE (Typ, RE_Interfaces_Array)
fa57ac97 8933 or else
3477e0b2 8934 Is_RTE (Typ, RE_Interface_Data_Element));
fa57ac97
ES
8935 end Is_Static_Dispatch_Table_Aggregate;
8936
dc3af7e2
AC
8937 -----------------------------
8938 -- Is_Two_Dim_Packed_Array --
8939 -----------------------------
8940
8941 function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean is
36e38022 8942 C : constant Uint := Component_Size (Typ);
dc3af7e2
AC
8943 begin
8944 return Number_Dimensions (Typ) = 2
8945 and then Is_Bit_Packed_Array (Typ)
36e38022 8946 and then C in Uint_1 | Uint_2 | Uint_4; -- False if No_Uint
dc3af7e2
AC
8947 end Is_Two_Dim_Packed_Array;
8948
70482933
RK
8949 --------------------
8950 -- Late_Expansion --
8951 --------------------
8952
8953 function Late_Expansion
8954 (N : Node_Id;
8955 Typ : Entity_Id;
df3e68b1 8956 Target : Node_Id) return List_Id
9bc856dd 8957 is
f29afe5f 8958 Aggr_Code : List_Id;
b748c3d1 8959 New_Aggr : Node_Id;
f29afe5f 8960
70482933 8961 begin
b748c3d1
EB
8962 if Is_Array_Type (Typ) then
8963 -- If the assignment can be done directly by the back end, then
8964 -- reset Set_Expansion_Delayed and do not expand further.
8965
8966 if not CodePeer_Mode
8967 and then not Modify_Tree_For_C
8968 and then not Possible_Bit_Aligned_Component (Target)
8969 and then not Is_Possibly_Unaligned_Slice (Target)
8970 and then Aggr_Assignment_OK_For_Backend (N)
8971 then
8972 New_Aggr := New_Copy_Tree (N);
8973 Set_Expansion_Delayed (New_Aggr, False);
8974
8975 Aggr_Code :=
8976 New_List (
8977 Make_OK_Assignment_Statement (Sloc (New_Aggr),
8978 Name => Target,
8979 Expression => New_Aggr));
8980
8981 -- Or else, generate component assignments to it
8982
8983 else
8984 Aggr_Code :=
8985 Build_Array_Aggr_Code
8986 (N => N,
8987 Ctype => Component_Type (Typ),
8988 Index => First_Index (Typ),
8989 Into => Target,
8990 Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
8991 Indexes => No_List);
8992 end if;
6031f544 8993
f3bf0d9a
HK
8994 -- Directly or indirectly (e.g. access protected procedure) a record
8995
8996 else
6031f544 8997 Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target);
70482933 8998 end if;
4ac2bbbd
AC
8999
9000 -- Save the last assignment statement associated with the aggregate
9001 -- when building a controlled object. This reference is utilized by
9002 -- the finalization machinery when marking an object as successfully
9003 -- initialized.
9004
9005 if Needs_Finalization (Typ)
9006 and then Is_Entity_Name (Target)
9007 and then Present (Entity (Target))
4a08c95c 9008 and then Ekind (Entity (Target)) in E_Constant | E_Variable
4ac2bbbd
AC
9009 then
9010 Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
9011 end if;
9012
9013 return Aggr_Code;
70482933
RK
9014 end Late_Expansion;
9015
9016 ----------------------------------
9017 -- Make_OK_Assignment_Statement --
9018 ----------------------------------
9019
9020 function Make_OK_Assignment_Statement
9021 (Sloc : Source_Ptr;
9022 Name : Node_Id;
0f95b178 9023 Expression : Node_Id) return Node_Id
70482933
RK
9024 is
9025 begin
9026 Set_Assignment_OK (Name);
9027 return Make_Assignment_Statement (Sloc, Name, Expression);
9028 end Make_OK_Assignment_Statement;
9029
c42006e9
AC
9030 ------------------------
9031 -- Max_Aggregate_Size --
9032 ------------------------
9033
9034 function Max_Aggregate_Size
eaf6e63a
BD
9035 (N : Node_Id;
9036 Default_Size : Nat := 5000) return Nat
9037 is
eaf6e63a
BD
9038 function Use_Small_Size (N : Node_Id) return Boolean;
9039 -- True if we should return a very small size, which means large
9040 -- aggregates will be implemented as a loop when possible (potentially
9041 -- transformed to memset calls).
9042
9043 function Aggr_Context (N : Node_Id) return Node_Id;
9044 -- Return the context in which the aggregate appears, not counting
9045 -- qualified expressions and similar.
9046
bcc15039
PT
9047 ------------------
9048 -- Aggr_Context --
9049 ------------------
9050
eaf6e63a
BD
9051 function Aggr_Context (N : Node_Id) return Node_Id is
9052 Result : Node_Id := Parent (N);
9053 begin
4a08c95c
AC
9054 if Nkind (Result) in N_Qualified_Expression
9055 | N_Type_Conversion
9056 | N_Unchecked_Type_Conversion
9057 | N_If_Expression
9058 | N_Case_Expression
9059 | N_Component_Association
9060 | N_Aggregate
eaf6e63a
BD
9061 then
9062 Result := Aggr_Context (Result);
9063 end if;
9064
9065 return Result;
9066 end Aggr_Context;
9067
bcc15039
PT
9068 --------------------
9069 -- Use_Small_Size --
9070 --------------------
9071
eaf6e63a
BD
9072 function Use_Small_Size (N : Node_Id) return Boolean is
9073 C : constant Node_Id := Aggr_Context (N);
9074 -- The decision depends on the context in which the aggregate occurs,
9075 -- and for variable declarations, whether we are nested inside a
9076 -- subprogram.
9077 begin
9078 case Nkind (C) is
9079 -- True for assignment statements and similar
9080
9081 when N_Assignment_Statement
9082 | N_Simple_Return_Statement
9083 | N_Allocator
9084 | N_Attribute_Reference
9085 =>
9086 return True;
9087
9088 -- True for nested variable declarations. False for library level
9089 -- variables, and for constants (whether or not nested).
9090
9091 when N_Object_Declaration =>
9092 return not Constant_Present (C)
0f3dfe41 9093 and then Is_Subprogram (Current_Scope);
eaf6e63a
BD
9094
9095 -- False for all other contexts
9096
9097 when others =>
9098 return False;
9099 end case;
9100 end Use_Small_Size;
9101
bcc15039
PT
9102 -- Local variables
9103
9104 Typ : constant Entity_Id := Etype (N);
9105
eaf6e63a
BD
9106 -- Start of processing for Max_Aggregate_Size
9107
c42006e9 9108 begin
bcc15039
PT
9109 -- We use a small limit in CodePeer mode where we favor loops instead of
9110 -- thousands of single assignments (from large aggregates).
c42006e9
AC
9111
9112 -- We also increase the limit to 2**24 (about 16 million) if
9113 -- Restrictions (No_Elaboration_Code) or Restrictions
9114 -- (No_Implicit_Loops) is specified, since in either case we are at risk
9115 -- of declaring the program illegal because of this limit. We also
9116 -- increase the limit when Static_Elaboration_Desired, given that this
9117 -- means that objects are intended to be placed in data memory.
9118
9119 -- Same if the aggregate is for a packed two-dimensional array, because
9120 -- if components are static it is much more efficient to construct a
9121 -- one-dimensional equivalent array with static components.
9122
9123 if CodePeer_Mode then
9124 return 100;
9125 elsif Restriction_Active (No_Elaboration_Code)
9126 or else Restriction_Active (No_Implicit_Loops)
9127 or else Is_Two_Dim_Packed_Array (Typ)
9128 or else (Ekind (Current_Scope) = E_Package
9129 and then Static_Elaboration_Desired (Current_Scope))
9130 then
9131 return 2 ** 24;
eaf6e63a 9132 elsif Use_Small_Size (N) then
152f64c2 9133 return 64;
c42006e9 9134 end if;
eaf6e63a
BD
9135
9136 return Default_Size;
c42006e9
AC
9137 end Max_Aggregate_Size;
9138
70482933
RK
9139 -----------------------
9140 -- Number_Of_Choices --
9141 -----------------------
9142
9143 function Number_Of_Choices (N : Node_Id) return Nat is
9144 Assoc : Node_Id;
9145 Choice : Node_Id;
9146
9147 Nb_Choices : Nat := 0;
9148
9149 begin
9150 if Present (Expressions (N)) then
9151 return 0;
9152 end if;
9153
9154 Assoc := First (Component_Associations (N));
9155 while Present (Assoc) loop
00f45f30 9156 Choice := First (Choice_List (Assoc));
70482933 9157 while Present (Choice) loop
70482933
RK
9158 if Nkind (Choice) /= N_Others_Choice then
9159 Nb_Choices := Nb_Choices + 1;
9160 end if;
9161
9162 Next (Choice);
9163 end loop;
9164
9165 Next (Assoc);
9166 end loop;
9167
9168 return Nb_Choices;
9169 end Number_Of_Choices;
9170
07fc65c4
GB
9171 ------------------------------------
9172 -- Packed_Array_Aggregate_Handled --
9173 ------------------------------------
9174
9175 -- The current version of this procedure will handle at compile time
9176 -- any array aggregate that meets these conditions:
9177
5eeeed5e 9178 -- One and two dimensional, bit packed
07fc65c4
GB
9179 -- Underlying packed type is modular type
9180 -- Bounds are within 32-bit Int range
9181 -- All bounds and values are static
9182
a39a553e
AC
9183 -- Note: for now, in the 2-D case, we only handle component sizes of
9184 -- 1, 2, 4 (cases where an integral number of elements occupies a byte).
9185
07fc65c4
GB
9186 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is
9187 Loc : constant Source_Ptr := Sloc (N);
9188 Typ : constant Entity_Id := Etype (N);
9189 Ctyp : constant Entity_Id := Component_Type (Typ);
9190
9191 Not_Handled : exception;
9192 -- Exception raised if this aggregate cannot be handled
9193
9194 begin
5eeeed5e 9195 -- Handle one- or two dimensional bit packed array
07fc65c4
GB
9196
9197 if not Is_Bit_Packed_Array (Typ)
5eeeed5e 9198 or else Number_Dimensions (Typ) > 2
07fc65c4
GB
9199 then
9200 return False;
9201 end if;
9202
5eeeed5e 9203 -- If two-dimensional, check whether it can be folded, and transformed
8ca597af
RD
9204 -- into a one-dimensional aggregate for the Packed_Array_Impl_Type of
9205 -- the original type.
5eeeed5e
AC
9206
9207 if Number_Dimensions (Typ) = 2 then
9208 return Two_Dim_Packed_Array_Handled (N);
9209 end if;
9210
8ca597af 9211 if not Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)) then
5eeeed5e
AC
9212 return False;
9213 end if;
9214
78326189 9215 if not Is_Scalar_Type (Ctyp) then
0f95b178
JM
9216 return False;
9217 end if;
9218
07fc65c4
GB
9219 declare
9220 Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
9221
07fc65c4 9222 function Get_Component_Val (N : Node_Id) return Uint;
3b9fa2df
ES
9223 -- Given a expression value N of the component type Ctyp, returns a
9224 -- value of Csiz (component size) bits representing this value. If
d940c627 9225 -- the value is nonstatic or any other reason exists why the value
3b9fa2df 9226 -- cannot be returned, then Not_Handled is raised.
07fc65c4
GB
9227
9228 -----------------------
9229 -- Get_Component_Val --
9230 -----------------------
9231
9232 function Get_Component_Val (N : Node_Id) return Uint is
fb8e3581 9233 Val : Uint;
07fc65c4
GB
9234
9235 begin
9236 -- We have to analyze the expression here before doing any further
9237 -- processing here. The analysis of such expressions is deferred
9238 -- till expansion to prevent some problems of premature analysis.
9239
9240 Analyze_And_Resolve (N, Ctyp);
9241
3b9fa2df
ES
9242 -- Must have a compile time value. String literals have to be
9243 -- converted into temporaries as well, because they cannot easily
9244 -- be converted into their bit representation.
07fc65c4 9245
6b6fcd3e
AC
9246 if not Compile_Time_Known_Value (N)
9247 or else Nkind (N) = N_String_Literal
9248 then
07fc65c4
GB
9249 raise Not_Handled;
9250 end if;
9251
9252 Val := Expr_Rep_Value (N);
9253
9254 -- Adjust for bias, and strip proper number of bits
9255
9256 if Has_Biased_Representation (Ctyp) then
9257 Val := Val - Expr_Value (Type_Low_Bound (Ctyp));
9258 end if;
9259
9260 return Val mod Uint_2 ** Csiz;
9261 end Get_Component_Val;
9262
7c4f3267
BD
9263 Bounds : constant Range_Nodes := Get_Index_Bounds (First_Index (Typ));
9264
07fc65c4
GB
9265 -- Here we know we have a one dimensional bit packed array
9266
9267 begin
07fc65c4
GB
9268 -- Cannot do anything if bounds are dynamic
9269
7c4f3267
BD
9270 if not (Compile_Time_Known_Value (Bounds.First)
9271 and then
9272 Compile_Time_Known_Value (Bounds.Last))
07fc65c4
GB
9273 then
9274 return False;
9275 end if;
9276
7c4f3267
BD
9277 declare
9278 Bounds_Vals : Range_Values;
9279 -- Compile-time known values of bounds
9280 begin
9281 -- Or are silly out of range of int bounds
07fc65c4 9282
7c4f3267
BD
9283 Bounds_Vals.First := Expr_Value (Bounds.First);
9284 Bounds_Vals.Last := Expr_Value (Bounds.Last);
07fc65c4 9285
7c4f3267
BD
9286 if not UI_Is_In_Int_Range (Bounds_Vals.First)
9287 or else
9288 not UI_Is_In_Int_Range (Bounds_Vals.Last)
9289 then
9290 return False;
9291 end if;
07fc65c4 9292
7c4f3267
BD
9293 -- At this stage we have a suitable aggregate for handling at
9294 -- compile time. The only remaining checks are that the values of
9295 -- expressions in the aggregate are compile-time known (checks are
9296 -- performed by Get_Component_Val), and that any subtypes or
9297 -- ranges are statically known.
07fc65c4 9298
7c4f3267
BD
9299 -- If the aggregate is not fully positional at this stage, then
9300 -- convert it to positional form. Either this will fail, in which
9301 -- case we can do nothing, or it will succeed, in which case we
9302 -- have succeeded in handling the aggregate and transforming it
9303 -- into a modular value, or it will stay an aggregate, in which
9304 -- case we have failed to create a packed value for it.
07fc65c4 9305
7c4f3267
BD
9306 if Present (Component_Associations (N)) then
9307 Convert_To_Positional (N, Handle_Bit_Packed => True);
9308 return Nkind (N) /= N_Aggregate;
9309 end if;
07fc65c4 9310
7c4f3267 9311 -- Otherwise we are all positional, so convert to proper value
07fc65c4 9312
7c4f3267
BD
9313 declare
9314 Len : constant Nat :=
9315 Int'Max (0, UI_To_Int (Bounds_Vals.Last) -
9316 UI_To_Int (Bounds_Vals.First) + 1);
9317 -- The length of the array (number of elements)
07fc65c4 9318
7c4f3267
BD
9319 Aggregate_Val : Uint;
9320 -- Value of aggregate. The value is set in the low order bits
9321 -- of this value. For the little-endian case, the values are
9322 -- stored from low-order to high-order and for the big-endian
9323 -- case the values are stored from high order to low order.
9324 -- Note that gigi will take care of the conversions to left
9325 -- justify the value in the big endian case (because of left
9326 -- justified modular type processing), so we do not have to
9327 -- worry about that here.
07fc65c4 9328
7c4f3267
BD
9329 Lit : Node_Id;
9330 -- Integer literal for resulting constructed value
07fc65c4 9331
7c4f3267
BD
9332 Shift : Nat;
9333 -- Shift count from low order for next value
07fc65c4 9334
7c4f3267
BD
9335 Incr : Int;
9336 -- Shift increment for loop
07fc65c4 9337
7c4f3267
BD
9338 Expr : Node_Id;
9339 -- Next expression from positional parameters of aggregate
c9a6b38f 9340
7c4f3267
BD
9341 Left_Justified : Boolean;
9342 -- Set True if we are filling the high order bits of the target
9343 -- value (i.e. the value is left justified).
07fc65c4 9344
7c4f3267
BD
9345 begin
9346 -- For little endian, we fill up the low order bits of the
9347 -- target value. For big endian we fill up the high order bits
9348 -- of the target value (which is a left justified modular
9349 -- value).
68f640f2 9350
7c4f3267 9351 Left_Justified := Bytes_Big_Endian;
c9a6b38f 9352
7c4f3267 9353 -- Switch justification if using -gnatd8
c9a6b38f 9354
7c4f3267
BD
9355 if Debug_Flag_8 then
9356 Left_Justified := not Left_Justified;
9357 end if;
c9a6b38f 9358
7c4f3267 9359 -- Switch justfification if reverse storage order
c9a6b38f 9360
7c4f3267
BD
9361 if Reverse_Storage_Order (Base_Type (Typ)) then
9362 Left_Justified := not Left_Justified;
9363 end if;
07fc65c4 9364
7c4f3267
BD
9365 if Left_Justified then
9366 Shift := Csiz * (Len - 1);
9367 Incr := -Csiz;
9368 else
9369 Shift := 0;
9370 Incr := +Csiz;
9371 end if;
07fc65c4 9372
7c4f3267 9373 -- Loop to set the values
fbf5a39b 9374
7c4f3267
BD
9375 if Len = 0 then
9376 Aggregate_Val := Uint_0;
9377 else
9378 Expr := First (Expressions (N));
9379 Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
9380
9381 for J in 2 .. Len loop
9382 Shift := Shift + Incr;
9383 Next (Expr);
9384 Aggregate_Val :=
9385 Aggregate_Val +
9386 Get_Component_Val (Expr) * Uint_2 ** Shift;
9387 end loop;
9388 end if;
07fc65c4 9389
7c4f3267 9390 -- Now we can rewrite with the proper value
07fc65c4 9391
7c4f3267
BD
9392 Lit := Make_Integer_Literal (Loc, Intval => Aggregate_Val);
9393 Set_Print_In_Hex (Lit);
07fc65c4 9394
7c4f3267
BD
9395 -- Construct the expression using this literal. Note that it
9396 -- is important to qualify the literal with its proper modular
9397 -- type since universal integer does not have the required
9398 -- range and also this is a left justified modular type,
9399 -- which is important in the big-endian case.
07fc65c4 9400
7c4f3267
BD
9401 Rewrite (N,
9402 Unchecked_Convert_To (Typ,
9403 Make_Qualified_Expression (Loc,
9404 Subtype_Mark =>
9405 New_Occurrence_Of (Packed_Array_Impl_Type (Typ), Loc),
9406 Expression => Lit)));
07fc65c4 9407
7c4f3267
BD
9408 Analyze_And_Resolve (N, Typ);
9409 return True;
9410 end;
07fc65c4
GB
9411 end;
9412 end;
9413
9414 exception
9415 when Not_Handled =>
9416 return False;
9417 end Packed_Array_Aggregate_Handled;
9418
fbf5a39b
AC
9419 ----------------------------
9420 -- Has_Mutable_Components --
9421 ----------------------------
9422
9423 function Has_Mutable_Components (Typ : Entity_Id) return Boolean is
9424 Comp : Entity_Id;
bee475e2 9425 Ctyp : Entity_Id;
fbf5a39b
AC
9426
9427 begin
9428 Comp := First_Component (Typ);
fbf5a39b 9429 while Present (Comp) loop
bee475e2
EB
9430 Ctyp := Underlying_Type (Etype (Comp));
9431 if Is_Record_Type (Ctyp)
9432 and then Has_Discriminants (Ctyp)
9433 and then not Is_Constrained (Ctyp)
fbf5a39b
AC
9434 then
9435 return True;
9436 end if;
9437
9438 Next_Component (Comp);
9439 end loop;
9440
9441 return False;
9442 end Has_Mutable_Components;
9443
07fc65c4
GB
9444 ------------------------------
9445 -- Initialize_Discriminants --
9446 ------------------------------
9447
9448 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is
9449 Loc : constant Source_Ptr := Sloc (N);
9450 Bas : constant Entity_Id := Base_Type (Typ);
9451 Par : constant Entity_Id := Etype (Bas);
9452 Decl : constant Node_Id := Parent (Par);
9453 Ref : Node_Id;
9454
9455 begin
9456 if Is_Tagged_Type (Bas)
9457 and then Is_Derived_Type (Bas)
9458 and then Has_Discriminants (Par)
9459 and then Has_Discriminants (Bas)
9460 and then Number_Discriminants (Bas) /= Number_Discriminants (Par)
9461 and then Nkind (Decl) = N_Full_Type_Declaration
9462 and then Nkind (Type_Definition (Decl)) = N_Record_Definition
36a66365
AC
9463 and then
9464 Present (Variant_Part (Component_List (Type_Definition (Decl))))
07fc65c4
GB
9465 and then Nkind (N) /= N_Extension_Aggregate
9466 then
9467
fbf5a39b 9468 -- Call init proc to set discriminants.
07fc65c4
GB
9469 -- There should eventually be a special procedure for this ???
9470
e4494292 9471 Ref := New_Occurrence_Of (Defining_Identifier (N), Loc);
07fc65c4
GB
9472 Insert_Actions_After (N,
9473 Build_Initialization_Call (Sloc (N), Ref, Typ));
9474 end if;
9475 end Initialize_Discriminants;
9476
3cf3e5c6
AC
9477 ----------------
9478 -- Must_Slide --
9479 ----------------
9480
9481 function Must_Slide
6732c403
ES
9482 (Aggr : Node_Id;
9483 Obj_Type : Entity_Id;
3cf3e5c6
AC
9484 Typ : Entity_Id) return Boolean
9485 is
3cf3e5c6 9486 begin
3b9fa2df
ES
9487 -- No sliding if the type of the object is not established yet, if it is
9488 -- an unconstrained type whose actual subtype comes from the aggregate,
6732c403
ES
9489 -- or if the two types are identical. If the aggregate contains only
9490 -- an Others_Clause it gets its type from the context and no sliding
9491 -- is involved either.
3cf3e5c6
AC
9492
9493 if not Is_Array_Type (Obj_Type) then
9494 return False;
9495
9496 elsif not Is_Constrained (Obj_Type) then
9497 return False;
9498
9499 elsif Typ = Obj_Type then
9500 return False;
9501
6732c403
ES
9502 elsif Is_Others_Aggregate (Aggr) then
9503 return False;
9504
3cf3e5c6
AC
9505 else
9506 -- Sliding can only occur along the first dimension
6732c403
ES
9507 -- If any the bounds of non-static sliding is required
9508 -- to force potential range checks.
3cf3e5c6 9509
7c4f3267
BD
9510 declare
9511 Bounds1 : constant Range_Nodes :=
9512 Get_Index_Bounds (First_Index (Typ));
9513 Bounds2 : constant Range_Nodes :=
9514 Get_Index_Bounds (First_Index (Obj_Type));
3cf3e5c6 9515
7c4f3267
BD
9516 begin
9517 if not Is_OK_Static_Expression (Bounds1.First) or else
9518 not Is_OK_Static_Expression (Bounds2.First) or else
9519 not Is_OK_Static_Expression (Bounds1.Last) or else
9520 not Is_OK_Static_Expression (Bounds2.Last)
9521 then
6732c403
ES
9522 return True;
9523
7c4f3267
BD
9524 else
9525 return Expr_Value (Bounds1.First) /= Expr_Value (Bounds2.First)
9526 or else
9527 Expr_Value (Bounds1.Last) /= Expr_Value (Bounds2.Last);
9528 end if;
9529 end;
3cf3e5c6
AC
9530 end if;
9531 end Must_Slide;
9532
937e9676
AC
9533 ---------------------------------
9534 -- Process_Transient_Component --
9535 ---------------------------------
5eeeed5e 9536
937e9676
AC
9537 procedure Process_Transient_Component
9538 (Loc : Source_Ptr;
9539 Comp_Typ : Entity_Id;
9540 Init_Expr : Node_Id;
9541 Fin_Call : out Node_Id;
9542 Hook_Clear : out Node_Id;
9543 Aggr : Node_Id := Empty;
9544 Stmts : List_Id := No_List)
9545 is
9546 procedure Add_Item (Item : Node_Id);
9547 -- Insert arbitrary node Item into the tree depending on the values of
9548 -- Aggr and Stmts.
5eeeed5e 9549
937e9676
AC
9550 --------------
9551 -- Add_Item --
9552 --------------
5eeeed5e 9553
937e9676
AC
9554 procedure Add_Item (Item : Node_Id) is
9555 begin
9556 if Present (Aggr) then
9557 Insert_Action (Aggr, Item);
9558 else
9559 pragma Assert (Present (Stmts));
9560 Append_To (Stmts, Item);
9561 end if;
9562 end Add_Item;
9563
9564 -- Local variables
9565
9566 Hook_Assign : Node_Id;
9567 Hook_Decl : Node_Id;
9568 Ptr_Decl : Node_Id;
9569 Res_Decl : Node_Id;
9570 Res_Id : Entity_Id;
9571 Res_Typ : Entity_Id;
eb16654e 9572 Copy_Init_Expr : constant Node_Id := New_Copy_Tree (Init_Expr);
937e9676
AC
9573
9574 -- Start of processing for Process_Transient_Component
5eeeed5e
AC
9575
9576 begin
937e9676
AC
9577 -- Add the access type, which provides a reference to the function
9578 -- result. Generate:
5eeeed5e 9579
937e9676 9580 -- type Res_Typ is access all Comp_Typ;
5eeeed5e 9581
937e9676 9582 Res_Typ := Make_Temporary (Loc, 'A');
2e02ab86 9583 Mutate_Ekind (Res_Typ, E_General_Access_Type);
937e9676 9584 Set_Directly_Designated_Type (Res_Typ, Comp_Typ);
5eeeed5e 9585
937e9676
AC
9586 Add_Item
9587 (Make_Full_Type_Declaration (Loc,
9588 Defining_Identifier => Res_Typ,
9589 Type_Definition =>
9590 Make_Access_To_Object_Definition (Loc,
9591 All_Present => True,
9592 Subtype_Indication => New_Occurrence_Of (Comp_Typ, Loc))));
5eeeed5e 9593
937e9676
AC
9594 -- Add the temporary which captures the result of the function call.
9595 -- Generate:
5eeeed5e 9596
937e9676 9597 -- Res : constant Res_Typ := Init_Expr'Reference;
5eeeed5e 9598
937e9676
AC
9599 -- Note that this temporary is effectively a transient object because
9600 -- its lifetime is bounded by the current array or record component.
5eeeed5e 9601
937e9676 9602 Res_Id := Make_Temporary (Loc, 'R');
2e02ab86 9603 Mutate_Ekind (Res_Id, E_Constant);
937e9676 9604 Set_Etype (Res_Id, Res_Typ);
5eeeed5e 9605
937e9676
AC
9606 -- Mark the transient object as successfully processed to avoid double
9607 -- finalization.
5eeeed5e 9608
937e9676 9609 Set_Is_Finalized_Transient (Res_Id);
5eeeed5e 9610
937e9676
AC
9611 -- Signal the general finalization machinery that this transient object
9612 -- should not be considered for finalization actions because its cleanup
9613 -- will be performed by Process_Transient_Component_Completion.
5eeeed5e 9614
937e9676 9615 Set_Is_Ignored_Transient (Res_Id);
5eeeed5e 9616
937e9676
AC
9617 Res_Decl :=
9618 Make_Object_Declaration (Loc,
9619 Defining_Identifier => Res_Id,
9620 Constant_Present => True,
9621 Object_Definition => New_Occurrence_Of (Res_Typ, Loc),
9622 Expression =>
eb16654e
MP
9623 Make_Reference (Loc, Copy_Init_Expr));
9624
9625 -- In some cases, like iterated component, the Init_Expr may have been
9626 -- analyzed in a context where all the Etype fields are not correct yet
9627 -- and a later call to Analyze is expected to set them.
9628 -- Resetting the Analyzed flag ensures this later call doesn't skip this
9629 -- node.
9630
9631 Reset_Analyzed_Flags (Copy_Init_Expr);
5eeeed5e 9632
937e9676 9633 Add_Item (Res_Decl);
5eeeed5e 9634
937e9676
AC
9635 -- Construct all pieces necessary to hook and finalize the transient
9636 -- result.
5eeeed5e 9637
937e9676
AC
9638 Build_Transient_Object_Statements
9639 (Obj_Decl => Res_Decl,
9640 Fin_Call => Fin_Call,
9641 Hook_Assign => Hook_Assign,
9642 Hook_Clear => Hook_Clear,
9643 Hook_Decl => Hook_Decl,
9644 Ptr_Decl => Ptr_Decl);
5eeeed5e 9645
937e9676
AC
9646 -- Add the access type which provides a reference to the transient
9647 -- result. Generate:
5eeeed5e 9648
937e9676 9649 -- type Ptr_Typ is access all Comp_Typ;
5eeeed5e 9650
937e9676 9651 Add_Item (Ptr_Decl);
5eeeed5e 9652
937e9676
AC
9653 -- Add the temporary which acts as a hook to the transient result.
9654 -- Generate:
5eeeed5e 9655
937e9676 9656 -- Hook : Ptr_Typ := null;
5eeeed5e 9657
937e9676 9658 Add_Item (Hook_Decl);
5eeeed5e 9659
937e9676 9660 -- Attach the transient result to the hook. Generate:
5eeeed5e 9661
937e9676 9662 -- Hook := Ptr_Typ (Res);
5eeeed5e 9663
937e9676 9664 Add_Item (Hook_Assign);
5eeeed5e 9665
937e9676
AC
9666 -- The original initialization expression now references the value of
9667 -- the temporary function result. Generate:
5eeeed5e 9668
937e9676 9669 -- Res.all
5eeeed5e 9670
937e9676
AC
9671 Rewrite (Init_Expr,
9672 Make_Explicit_Dereference (Loc,
9673 Prefix => New_Occurrence_Of (Res_Id, Loc)));
9674 end Process_Transient_Component;
5eeeed5e 9675
937e9676
AC
9676 --------------------------------------------
9677 -- Process_Transient_Component_Completion --
9678 --------------------------------------------
5eeeed5e 9679
937e9676
AC
9680 procedure Process_Transient_Component_Completion
9681 (Loc : Source_Ptr;
9682 Aggr : Node_Id;
9683 Fin_Call : Node_Id;
9684 Hook_Clear : Node_Id;
9685 Stmts : List_Id)
9686 is
9687 Exceptions_OK : constant Boolean :=
9688 not Restriction_Active (No_Exception_Propagation);
5eeeed5e 9689
937e9676 9690 begin
937e9676 9691 pragma Assert (Present (Hook_Clear));
5eeeed5e 9692
937e9676 9693 -- Generate the following code if exception propagation is allowed:
5eeeed5e 9694
937e9676
AC
9695 -- declare
9696 -- Abort : constant Boolean := Triggered_By_Abort;
9697 -- <or>
9698 -- Abort : constant Boolean := False; -- no abort
5eeeed5e 9699
937e9676
AC
9700 -- E : Exception_Occurrence;
9701 -- Raised : Boolean := False;
5eeeed5e 9702
937e9676
AC
9703 -- begin
9704 -- [Abort_Defer;]
5eeeed5e 9705
937e9676
AC
9706 -- begin
9707 -- Hook := null;
9708 -- [Deep_]Finalize (Res.all);
5eeeed5e 9709
937e9676
AC
9710 -- exception
9711 -- when others =>
9712 -- if not Raised then
9713 -- Raised := True;
9714 -- Save_Occurrence (E,
9715 -- Get_Curent_Excep.all.all);
9716 -- end if;
9717 -- end;
5eeeed5e 9718
937e9676 9719 -- [Abort_Undefer;]
5eeeed5e 9720
937e9676
AC
9721 -- if Raised and then not Abort then
9722 -- Raise_From_Controlled_Operation (E);
9723 -- end if;
9724 -- end;
9725
9726 if Exceptions_OK then
9727 Abort_And_Exception : declare
9728 Blk_Decls : constant List_Id := New_List;
9729 Blk_Stmts : constant List_Id := New_List;
2168d7cc 9730 Fin_Stmts : constant List_Id := New_List;
937e9676
AC
9731
9732 Fin_Data : Finalization_Exception_Data;
9733
9734 begin
9735 -- Create the declarations of the two flags and the exception
9736 -- occurrence.
9737
9738 Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
9739
9740 -- Generate:
9741 -- Abort_Defer;
9742
9743 if Abort_Allowed then
9744 Append_To (Blk_Stmts,
9745 Build_Runtime_Call (Loc, RE_Abort_Defer));
9746 end if;
9747
9748 -- Wrap the hook clear and the finalization call in order to trap
9749 -- a potential exception.
9750
2168d7cc
AC
9751 Append_To (Fin_Stmts, Hook_Clear);
9752
9753 if Present (Fin_Call) then
9754 Append_To (Fin_Stmts, Fin_Call);
9755 end if;
9756
937e9676
AC
9757 Append_To (Blk_Stmts,
9758 Make_Block_Statement (Loc,
9759 Handled_Statement_Sequence =>
9760 Make_Handled_Sequence_Of_Statements (Loc,
2168d7cc 9761 Statements => Fin_Stmts,
937e9676
AC
9762 Exception_Handlers => New_List (
9763 Build_Exception_Handler (Fin_Data)))));
9764
9765 -- Generate:
9766 -- Abort_Undefer;
9767
9768 if Abort_Allowed then
9769 Append_To (Blk_Stmts,
9770 Build_Runtime_Call (Loc, RE_Abort_Undefer));
9771 end if;
9772
9773 -- Reraise the potential exception with a proper "upgrade" to
9774 -- Program_Error if needed.
9775
9776 Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
9777
9778 -- Wrap everything in a block
9779
9780 Append_To (Stmts,
9781 Make_Block_Statement (Loc,
9782 Declarations => Blk_Decls,
9783 Handled_Statement_Sequence =>
9784 Make_Handled_Sequence_Of_Statements (Loc,
9785 Statements => Blk_Stmts)));
9786 end Abort_And_Exception;
9787
9788 -- Generate the following code if exception propagation is not allowed
9789 -- and aborts are allowed:
9790
9791 -- begin
9792 -- Abort_Defer;
9793 -- Hook := null;
9794 -- [Deep_]Finalize (Res.all);
9795 -- at end
bb072d1c 9796 -- Abort_Undefer_Direct;
937e9676
AC
9797 -- end;
9798
9799 elsif Abort_Allowed then
9800 Abort_Only : declare
9801 Blk_Stmts : constant List_Id := New_List;
9802
937e9676
AC
9803 begin
9804 Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
9805 Append_To (Blk_Stmts, Hook_Clear);
2168d7cc
AC
9806
9807 if Present (Fin_Call) then
9808 Append_To (Blk_Stmts, Fin_Call);
9809 end if;
937e9676 9810
bb072d1c
AC
9811 Append_To (Stmts,
9812 Build_Abort_Undefer_Block (Loc,
9813 Stmts => Blk_Stmts,
9814 Context => Aggr));
937e9676
AC
9815 end Abort_Only;
9816
9817 -- Otherwise generate:
9818
9819 -- Hook := null;
9820 -- [Deep_]Finalize (Res.all);
9821
9822 else
9823 Append_To (Stmts, Hook_Clear);
2168d7cc
AC
9824
9825 if Present (Fin_Call) then
9826 Append_To (Stmts, Fin_Call);
9827 end if;
937e9676
AC
9828 end if;
9829 end Process_Transient_Component_Completion;
5eeeed5e 9830
70482933
RK
9831 ---------------------
9832 -- Sort_Case_Table --
9833 ---------------------
9834
9835 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
fbf5a39b
AC
9836 L : constant Int := Case_Table'First;
9837 U : constant Int := Case_Table'Last;
70482933
RK
9838 K : Int;
9839 J : Int;
9840 T : Case_Bounds;
9841
9842 begin
9843 K := L;
70482933
RK
9844 while K /= U loop
9845 T := Case_Table (K + 1);
70482933 9846
5277cab6 9847 J := K + 1;
70482933
RK
9848 while J /= L
9849 and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
9850 Expr_Value (T.Choice_Lo)
9851 loop
9852 Case_Table (J) := Case_Table (J - 1);
9853 J := J - 1;
9854 end loop;
9855
9856 Case_Table (J) := T;
9857 K := K + 1;
9858 end loop;
9859 end Sort_Case_Table;
9860
0f95b178
JM
9861 ----------------------------
9862 -- Static_Array_Aggregate --
9863 ----------------------------
9864
9865 function Static_Array_Aggregate (N : Node_Id) return Boolean is
2401c98f
HK
9866 function Is_Static_Component (Nod : Node_Id) return Boolean;
9867 -- Return True if Nod has a compile-time known value and can be passed
9868 -- as is to the back-end without further expansion.
2a1838cd
EB
9869
9870 ---------------------------
9871 -- Is_Static_Component --
9872 ---------------------------
9873
2401c98f 9874 function Is_Static_Component (Nod : Node_Id) return Boolean is
2a1838cd 9875 begin
4a08c95c 9876 if Nkind (Nod) in N_Integer_Literal | N_Real_Literal then
2a1838cd
EB
9877 return True;
9878
2401c98f
HK
9879 elsif Is_Entity_Name (Nod)
9880 and then Present (Entity (Nod))
9881 and then Ekind (Entity (Nod)) = E_Enumeration_Literal
2a1838cd
EB
9882 then
9883 return True;
9884
2401c98f
HK
9885 elsif Nkind (Nod) = N_Aggregate
9886 and then Compile_Time_Known_Aggregate (Nod)
2a1838cd
EB
9887 then
9888 return True;
9889
9890 else
9891 return False;
9892 end if;
9893 end Is_Static_Component;
9894
2401c98f
HK
9895 -- Local variables
9896
9897 Bounds : constant Node_Id := Aggregate_Bounds (N);
9898 Typ : constant Entity_Id := Etype (N);
0f95b178 9899
2401c98f
HK
9900 Agg : Node_Id;
9901 Expr : Node_Id;
9902 Lo : Node_Id;
9903 Hi : Node_Id;
0f95b178 9904
2a1838cd
EB
9905 -- Start of processing for Static_Array_Aggregate
9906
0f95b178 9907 begin
2a1838cd 9908 if Is_Packed (Typ) or else Has_Discriminants (Component_Type (Typ)) then
0f95b178
JM
9909 return False;
9910 end if;
9911
9912 if Present (Bounds)
9913 and then Nkind (Bounds) = N_Range
9914 and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
9915 and then Nkind (High_Bound (Bounds)) = N_Integer_Literal
9916 then
9917 Lo := Low_Bound (Bounds);
9918 Hi := High_Bound (Bounds);
9919
9920 if No (Component_Associations (N)) then
9921
2a1838cd 9922 -- Verify that all components are static
0f95b178
JM
9923
9924 Expr := First (Expressions (N));
9925 while Present (Expr) loop
2a1838cd 9926 if not Is_Static_Component (Expr) then
0f95b178
JM
9927 return False;
9928 end if;
9929
9930 Next (Expr);
9931 end loop;
9932
9933 return True;
9934
9935 else
9936 -- We allow only a single named association, either a static
9937 -- range or an others_clause, with a static expression.
9938
9939 Expr := First (Component_Associations (N));
9940
9941 if Present (Expressions (N)) then
9942 return False;
9943
9944 elsif Present (Next (Expr)) then
9945 return False;
9946
00f45f30 9947 elsif Present (Next (First (Choice_List (Expr)))) then
0f95b178
JM
9948 return False;
9949
9950 else
d7f94401
AC
9951 -- The aggregate is static if all components are literals,
9952 -- or else all its components are static aggregates for the
fc534c1c
ES
9953 -- component type. We also limit the size of a static aggregate
9954 -- to prevent runaway static expressions.
0f95b178 9955
2a1838cd 9956 if not Is_Static_Component (Expression (Expr)) then
0f95b178 9957 return False;
6a2e4f0b 9958 end if;
fc534c1c 9959
eaf6e63a 9960 if not Aggr_Size_OK (N) then
fc534c1c 9961 return False;
0f95b178
JM
9962 end if;
9963
9964 -- Create a positional aggregate with the right number of
9965 -- copies of the expression.
9966
9967 Agg := Make_Aggregate (Sloc (N), New_List, No_List);
9968
9969 for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi))
9970 loop
37368818 9971 Append_To (Expressions (Agg), New_Copy (Expression (Expr)));
597d7158 9972
9b4b0a1a
GD
9973 -- The copied expression must be analyzed and resolved.
9974 -- Besides setting the type, this ensures that static
9975 -- expressions are appropriately marked as such.
597d7158 9976
9b4b0a1a
GD
9977 Analyze_And_Resolve
9978 (Last (Expressions (Agg)), Component_Type (Typ));
0f95b178
JM
9979 end loop;
9980
9981 Set_Aggregate_Bounds (Agg, Bounds);
9982 Set_Etype (Agg, Typ);
9983 Set_Analyzed (Agg);
9984 Rewrite (N, Agg);
9985 Set_Compile_Time_Known_Aggregate (N);
9986
9987 return True;
9988 end if;
9989 end if;
9990
9991 else
9992 return False;
9993 end if;
9994 end Static_Array_Aggregate;
9b4b0a1a 9995
937e9676
AC
9996 ----------------------------------
9997 -- Two_Dim_Packed_Array_Handled --
9998 ----------------------------------
9999
10000 function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is
10001 Loc : constant Source_Ptr := Sloc (N);
10002 Typ : constant Entity_Id := Etype (N);
10003 Ctyp : constant Entity_Id := Component_Type (Typ);
10004 Comp_Size : constant Int := UI_To_Int (Component_Size (Typ));
10005 Packed_Array : constant Entity_Id :=
10006 Packed_Array_Impl_Type (Base_Type (Typ));
10007
10008 One_Comp : Node_Id;
10009 -- Expression in original aggregate
10010
10011 One_Dim : Node_Id;
10012 -- One-dimensional subaggregate
10013
10014 begin
10015
10016 -- For now, only deal with cases where an integral number of elements
10017 -- fit in a single byte. This includes the most common boolean case.
10018
10019 if not (Comp_Size = 1 or else
10020 Comp_Size = 2 or else
10021 Comp_Size = 4)
10022 then
10023 return False;
10024 end if;
10025
c42006e9 10026 Convert_To_Positional (N, Handle_Bit_Packed => True);
937e9676
AC
10027
10028 -- Verify that all components are static
10029
10030 if Nkind (N) = N_Aggregate
10031 and then Compile_Time_Known_Aggregate (N)
10032 then
10033 null;
10034
10035 -- The aggregate may have been reanalyzed and converted already
10036
10037 elsif Nkind (N) /= N_Aggregate then
10038 return True;
10039
10040 -- If component associations remain, the aggregate is not static
10041
10042 elsif Present (Component_Associations (N)) then
10043 return False;
10044
10045 else
10046 One_Dim := First (Expressions (N));
10047 while Present (One_Dim) loop
10048 if Present (Component_Associations (One_Dim)) then
10049 return False;
10050 end if;
10051
10052 One_Comp := First (Expressions (One_Dim));
10053 while Present (One_Comp) loop
10054 if not Is_OK_Static_Expression (One_Comp) then
10055 return False;
10056 end if;
10057
10058 Next (One_Comp);
10059 end loop;
10060
10061 Next (One_Dim);
10062 end loop;
10063 end if;
10064
10065 -- Two-dimensional aggregate is now fully positional so pack one
10066 -- dimension to create a static one-dimensional array, and rewrite
10067 -- as an unchecked conversion to the original type.
10068
10069 declare
10070 Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array));
10071 -- The packed array type is a byte array
10072
10073 Packed_Num : Nat;
10074 -- Number of components accumulated in current byte
10075
10076 Comps : List_Id;
10077 -- Assembled list of packed values for equivalent aggregate
10078
10079 Comp_Val : Uint;
10080 -- Integer value of component
10081
10082 Incr : Int;
10083 -- Step size for packing
10084
10085 Init_Shift : Int;
10086 -- Endian-dependent start position for packing
10087
10088 Shift : Int;
10089 -- Current insertion position
10090
10091 Val : Int;
10092 -- Component of packed array being assembled
10093
10094 begin
10095 Comps := New_List;
10096 Val := 0;
10097 Packed_Num := 0;
10098
64ac53f4 10099 -- Account for endianness. See corresponding comment in
937e9676
AC
10100 -- Packed_Array_Aggregate_Handled concerning the following.
10101
10102 if Bytes_Big_Endian
10103 xor Debug_Flag_8
10104 xor Reverse_Storage_Order (Base_Type (Typ))
10105 then
10106 Init_Shift := Byte_Size - Comp_Size;
10107 Incr := -Comp_Size;
10108 else
10109 Init_Shift := 0;
10110 Incr := +Comp_Size;
10111 end if;
10112
10113 -- Iterate over each subaggregate
10114
10115 Shift := Init_Shift;
10116 One_Dim := First (Expressions (N));
10117 while Present (One_Dim) loop
10118 One_Comp := First (Expressions (One_Dim));
10119 while Present (One_Comp) loop
10120 if Packed_Num = Byte_Size / Comp_Size then
10121
10122 -- Byte is complete, add to list of expressions
10123
10124 Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
10125 Val := 0;
10126 Shift := Init_Shift;
10127 Packed_Num := 0;
10128
10129 else
10130 Comp_Val := Expr_Rep_Value (One_Comp);
10131
10132 -- Adjust for bias, and strip proper number of bits
10133
10134 if Has_Biased_Representation (Ctyp) then
10135 Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp));
10136 end if;
10137
10138 Comp_Val := Comp_Val mod Uint_2 ** Comp_Size;
10139 Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift);
10140 Shift := Shift + Incr;
99859ea7 10141 Next (One_Comp);
937e9676
AC
10142 Packed_Num := Packed_Num + 1;
10143 end if;
10144 end loop;
10145
99859ea7 10146 Next (One_Dim);
937e9676
AC
10147 end loop;
10148
10149 if Packed_Num > 0 then
10150
10151 -- Add final incomplete byte if present
10152
10153 Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
10154 end if;
10155
10156 Rewrite (N,
10157 Unchecked_Convert_To (Typ,
10158 Make_Qualified_Expression (Loc,
10159 Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc),
10160 Expression => Make_Aggregate (Loc, Expressions => Comps))));
10161 Analyze_And_Resolve (N);
10162 return True;
10163 end;
10164 end Two_Dim_Packed_Array_Handled;
10165
70482933 10166end Exp_Aggr;