1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Expander; use Expander;
34 with Exp_Util; use Exp_Util;
35 with Exp_Ch3; use Exp_Ch3;
36 with Exp_Ch6; use Exp_Ch6;
37 with Exp_Ch7; use Exp_Ch7;
38 with Exp_Ch9; use Exp_Ch9;
39 with Exp_Disp; use Exp_Disp;
40 with Exp_Tss; use Exp_Tss;
41 with Freeze; use Freeze;
42 with Itypes; use Itypes;
44 with Namet; use Namet;
45 with Nmake; use Nmake;
46 with Nlists; use Nlists;
48 with Restrict; use Restrict;
49 with Rident; use Rident;
50 with Rtsfind; use Rtsfind;
51 with Ttypes; use Ttypes;
53 with Sem_Aggr; use Sem_Aggr;
54 with Sem_Aux; use Sem_Aux;
55 with Sem_Ch3; use Sem_Ch3;
56 with Sem_Ch8; use Sem_Ch8;
57 with Sem_Ch13; use Sem_Ch13;
58 with Sem_Eval; use Sem_Eval;
59 with Sem_Mech; use Sem_Mech;
60 with Sem_Res; use Sem_Res;
61 with Sem_Util; use Sem_Util;
62 with Sinfo; use Sinfo;
63 with Snames; use Snames;
64 with Stand; use Stand;
65 with Stringt; use Stringt;
66 with Tbuild; use Tbuild;
67 with Uintp; use Uintp;
68 with Urealp; use Urealp;
70 package body Exp_Aggr is
72 type Case_Bounds is record
75 Choice_Node : Node_Id;
78 type Case_Table_Type is array (Nat range <>) of Case_Bounds;
79 -- Table type used by Check_Case_Choices procedure
81 procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id);
82 procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
83 procedure Expand_Container_Aggregate (N : Node_Id);
85 function Get_Base_Object (N : Node_Id) return Entity_Id;
86 -- Return the base object, i.e. the outermost prefix object, that N refers
87 -- to statically, or Empty if it cannot be determined. The assumption is
88 -- that all dereferences are explicit in the tree rooted at N.
90 function Has_Default_Init_Comps (N : Node_Id) return Boolean;
91 -- N is an aggregate (record or array). Checks the presence of default
92 -- initialization (<>) in any component (Ada 2005: AI-287).
94 function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean;
95 -- Return True if aggregate N is located in a context supported by the
96 -- CCG backend; False otherwise.
98 function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean;
99 -- Returns true if N is an aggregate used to initialize the components
100 -- of a statically allocated dispatch table.
102 function Late_Expansion
105 Target : Node_Id) return List_Id;
106 -- This routine implements top-down expansion of nested aggregates. In
107 -- doing so, it avoids the generation of temporaries at each level. N is
108 -- a nested record or array aggregate with the Expansion_Delayed flag.
109 -- Typ is the expected type of the aggregate. Target is a (duplicatable)
110 -- expression that will hold the result of the aggregate expansion.
112 function Make_OK_Assignment_Statement
115 Expression : Node_Id) return Node_Id;
116 -- This is like Make_Assignment_Statement, except that Assignment_OK
117 -- is set in the left operand. All assignments built by this unit use
118 -- this routine. This is needed to deal with assignments to initialized
119 -- constants that are done in place.
122 (Obj_Type : Entity_Id;
123 Typ : Entity_Id) return Boolean;
124 -- A static array aggregate in an object declaration can in most cases be
125 -- expanded in place. The one exception is when the aggregate is given
126 -- with component associations that specify different bounds from those of
127 -- the type definition in the object declaration. In this pathological
128 -- case the aggregate must slide, and we must introduce an intermediate
129 -- temporary to hold it.
131 -- The same holds in an assignment to one-dimensional array of arrays,
132 -- when a component may be given with bounds that differ from those of the
135 function Number_Of_Choices (N : Node_Id) return Nat;
136 -- Returns the number of discrete choices (not including the others choice
137 -- if present) contained in (sub-)aggregate N.
139 procedure Process_Transient_Component
141 Comp_Typ : Entity_Id;
143 Fin_Call : out Node_Id;
144 Hook_Clear : out Node_Id;
145 Aggr : Node_Id := Empty;
146 Stmts : List_Id := No_List);
147 -- Subsidiary to the expansion of array and record aggregates. Generate
148 -- part of the necessary code to finalize a transient component. Comp_Typ
149 -- is the component type. Init_Expr is the initialization expression of the
150 -- component which is always a function call. Fin_Call is the finalization
151 -- call used to clean up the transient function result. Hook_Clear is the
152 -- hook reset statement. Aggr and Stmts both control the placement of the
153 -- generated code. Aggr is the related aggregate. If present, all code is
154 -- inserted prior to Aggr using Insert_Action. Stmts is the initialization
155 -- statements of the component. If present, all code is added to Stmts.
157 procedure Process_Transient_Component_Completion
161 Hook_Clear : Node_Id;
163 -- Subsidiary to the expansion of array and record aggregates. Generate
164 -- part of the necessary code to finalize a transient component. Aggr is
165 -- the related aggregate. Fin_Clear is the finalization call used to clean
166 -- up the transient component. Hook_Clear is the hook reset statment. Stmts
167 -- is the initialization statement list for the component. All generated
168 -- code is added to Stmts.
170 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
171 -- Sort the Case Table using the Lower Bound of each Choice as the key.
172 -- A simple insertion sort is used since the number of choices in a case
173 -- statement of variant part will usually be small and probably in near
176 ------------------------------------------------------
177 -- Local subprograms for Record Aggregate Expansion --
178 ------------------------------------------------------
180 function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean;
181 -- True if N is an aggregate (possibly qualified or converted) that is
182 -- being returned from a build-in-place function.
184 function Build_Record_Aggr_Code
187 Lhs : Node_Id) return List_Id;
188 -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
189 -- aggregate. Target is an expression containing the location on which the
190 -- component by component assignments will take place. Returns the list of
191 -- assignments plus all other adjustments needed for tagged and controlled
194 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
195 -- Transform a record aggregate into a sequence of assignments performed
196 -- component by component. N is an N_Aggregate or N_Extension_Aggregate.
197 -- Typ is the type of the record aggregate.
199 procedure Expand_Record_Aggregate
201 Orig_Tag : Node_Id := Empty;
202 Parent_Expr : Node_Id := Empty);
203 -- This is the top level procedure for record aggregate expansion.
204 -- Expansion for record aggregates needs expand aggregates for tagged
205 -- record types. Specifically Expand_Record_Aggregate adds the Tag
206 -- field in front of the Component_Association list that was created
207 -- during resolution by Resolve_Record_Aggregate.
209 -- N is the record aggregate node.
210 -- Orig_Tag is the value of the Tag that has to be provided for this
211 -- specific aggregate. It carries the tag corresponding to the type
212 -- of the outermost aggregate during the recursive expansion
213 -- Parent_Expr is the ancestor part of the original extension
216 function Has_Mutable_Components (Typ : Entity_Id) return Boolean;
217 -- Return true if one of the components is of a discriminated type with
218 -- defaults. An aggregate for a type with mutable components must be
219 -- expanded into individual assignments.
221 function In_Place_Assign_OK
223 Target_Object : Entity_Id := Empty) return Boolean;
224 -- Predicate to determine whether an aggregate assignment can be done in
225 -- place, because none of the new values can depend on the components of
226 -- the target of the assignment.
228 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);
229 -- If the type of the aggregate is a type extension with renamed discrimi-
230 -- nants, we must initialize the hidden discriminants of the parent.
231 -- Otherwise, the target object must not be initialized. The discriminants
232 -- are initialized by calling the initialization procedure for the type.
233 -- This is incorrect if the initialization of other components has any
234 -- side effects. We restrict this call to the case where the parent type
235 -- has a variant part, because this is the only case where the hidden
236 -- discriminants are accessed, namely when calling discriminant checking
237 -- functions of the parent type, and when applying a stream attribute to
238 -- an object of the derived type.
240 -----------------------------------------------------
241 -- Local Subprograms for Array Aggregate Expansion --
242 -----------------------------------------------------
244 function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean;
245 -- Returns true if an aggregate assignment can be done by the back end
247 function Aggr_Size_OK (N : Node_Id) return Boolean;
248 -- Very large static aggregates present problems to the back-end, and are
249 -- transformed into assignments and loops. This function verifies that the
250 -- total number of components of an aggregate is acceptable for rewriting
251 -- into a purely positional static form. Aggr_Size_OK must be called before
254 -- This function also detects and warns about one-component aggregates that
255 -- appear in a nonstatic context. Even if the component value is static,
256 -- such an aggregate must be expanded into an assignment.
258 function Backend_Processing_Possible (N : Node_Id) return Boolean;
259 -- This function checks if array aggregate N can be processed directly
260 -- by the backend. If this is the case, True is returned.
262 function Build_Array_Aggr_Code
267 Scalar_Comp : Boolean;
268 Indexes : List_Id := No_List) return List_Id;
269 -- This recursive routine returns a list of statements containing the
270 -- loops and assignments that are needed for the expansion of the array
273 -- N is the (sub-)aggregate node to be expanded into code. This node has
274 -- been fully analyzed, and its Etype is properly set.
276 -- Index is the index node corresponding to the array subaggregate N
278 -- Into is the target expression into which we are copying the aggregate.
279 -- Note that this node may not have been analyzed yet, and so the Etype
280 -- field may not be set.
282 -- Scalar_Comp is True if the component type of the aggregate is scalar
284 -- Indexes is the current list of expressions used to index the object we
287 procedure Convert_Array_Aggr_In_Allocator
291 -- If the aggregate appears within an allocator and can be expanded in
292 -- place, this routine generates the individual assignments to components
293 -- of the designated object. This is an optimization over the general
294 -- case, where a temporary is first created on the stack and then used to
295 -- construct the allocated object on the heap.
297 procedure Convert_To_Positional
299 Handle_Bit_Packed : Boolean := False);
300 -- If possible, convert named notation to positional notation. This
301 -- conversion is possible only in some static cases. If the conversion is
302 -- possible, then N is rewritten with the analyzed converted aggregate.
303 -- The parameter Handle_Bit_Packed is usually set False (since we do
304 -- not expect the back end to handle bit packed arrays, so the normal case
305 -- of conversion is pointless), but in the special case of a call from
306 -- Packed_Array_Aggregate_Handled, we set this parameter to True, since
307 -- these are cases we handle in there.
309 procedure Expand_Array_Aggregate (N : Node_Id);
310 -- This is the top-level routine to perform array aggregate expansion.
311 -- N is the N_Aggregate node to be expanded.
313 function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean;
314 -- For two-dimensional packed aggregates with constant bounds and constant
315 -- components, it is preferable to pack the inner aggregates because the
316 -- whole matrix can then be presented to the back-end as a one-dimensional
317 -- list of literals. This is much more efficient than expanding into single
318 -- component assignments. This function determines if the type Typ is for
319 -- an array that is suitable for this optimization: it returns True if Typ
320 -- is a two dimensional bit packed array with component size 1, 2, or 4.
322 function Max_Aggregate_Size
324 Default_Size : Nat := 5000) return Nat;
325 -- Return the max size for a static aggregate N. Return Default_Size if no
326 -- other special criteria trigger.
328 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
329 -- Given an array aggregate, this function handles the case of a packed
330 -- array aggregate with all constant values, where the aggregate can be
331 -- evaluated at compile time. If this is possible, then N is rewritten
332 -- to be its proper compile time value with all the components properly
333 -- assembled. The expression is analyzed and resolved and True is returned.
334 -- If this transformation is not possible, N is unchanged and False is
337 function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean;
338 -- If the type of the aggregate is a two-dimensional bit_packed array
339 -- it may be transformed into an array of bytes with constant values,
340 -- and presented to the back-end as a static value. The function returns
341 -- false if this transformation cannot be performed. THis is similar to,
342 -- and reuses part of the machinery in Packed_Array_Aggregate_Handled.
344 ------------------------------------
345 -- Aggr_Assignment_OK_For_Backend --
346 ------------------------------------
348 -- Back-end processing by Gigi/gcc is possible only if all the following
349 -- conditions are met:
351 -- 1. N consists of a single OTHERS choice, possibly recursively, or
352 -- of a single choice, possibly recursively, if it is surrounded by
353 -- a qualified expression whose subtype mark is unconstrained.
355 -- 2. The array type has no null ranges (the purpose of this is to
356 -- avoid a bogus warning for an out-of-range value).
358 -- 3. The array type has no atomic components
360 -- 4. The component type is elementary
362 -- 5. The component size is a multiple of Storage_Unit
364 -- 6. The component size is Storage_Unit or the value is of the form
365 -- M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit)
366 -- and M in 0 .. A-1. This can also be viewed as K occurrences of
367 -- the Storage_Unit value M, concatenated together.
369 -- The ultimate goal is to generate a call to a fast memset routine
370 -- specifically optimized for the target.
372 function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is
373 Csiz : Uint := No_Uint;
383 function Is_OK_Aggregate (Aggr : Node_Id) return Boolean;
384 -- Return true if Aggr is suitable for back-end assignment
386 ---------------------
387 -- Is_OK_Aggregate --
388 ---------------------
390 function Is_OK_Aggregate (Aggr : Node_Id) return Boolean is
391 Assoc : constant List_Id := Component_Associations (Aggr);
394 -- An "others" aggregate is most likely OK, but see below
396 if Is_Others_Aggregate (Aggr) then
399 -- An aggregate with a single choice requires a qualified expression
400 -- whose subtype mark is an unconstrained type because we need it to
401 -- have the semantics of an "others" aggregate.
403 elsif Nkind (Parent (N)) = N_Qualified_Expression
404 and then not Is_Constrained (Entity (Subtype_Mark (Parent (N))))
405 and then Is_Single_Aggregate (Aggr)
409 -- The other cases are not OK
415 -- In any case we do not support an iterated association
417 return Nkind (First (Assoc)) /= N_Iterated_Component_Association;
420 -- Start of processing for Aggr_Assignment_OK_For_Backend
423 -- Back end doesn't know about <>
425 if Has_Default_Init_Comps (N) then
429 -- Recurse as far as possible to find the innermost component type
433 while Is_Array_Type (Ctyp) loop
434 if Nkind (Expr) /= N_Aggregate
435 or else not Is_OK_Aggregate (Expr)
440 Index := First_Index (Ctyp);
441 while Present (Index) loop
442 Get_Index_Bounds (Index, Low, High);
444 if Is_Null_Range (Low, High) then
451 Expr := Expression (First (Component_Associations (Expr)));
453 for J in 1 .. Number_Dimensions (Ctyp) - 1 loop
454 if Nkind (Expr) /= N_Aggregate
455 or else not Is_OK_Aggregate (Expr)
460 Expr := Expression (First (Component_Associations (Expr)));
463 if Has_Atomic_Components (Ctyp) then
467 Csiz := Component_Size (Ctyp);
468 Ctyp := Component_Type (Ctyp);
470 if Is_Full_Access (Ctyp) then
475 -- Access types need to be dealt with specially
477 if Is_Access_Type (Ctyp) then
479 -- Component_Size is not set by Layout_Type if the component
480 -- type is an access type ???
482 Csiz := Esize (Ctyp);
484 -- Fat pointers are rejected as they are not really elementary
487 if Csiz /= System_Address_Size then
491 -- The supported expressions are NULL and constants, others are
492 -- rejected upfront to avoid being analyzed below, which can be
493 -- problematic for some of them, for example allocators.
495 if Nkind (Expr) /= N_Null and then not Is_Entity_Name (Expr) then
499 -- Scalar types are OK if their size is a multiple of Storage_Unit
501 elsif Is_Scalar_Type (Ctyp) then
502 pragma Assert (Csiz /= No_Uint);
504 if Csiz mod System_Storage_Unit /= 0 then
508 -- Composite types are rejected
514 -- If the expression has side effects (e.g. contains calls with
515 -- potential side effects) reject as well. We only preanalyze the
516 -- expression to prevent the removal of intended side effects.
518 Preanalyze_And_Resolve (Expr, Ctyp);
520 if not Side_Effect_Free (Expr) then
524 -- The expression needs to be analyzed if True is returned
526 Analyze_And_Resolve (Expr, Ctyp);
528 -- Strip away any conversions from the expression as they simply
529 -- qualify the real expression.
531 while Nkind (Expr) in N_Unchecked_Type_Conversion | N_Type_Conversion
533 Expr := Expression (Expr);
536 Nunits := UI_To_Int (Csiz) / System_Storage_Unit;
542 if not Compile_Time_Known_Value (Expr) then
546 -- The only supported value for floating point is 0.0
548 if Is_Floating_Point_Type (Ctyp) then
549 return Expr_Value_R (Expr) = Ureal_0;
552 -- For other types, we can look into the value as an integer, which
553 -- means the representation value for enumeration literals.
555 Value := Expr_Rep_Value (Expr);
557 if Has_Biased_Representation (Ctyp) then
558 Value := Value - Expr_Value (Type_Low_Bound (Ctyp));
561 -- Values 0 and -1 immediately satisfy the last check
563 if Value = Uint_0 or else Value = Uint_Minus_1 then
567 -- We need to work with an unsigned value
570 Value := Value + 2**(System_Storage_Unit * Nunits);
573 Remainder := Value rem 2**System_Storage_Unit;
575 for J in 1 .. Nunits - 1 loop
576 Value := Value / 2**System_Storage_Unit;
578 if Value rem 2**System_Storage_Unit /= Remainder then
584 end Aggr_Assignment_OK_For_Backend;
590 function Aggr_Size_OK (N : Node_Id) return Boolean is
591 Typ : constant Entity_Id := Etype (N);
600 -- Determines the maximum size of an array aggregate produced by
601 -- converting named to positional notation (e.g. from others clauses).
602 -- This avoids running away with attempts to convert huge aggregates,
603 -- which hit memory limits in the backend.
605 function Component_Count (T : Entity_Id) return Nat;
606 -- The limit is applied to the total number of subcomponents that the
607 -- aggregate will have, which is the number of static expressions
608 -- that will appear in the flattened array. This requires a recursive
609 -- computation of the number of scalar components of the structure.
611 ---------------------
612 -- Component_Count --
613 ---------------------
615 function Component_Count (T : Entity_Id) return Nat is
620 if Is_Scalar_Type (T) then
623 elsif Is_Record_Type (T) then
624 Comp := First_Component (T);
625 while Present (Comp) loop
626 Res := Res + Component_Count (Etype (Comp));
627 Next_Component (Comp);
632 elsif Is_Array_Type (T) then
634 Lo : constant Node_Id :=
635 Type_Low_Bound (Etype (First_Index (T)));
636 Hi : constant Node_Id :=
637 Type_High_Bound (Etype (First_Index (T)));
639 Siz : constant Nat := Component_Count (Component_Type (T));
642 -- Check for superflat arrays, i.e. arrays with such bounds
643 -- as 4 .. 2, to insure that this function never returns a
644 -- meaningless negative value.
646 if not Compile_Time_Known_Value (Lo)
647 or else not Compile_Time_Known_Value (Hi)
648 or else Expr_Value (Hi) < Expr_Value (Lo)
653 -- If the number of components is greater than Int'Last,
654 -- then return Int'Last, so caller will return False (Aggr
655 -- size is not OK). Otherwise, UI_To_Int will crash.
658 UI : constant Uint :=
659 Expr_Value (Hi) - Expr_Value (Lo) + 1;
661 if UI_Is_In_Int_Range (UI) then
662 return Siz * UI_To_Int (UI);
671 -- Can only be a null for an access type
677 -- Start of processing for Aggr_Size_OK
680 -- We bump the maximum size unless the aggregate has a single component
681 -- association, which will be more efficient if implemented with a loop.
683 if No (Expressions (N))
684 and then No (Next (First (Component_Associations (N))))
686 Max_Aggr_Size := Max_Aggregate_Size (N);
688 Max_Aggr_Size := Max_Aggregate_Size (N, 500_000);
691 Size := UI_From_Int (Component_Count (Component_Type (Typ)));
693 Indx := First_Index (Typ);
694 while Present (Indx) loop
695 Lo := Type_Low_Bound (Etype (Indx));
696 Hi := Type_High_Bound (Etype (Indx));
698 -- Bounds need to be known at compile time
700 if not Compile_Time_Known_Value (Lo)
701 or else not Compile_Time_Known_Value (Hi)
706 Lov := Expr_Value (Lo);
707 Hiv := Expr_Value (Hi);
709 -- A flat array is always safe
715 -- One-component aggregates are suspicious, and if the context type
716 -- is an object declaration with nonstatic bounds it will trip gcc;
717 -- such an aggregate must be expanded into a single assignment.
719 if Hiv = Lov and then Nkind (Parent (N)) = N_Object_Declaration then
721 Index_Type : constant Entity_Id :=
723 (First_Index (Etype (Defining_Identifier (Parent (N)))));
727 if not Compile_Time_Known_Value (Type_Low_Bound (Index_Type))
728 or else not Compile_Time_Known_Value
729 (Type_High_Bound (Index_Type))
731 if Present (Component_Associations (N)) then
734 (Choice_List (First (Component_Associations (N))));
736 if Is_Entity_Name (Indx)
737 and then not Is_Type (Entity (Indx))
740 ("single component aggregate in "
741 & "non-static context??", Indx);
742 Error_Msg_N ("\maybe subtype name was meant??", Indx);
752 Rng : constant Uint := Hiv - Lov + 1;
755 -- Check if size is too large
757 if not UI_Is_In_Int_Range (Rng) then
761 -- Compute the size using universal arithmetic to avoid the
762 -- possibility of overflow on very large aggregates.
767 or else Size > Max_Aggr_Size
773 -- Bounds must be in integer range, for later array construction
775 if not UI_Is_In_Int_Range (Lov)
777 not UI_Is_In_Int_Range (Hiv)
788 ---------------------------------
789 -- Backend_Processing_Possible --
790 ---------------------------------
792 -- Backend processing by Gigi/gcc is possible only if all the following
793 -- conditions are met:
795 -- 1. N is fully positional
797 -- 2. N is not a bit-packed array aggregate;
799 -- 3. The size of N's array type must be known at compile time. Note
800 -- that this implies that the component size is also known
802 -- 4. The array type of N does not follow the Fortran layout convention
803 -- or if it does it must be 1 dimensional.
805 -- 5. The array component type may not be tagged (which could necessitate
806 -- reassignment of proper tags).
808 -- 6. The array component type must not have unaligned bit components
810 -- 7. None of the components of the aggregate may be bit unaligned
813 -- 8. There cannot be delayed components, since we do not know enough
814 -- at this stage to know if back end processing is possible.
816 -- 9. There cannot be any discriminated record components, since the
817 -- back end cannot handle this complex case.
819 -- 10. No controlled actions need to be generated for components
821 -- 11. When generating C code, N must be part of a N_Object_Declaration
823 -- 12. When generating C code, N must not include function calls
825 function Backend_Processing_Possible (N : Node_Id) return Boolean is
826 Typ : constant Entity_Id := Etype (N);
827 -- Typ is the correct constrained array subtype of the aggregate
829 function Component_Check (N : Node_Id; Index : Node_Id) return Boolean;
830 -- This routine checks components of aggregate N, enforcing checks
831 -- 1, 7, 8, 9, 11, and 12. In the multidimensional case, these checks
832 -- are performed on subaggregates. The Index value is the current index
833 -- being checked in the multidimensional case.
835 ---------------------
836 -- Component_Check --
837 ---------------------
839 function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is
840 function Ultimate_Original_Expression (N : Node_Id) return Node_Id;
841 -- Given a type conversion or an unchecked type conversion N, return
842 -- its innermost original expression.
844 ----------------------------------
845 -- Ultimate_Original_Expression --
846 ----------------------------------
848 function Ultimate_Original_Expression (N : Node_Id) return Node_Id is
849 Expr : Node_Id := Original_Node (N);
852 while Nkind (Expr) in
853 N_Type_Conversion | N_Unchecked_Type_Conversion
855 Expr := Original_Node (Expression (Expr));
859 end Ultimate_Original_Expression;
865 -- Start of processing for Component_Check
868 -- Checks 1: (no component associations)
870 if Present (Component_Associations (N)) then
874 -- Checks 11: The C code generator cannot handle aggregates that are
875 -- not part of an object declaration.
877 if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
881 -- Checks on components
883 -- Recurse to check subaggregates, which may appear in qualified
884 -- expressions. If delayed, the front-end will have to expand.
885 -- If the component is a discriminated record, treat as nonstatic,
886 -- as the back-end cannot handle this properly.
888 Expr := First (Expressions (N));
889 while Present (Expr) loop
891 -- Checks 8: (no delayed components)
893 if Is_Delayed_Aggregate (Expr) then
897 -- Checks 9: (no discriminated records)
899 if Present (Etype (Expr))
900 and then Is_Record_Type (Etype (Expr))
901 and then Has_Discriminants (Etype (Expr))
906 -- Checks 7. Component must not be bit aligned component
908 if Possible_Bit_Aligned_Component (Expr) then
912 -- Checks 12: (no function call)
916 Nkind (Ultimate_Original_Expression (Expr)) = N_Function_Call
921 -- Recursion to following indexes for multiple dimension case
923 if Present (Next_Index (Index))
924 and then not Component_Check (Expr, Next_Index (Index))
929 -- All checks for that component finished, on to next
937 -- Start of processing for Backend_Processing_Possible
940 -- Checks 2 (array not bit packed) and 10 (no controlled actions)
942 if Is_Bit_Packed_Array (Typ) or else Needs_Finalization (Typ) then
946 -- If component is limited, aggregate must be expanded because each
947 -- component assignment must be built in place.
949 if Is_Limited_View (Component_Type (Typ)) then
953 -- Checks 4 (array must not be multidimensional Fortran case)
955 if Convention (Typ) = Convention_Fortran
956 and then Number_Dimensions (Typ) > 1
961 -- Checks 3 (size of array must be known at compile time)
963 if not Size_Known_At_Compile_Time (Typ) then
967 -- Checks on components
969 if not Component_Check (N, First_Index (Typ)) then
973 -- Checks 5 (if the component type is tagged, then we may need to do
974 -- tag adjustments. Perhaps this should be refined to check for any
975 -- component associations that actually need tag adjustment, similar
976 -- to the test in Component_OK_For_Backend for record aggregates with
977 -- tagged components, but not clear whether it's worthwhile ???; in the
978 -- case of virtual machines (no Tagged_Type_Expansion), object tags are
979 -- handled implicitly).
981 if Is_Tagged_Type (Component_Type (Typ))
982 and then Tagged_Type_Expansion
987 -- Checks 6 (component type must not have bit aligned components)
989 if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then
993 -- Backend processing is possible
996 end Backend_Processing_Possible;
998 ---------------------------
999 -- Build_Array_Aggr_Code --
1000 ---------------------------
1002 -- The code that we generate from a one dimensional aggregate is
1004 -- 1. If the subaggregate contains discrete choices we
1006 -- (a) Sort the discrete choices
1008 -- (b) Otherwise for each discrete choice that specifies a range we
1009 -- emit a loop. If a range specifies a maximum of three values, or
1010 -- we are dealing with an expression we emit a sequence of
1011 -- assignments instead of a loop.
1013 -- (c) Generate the remaining loops to cover the others choice if any
1015 -- 2. If the aggregate contains positional elements we
1017 -- (a) translate the positional elements in a series of assignments
1019 -- (b) Generate a final loop to cover the others choice if any.
1020 -- Note that this final loop has to be a while loop since the case
1022 -- L : Integer := Integer'Last;
1023 -- H : Integer := Integer'Last;
1024 -- A : array (L .. H) := (1, others =>0);
1026 -- cannot be handled by a for loop. Thus for the following
1028 -- array (L .. H) := (.. positional elements.., others =>E);
1030 -- we always generate something like:
1032 -- J : Index_Type := Index_Of_Last_Positional_Element;
1034 -- J := Index_Base'Succ (J)
1038 function Build_Array_Aggr_Code
1043 Scalar_Comp : Boolean;
1044 Indexes : List_Id := No_List) return List_Id
1046 Loc : constant Source_Ptr := Sloc (N);
1047 Index_Base : constant Entity_Id := Base_Type (Etype (Index));
1048 Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base);
1049 Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);
1051 function Add (Val : Int; To : Node_Id) return Node_Id;
1052 -- Returns an expression where Val is added to expression To, unless
1053 -- To+Val is provably out of To's base type range. To must be an
1054 -- already analyzed expression.
1056 function Empty_Range (L, H : Node_Id) return Boolean;
1057 -- Returns True if the range defined by L .. H is certainly empty
1059 function Equal (L, H : Node_Id) return Boolean;
1060 -- Returns True if L = H for sure
1062 function Index_Base_Name return Node_Id;
1063 -- Returns a new reference to the index type name
1068 In_Loop : Boolean := False) return List_Id;
1069 -- Ind must be a side-effect-free expression. If the input aggregate N
1070 -- to Build_Loop contains no subaggregates, then this function returns
1071 -- the assignment statement:
1073 -- Into (Indexes, Ind) := Expr;
1075 -- Otherwise we call Build_Code recursively. Flag In_Loop should be set
1076 -- when the assignment appears within a generated loop.
1078 -- Ada 2005 (AI-287): In case of default initialized component, Expr
1079 -- is empty and we generate a call to the corresponding IP subprogram.
1081 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
1082 -- Nodes L and H must be side-effect-free expressions. If the input
1083 -- aggregate N to Build_Loop contains no subaggregates, this routine
1084 -- returns the for loop statement:
1086 -- for J in Index_Base'(L) .. Index_Base'(H) loop
1087 -- Into (Indexes, J) := Expr;
1090 -- Otherwise we call Build_Code recursively. As an optimization if the
1091 -- loop covers 3 or fewer scalar elements we generate a sequence of
1093 -- If the component association that generates the loop comes from an
1094 -- Iterated_Component_Association, the loop parameter has the name of
1095 -- the corresponding parameter in the original construct.
1097 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
1098 -- Nodes L and H must be side-effect-free expressions. If the input
1099 -- aggregate N to Build_Loop contains no subaggregates, this routine
1100 -- returns the while loop statement:
1102 -- J : Index_Base := L;
1104 -- J := Index_Base'Succ (J);
1105 -- Into (Indexes, J) := Expr;
1108 -- Otherwise we call Build_Code recursively
1110 function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id;
1111 -- For an association with a box, use value given by aspect
1112 -- Default_Component_Value of array type if specified, else use
1113 -- value given by aspect Default_Value for component type itself
1114 -- if specified, else return Empty.
1116 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
1117 function Local_Expr_Value (E : Node_Id) return Uint;
1118 -- These two Local routines are used to replace the corresponding ones
1119 -- in sem_eval because while processing the bounds of an aggregate with
1120 -- discrete choices whose index type is an enumeration, we build static
1121 -- expressions not recognized by Compile_Time_Known_Value as such since
1122 -- they have not yet been analyzed and resolved. All the expressions in
1123 -- question are things like Index_Base_Name'Val (Const) which we can
1124 -- easily recognize as being constant.
1130 function Add (Val : Int; To : Node_Id) return Node_Id is
1135 U_Val : constant Uint := UI_From_Int (Val);
1138 -- Note: do not try to optimize the case of Val = 0, because
1139 -- we need to build a new node with the proper Sloc value anyway.
1141 -- First test if we can do constant folding
1143 if Local_Compile_Time_Known_Value (To) then
1144 U_To := Local_Expr_Value (To) + Val;
1146 -- Determine if our constant is outside the range of the index.
1147 -- If so return an Empty node. This empty node will be caught
1148 -- by Empty_Range below.
1150 if Compile_Time_Known_Value (Index_Base_L)
1151 and then U_To < Expr_Value (Index_Base_L)
1155 elsif Compile_Time_Known_Value (Index_Base_H)
1156 and then U_To > Expr_Value (Index_Base_H)
1161 Expr_Pos := Make_Integer_Literal (Loc, U_To);
1162 Set_Is_Static_Expression (Expr_Pos);
1164 if not Is_Enumeration_Type (Index_Base) then
1167 -- If we are dealing with enumeration return
1168 -- Index_Base'Val (Expr_Pos)
1172 Make_Attribute_Reference
1174 Prefix => Index_Base_Name,
1175 Attribute_Name => Name_Val,
1176 Expressions => New_List (Expr_Pos));
1182 -- If we are here no constant folding possible
1184 if not Is_Enumeration_Type (Index_Base) then
1187 Left_Opnd => Duplicate_Subexpr (To),
1188 Right_Opnd => Make_Integer_Literal (Loc, U_Val));
1190 -- If we are dealing with enumeration return
1191 -- Index_Base'Val (Index_Base'Pos (To) + Val)
1195 Make_Attribute_Reference
1197 Prefix => Index_Base_Name,
1198 Attribute_Name => Name_Pos,
1199 Expressions => New_List (Duplicate_Subexpr (To)));
1203 Left_Opnd => To_Pos,
1204 Right_Opnd => Make_Integer_Literal (Loc, U_Val));
1207 Make_Attribute_Reference
1209 Prefix => Index_Base_Name,
1210 Attribute_Name => Name_Val,
1211 Expressions => New_List (Expr_Pos));
1221 function Empty_Range (L, H : Node_Id) return Boolean is
1222 Is_Empty : Boolean := False;
1227 -- First check if L or H were already detected as overflowing the
1228 -- index base range type by function Add above. If this is so Add
1229 -- returns the empty node.
1231 if No (L) or else No (H) then
1235 for J in 1 .. 3 loop
1238 -- L > H range is empty
1244 -- B_L > H range must be empty
1247 Low := Index_Base_L;
1250 -- L > B_H range must be empty
1254 High := Index_Base_H;
1257 if Local_Compile_Time_Known_Value (Low)
1259 Local_Compile_Time_Known_Value (High)
1262 UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High));
1275 function Equal (L, H : Node_Id) return Boolean is
1280 elsif Local_Compile_Time_Known_Value (L)
1282 Local_Compile_Time_Known_Value (H)
1284 return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H));
1297 In_Loop : Boolean := False) return List_Id
1299 function Add_Loop_Actions (Lis : List_Id) return List_Id;
1300 -- Collect insert_actions generated in the construction of a loop,
1301 -- and prepend them to the sequence of assignments to complete the
1302 -- eventual body of the loop.
1304 procedure Initialize_Array_Component
1305 (Arr_Comp : Node_Id;
1307 Init_Expr : Node_Id;
1309 -- Perform the initialization of array component Arr_Comp with
1310 -- expected type Comp_Typ. Init_Expr denotes the initialization
1311 -- expression of the array component. All generated code is added
1314 procedure Initialize_Ctrl_Array_Component
1315 (Arr_Comp : Node_Id;
1316 Comp_Typ : Entity_Id;
1317 Init_Expr : Node_Id;
1319 -- Perform the initialization of array component Arr_Comp when its
1320 -- expected type Comp_Typ needs finalization actions. Init_Expr is
1321 -- the initialization expression of the array component. All hook-
1322 -- related declarations are inserted prior to aggregate N. Remaining
1323 -- code is added to list Stmts.
1325 ----------------------
1326 -- Add_Loop_Actions --
1327 ----------------------
1329 function Add_Loop_Actions (Lis : List_Id) return List_Id is
1333 -- Ada 2005 (AI-287): Do nothing else in case of default
1334 -- initialized component.
1339 elsif Nkind (Parent (Expr)) = N_Component_Association
1340 and then Present (Loop_Actions (Parent (Expr)))
1342 Append_List (Lis, Loop_Actions (Parent (Expr)));
1343 Res := Loop_Actions (Parent (Expr));
1344 Set_Loop_Actions (Parent (Expr), No_List);
1350 end Add_Loop_Actions;
1352 --------------------------------
1353 -- Initialize_Array_Component --
1354 --------------------------------
1356 procedure Initialize_Array_Component
1357 (Arr_Comp : Node_Id;
1359 Init_Expr : Node_Id;
1362 Exceptions_OK : constant Boolean :=
1363 not Restriction_Active
1364 (No_Exception_Propagation);
1366 Finalization_OK : constant Boolean :=
1368 and then Needs_Finalization (Comp_Typ);
1370 Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
1372 Blk_Stmts : List_Id;
1373 Init_Stmt : Node_Id;
1376 -- Protect the initialization statements from aborts. Generate:
1380 if Finalization_OK and Abort_Allowed then
1381 if Exceptions_OK then
1382 Blk_Stmts := New_List;
1387 Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
1389 -- Otherwise aborts are not allowed. All generated code is added
1390 -- directly to the input list.
1396 -- Initialize the array element. Generate:
1398 -- Arr_Comp := Init_Expr;
1400 -- Note that the initialization expression is replicated because
1401 -- it has to be reevaluated within a generated loop.
1404 Make_OK_Assignment_Statement (Loc,
1405 Name => New_Copy_Tree (Arr_Comp),
1406 Expression => New_Copy_Tree (Init_Expr));
1407 Set_No_Ctrl_Actions (Init_Stmt);
1409 -- If this is an aggregate for an array of arrays, each
1410 -- subaggregate will be expanded as well, and even with
1411 -- No_Ctrl_Actions the assignments of inner components will
1412 -- require attachment in their assignments to temporaries. These
1413 -- temporaries must be finalized for each subaggregate. Generate:
1416 -- Arr_Comp := Init_Expr;
1419 if Finalization_OK and then Is_Array_Type (Comp_Typ) then
1421 Make_Block_Statement (Loc,
1422 Handled_Statement_Sequence =>
1423 Make_Handled_Sequence_Of_Statements (Loc,
1424 Statements => New_List (Init_Stmt)));
1427 Append_To (Blk_Stmts, Init_Stmt);
1429 -- Adjust the tag due to a possible view conversion. Generate:
1431 -- Arr_Comp._tag := Full_TypP;
1433 if Tagged_Type_Expansion
1434 and then Present (Comp_Typ)
1435 and then Is_Tagged_Type (Comp_Typ)
1437 Append_To (Blk_Stmts,
1438 Make_OK_Assignment_Statement (Loc,
1440 Make_Selected_Component (Loc,
1441 Prefix => New_Copy_Tree (Arr_Comp),
1444 (First_Tag_Component (Full_Typ), Loc)),
1447 Unchecked_Convert_To (RTE (RE_Tag),
1449 (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
1453 -- Adjust the array component. Controlled subaggregates are not
1454 -- considered because each of their individual elements will
1455 -- receive an adjustment of its own. Generate:
1457 -- [Deep_]Adjust (Arr_Comp);
1460 and then not Is_Limited_Type (Comp_Typ)
1461 and then not Is_Build_In_Place_Function_Call (Init_Expr)
1463 (Is_Array_Type (Comp_Typ)
1464 and then Is_Controlled (Component_Type (Comp_Typ))
1465 and then Nkind (Expr) = N_Aggregate)
1469 (Obj_Ref => New_Copy_Tree (Arr_Comp),
1472 -- Guard against a missing [Deep_]Adjust when the component
1473 -- type was not frozen properly.
1475 if Present (Adj_Call) then
1476 Append_To (Blk_Stmts, Adj_Call);
1480 -- Complete the protection of the initialization statements
1482 if Finalization_OK and Abort_Allowed then
1484 -- Wrap the initialization statements in a block to catch a
1485 -- potential exception. Generate:
1489 -- Arr_Comp := Init_Expr;
1490 -- Arr_Comp._tag := Full_TypP;
1491 -- [Deep_]Adjust (Arr_Comp);
1493 -- Abort_Undefer_Direct;
1496 if Exceptions_OK then
1498 Build_Abort_Undefer_Block (Loc,
1502 -- Otherwise exceptions are not propagated. Generate:
1505 -- Arr_Comp := Init_Expr;
1506 -- Arr_Comp._tag := Full_TypP;
1507 -- [Deep_]Adjust (Arr_Comp);
1511 Append_To (Blk_Stmts,
1512 Build_Runtime_Call (Loc, RE_Abort_Undefer));
1515 end Initialize_Array_Component;
1517 -------------------------------------
1518 -- Initialize_Ctrl_Array_Component --
1519 -------------------------------------
1521 procedure Initialize_Ctrl_Array_Component
1522 (Arr_Comp : Node_Id;
1523 Comp_Typ : Entity_Id;
1524 Init_Expr : Node_Id;
1528 Act_Stmts : List_Id;
1531 Hook_Clear : Node_Id;
1533 In_Place_Expansion : Boolean;
1534 -- Flag set when a nonlimited controlled function call requires
1535 -- in-place expansion.
1538 -- Duplicate the initialization expression in case the context is
1539 -- a multi choice list or an "others" choice which plugs various
1540 -- holes in the aggregate. As a result the expression is no longer
1541 -- shared between the various components and is reevaluated for
1542 -- each such component.
1544 Expr := New_Copy_Tree (Init_Expr);
1545 Set_Parent (Expr, Parent (Init_Expr));
1547 -- Perform a preliminary analysis and resolution to determine what
1548 -- the initialization expression denotes. An unanalyzed function
1549 -- call may appear as an identifier or an indexed component.
1551 if Nkind (Expr) in N_Function_Call
1553 | N_Indexed_Component
1554 and then not Analyzed (Expr)
1556 Preanalyze_And_Resolve (Expr, Comp_Typ);
1559 In_Place_Expansion :=
1560 Nkind (Expr) = N_Function_Call
1561 and then not Is_Build_In_Place_Result_Type (Comp_Typ);
1563 -- The initialization expression is a controlled function call.
1564 -- Perform in-place removal of side effects to avoid creating a
1565 -- transient scope, which leads to premature finalization.
1567 -- This in-place expansion is not performed for limited transient
1568 -- objects, because the initialization is already done in place.
1570 if In_Place_Expansion then
1572 -- Suppress the removal of side effects by general analysis,
1573 -- because this behavior is emulated here. This avoids the
1574 -- generation of a transient scope, which leads to out-of-order
1575 -- adjustment and finalization.
1577 Set_No_Side_Effect_Removal (Expr);
1579 -- When the transient component initialization is related to a
1580 -- range or an "others", keep all generated statements within
1581 -- the enclosing loop. This way the controlled function call
1582 -- will be evaluated at each iteration, and its result will be
1583 -- finalized at the end of each iteration.
1589 -- Otherwise this is a single component initialization. Hook-
1590 -- related statements are inserted prior to the aggregate.
1594 Act_Stmts := No_List;
1597 -- Install all hook-related declarations and prepare the clean
1600 Process_Transient_Component
1602 Comp_Typ => Comp_Typ,
1604 Fin_Call => Fin_Call,
1605 Hook_Clear => Hook_Clear,
1607 Stmts => Act_Stmts);
1610 -- Use the noncontrolled component initialization circuitry to
1611 -- assign the result of the function call to the array element.
1612 -- This also performs subaggregate wrapping, tag adjustment, and
1613 -- [deep] adjustment of the array element.
1615 Initialize_Array_Component
1616 (Arr_Comp => Arr_Comp,
1617 Comp_Typ => Comp_Typ,
1621 -- At this point the array element is fully initialized. Complete
1622 -- the processing of the controlled array component by finalizing
1623 -- the transient function result.
1625 if In_Place_Expansion then
1626 Process_Transient_Component_Completion
1629 Fin_Call => Fin_Call,
1630 Hook_Clear => Hook_Clear,
1633 end Initialize_Ctrl_Array_Component;
1637 Stmts : constant List_Id := New_List;
1639 Comp_Typ : Entity_Id := Empty;
1641 Indexed_Comp : Node_Id;
1642 Init_Call : Node_Id;
1643 New_Indexes : List_Id;
1645 -- Start of processing for Gen_Assign
1648 if No (Indexes) then
1649 New_Indexes := New_List;
1651 New_Indexes := New_Copy_List_Tree (Indexes);
1654 Append_To (New_Indexes, Ind);
1656 if Present (Next_Index (Index)) then
1659 Build_Array_Aggr_Code
1662 Index => Next_Index (Index),
1664 Scalar_Comp => Scalar_Comp,
1665 Indexes => New_Indexes));
1668 -- If we get here then we are at a bottom-level (sub-)aggregate
1672 (Make_Indexed_Component (Loc,
1673 Prefix => New_Copy_Tree (Into),
1674 Expressions => New_Indexes));
1676 Set_Assignment_OK (Indexed_Comp);
1678 -- Ada 2005 (AI-287): In case of default initialized component, Expr
1679 -- is not present (and therefore we also initialize Expr_Q to empty).
1683 elsif Nkind (Expr) = N_Qualified_Expression then
1684 Expr_Q := Expression (Expr);
1689 if Present (Etype (N)) and then Etype (N) /= Any_Composite then
1690 Comp_Typ := Component_Type (Etype (N));
1691 pragma Assert (Comp_Typ = Ctype); -- AI-287
1693 elsif Present (Next (First (New_Indexes))) then
1695 -- Ada 2005 (AI-287): Do nothing in case of default initialized
1696 -- component because we have received the component type in
1697 -- the formal parameter Ctype.
1699 -- ??? Some assert pragmas have been added to check if this new
1700 -- formal can be used to replace this code in all cases.
1702 if Present (Expr) then
1704 -- This is a multidimensional array. Recover the component type
1705 -- from the outermost aggregate, because subaggregates do not
1706 -- have an assigned type.
1713 while Present (P) loop
1714 if Nkind (P) = N_Aggregate
1715 and then Present (Etype (P))
1717 Comp_Typ := Component_Type (Etype (P));
1725 pragma Assert (Comp_Typ = Ctype); -- AI-287
1730 -- Ada 2005 (AI-287): We only analyze the expression in case of non-
1731 -- default initialized components (otherwise Expr_Q is not present).
1734 and then Nkind (Expr_Q) in N_Aggregate | N_Extension_Aggregate
1736 -- At this stage the Expression may not have been analyzed yet
1737 -- because the array aggregate code has not been updated to use
1738 -- the Expansion_Delayed flag and avoid analysis altogether to
1739 -- solve the same problem (see Resolve_Aggr_Expr). So let us do
1740 -- the analysis of non-array aggregates now in order to get the
1741 -- value of Expansion_Delayed flag for the inner aggregate ???
1743 -- In the case of an iterated component association, the analysis
1744 -- of the generated loop will analyze the expression in the
1745 -- proper context, in which the loop parameter is visible.
1747 if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ) then
1748 if Nkind (Parent (Expr_Q)) = N_Iterated_Component_Association
1749 or else Nkind (Parent (Parent ((Expr_Q)))) =
1750 N_Iterated_Component_Association
1754 Analyze_And_Resolve (Expr_Q, Comp_Typ);
1758 if Is_Delayed_Aggregate (Expr_Q) then
1760 -- This is either a subaggregate of a multidimensional array,
1761 -- or a component of an array type whose component type is
1762 -- also an array. In the latter case, the expression may have
1763 -- component associations that provide different bounds from
1764 -- those of the component type, and sliding must occur. Instead
1765 -- of decomposing the current aggregate assignment, force the
1766 -- reanalysis of the assignment, so that a temporary will be
1767 -- generated in the usual fashion, and sliding will take place.
1769 if Nkind (Parent (N)) = N_Assignment_Statement
1770 and then Is_Array_Type (Comp_Typ)
1771 and then Present (Component_Associations (Expr_Q))
1772 and then Must_Slide (Comp_Typ, Etype (Expr_Q))
1774 Set_Expansion_Delayed (Expr_Q, False);
1775 Set_Analyzed (Expr_Q, False);
1780 Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp));
1785 if Present (Expr) then
1787 -- Handle an initialization expression of a controlled type in
1788 -- case it denotes a function call. In general such a scenario
1789 -- will produce a transient scope, but this will lead to wrong
1790 -- order of initialization, adjustment, and finalization in the
1791 -- context of aggregates.
1793 -- Target (1) := Ctrl_Func_Call;
1796 -- Trans_Obj : ... := Ctrl_Func_Call; -- object
1797 -- Target (1) := Trans_Obj;
1798 -- Finalize (Trans_Obj);
1800 -- Target (1)._tag := ...;
1801 -- Adjust (Target (1));
1803 -- In the example above, the call to Finalize occurs too early
1804 -- and as a result it may leave the array component in a bad
1805 -- state. Finalization of the transient object should really
1806 -- happen after adjustment.
1808 -- To avoid this scenario, perform in-place side-effect removal
1809 -- of the function call. This eliminates the transient property
1810 -- of the function result and ensures correct order of actions.
1812 -- Res : ... := Ctrl_Func_Call;
1813 -- Target (1) := Res;
1814 -- Target (1)._tag := ...;
1815 -- Adjust (Target (1));
1818 if Present (Comp_Typ)
1819 and then Needs_Finalization (Comp_Typ)
1820 and then Nkind (Expr) /= N_Aggregate
1822 Initialize_Ctrl_Array_Component
1823 (Arr_Comp => Indexed_Comp,
1824 Comp_Typ => Comp_Typ,
1828 -- Otherwise perform simple component initialization
1831 Initialize_Array_Component
1832 (Arr_Comp => Indexed_Comp,
1833 Comp_Typ => Comp_Typ,
1838 -- Ada 2005 (AI-287): In case of default initialized component, call
1839 -- the initialization subprogram associated with the component type.
1840 -- If the component type is an access type, add an explicit null
1841 -- assignment, because for the back-end there is an initialization
1842 -- present for the whole aggregate, and no default initialization
1845 -- In addition, if the component type is controlled, we must call
1846 -- its Initialize procedure explicitly, because there is no explicit
1847 -- object creation that will invoke it otherwise.
1850 if Present (Base_Init_Proc (Base_Type (Ctype)))
1851 or else Has_Task (Base_Type (Ctype))
1853 Append_List_To (Stmts,
1854 Build_Initialization_Call (Loc,
1855 Id_Ref => Indexed_Comp,
1857 With_Default_Init => True));
1859 -- If the component type has invariants, add an invariant
1860 -- check after the component is default-initialized. It will
1861 -- be analyzed and resolved before the code for initialization
1862 -- of other components.
1864 if Has_Invariants (Ctype) then
1865 Set_Etype (Indexed_Comp, Ctype);
1866 Append_To (Stmts, Make_Invariant_Call (Indexed_Comp));
1869 elsif Is_Access_Type (Ctype) then
1871 Make_Assignment_Statement (Loc,
1872 Name => New_Copy_Tree (Indexed_Comp),
1873 Expression => Make_Null (Loc)));
1876 if Needs_Finalization (Ctype) then
1879 (Obj_Ref => New_Copy_Tree (Indexed_Comp),
1882 -- Guard against a missing [Deep_]Initialize when the component
1883 -- type was not properly frozen.
1885 if Present (Init_Call) then
1886 Append_To (Stmts, Init_Call);
1890 -- If Default_Initial_Condition applies to the component type,
1891 -- add a DIC check after the component is default-initialized,
1892 -- as well as after an Initialize procedure is called, in the
1893 -- case of components of a controlled type. It will be analyzed
1894 -- and resolved before the code for initialization of other
1897 -- Theoretically this might also be needed for cases where Expr
1898 -- is not empty, but a default init still applies, such as for
1899 -- Default_Value cases, in which case we won't get here. ???
1901 if Has_DIC (Ctype) and then Present (DIC_Procedure (Ctype)) then
1903 Build_DIC_Call (Loc, New_Copy_Tree (Indexed_Comp), Ctype));
1907 return Add_Loop_Actions (Stmts);
1914 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
1915 Is_Iterated_Component : constant Boolean :=
1916 Nkind (Parent (Expr)) = N_Iterated_Component_Association;
1927 -- Index_Base'(L) .. Index_Base'(H)
1929 L_Iteration_Scheme : Node_Id;
1930 -- L_J in Index_Base'(L) .. Index_Base'(H)
1933 -- The statements to execute in the loop
1935 S : constant List_Id := New_List;
1936 -- List of statements
1939 -- Copy of expression tree, used for checking purposes
1942 -- If loop bounds define an empty range return the null statement
1944 if Empty_Range (L, H) then
1945 Append_To (S, Make_Null_Statement (Loc));
1947 -- Ada 2005 (AI-287): Nothing else need to be done in case of
1948 -- default initialized component.
1954 -- The expression must be type-checked even though no component
1955 -- of the aggregate will have this value. This is done only for
1956 -- actual components of the array, not for subaggregates. Do
1957 -- the check on a copy, because the expression may be shared
1958 -- among several choices, some of which might be non-null.
1960 if Present (Etype (N))
1961 and then Is_Array_Type (Etype (N))
1962 and then No (Next_Index (Index))
1964 Expander_Mode_Save_And_Set (False);
1965 Tcopy := New_Copy_Tree (Expr);
1966 Set_Parent (Tcopy, N);
1968 -- For iterated_component_association analyze and resolve
1969 -- the expression with name of the index parameter visible.
1970 -- To manipulate scopes, we use entity of the implicit loop.
1972 if Is_Iterated_Component then
1974 Index_Parameter : constant Entity_Id :=
1975 Defining_Identifier (Parent (Expr));
1977 Push_Scope (Scope (Index_Parameter));
1978 Enter_Name (Index_Parameter);
1980 (Tcopy, Component_Type (Etype (N)));
1984 -- For ordinary component association, just analyze and
1985 -- resolve the expression.
1988 Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
1991 Expander_Mode_Restore;
1997 -- If loop bounds are the same then generate an assignment, unless
1998 -- the parent construct is an Iterated_Component_Association.
2000 elsif Equal (L, H) and then not Is_Iterated_Component then
2001 return Gen_Assign (New_Copy_Tree (L), Expr);
2003 -- If H - L <= 2 then generate a sequence of assignments when we are
2004 -- processing the bottom most aggregate and it contains scalar
2007 elsif No (Next_Index (Index))
2008 and then Scalar_Comp
2009 and then Local_Compile_Time_Known_Value (L)
2010 and then Local_Compile_Time_Known_Value (H)
2011 and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
2012 and then not Is_Iterated_Component
2014 Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
2015 Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
2017 if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then
2018 Append_List_To (S, Gen_Assign (Add (2, To => L), Expr));
2024 -- Otherwise construct the loop, starting with the loop index L_J
2026 if Is_Iterated_Component then
2028 Make_Defining_Identifier (Loc,
2029 Chars => (Chars (Defining_Identifier (Parent (Expr)))));
2032 L_J := Make_Temporary (Loc, 'J', L);
2035 -- Construct "L .. H" in Index_Base. We use a qualified expression
2036 -- for the bound to convert to the index base, but we don't need
2037 -- to do that if we already have the base type at hand.
2039 if Etype (L) = Index_Base then
2043 Make_Qualified_Expression (Loc,
2044 Subtype_Mark => Index_Base_Name,
2045 Expression => New_Copy_Tree (L));
2048 if Etype (H) = Index_Base then
2052 Make_Qualified_Expression (Loc,
2053 Subtype_Mark => Index_Base_Name,
2054 Expression => New_Copy_Tree (H));
2062 -- Construct "for L_J in Index_Base range L .. H"
2064 L_Iteration_Scheme :=
2065 Make_Iteration_Scheme
2067 Loop_Parameter_Specification =>
2068 Make_Loop_Parameter_Specification
2070 Defining_Identifier => L_J,
2071 Discrete_Subtype_Definition => L_Range));
2073 -- Construct the statements to execute in the loop body
2076 Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr, In_Loop => True);
2078 -- Construct the final loop
2081 Make_Implicit_Loop_Statement
2083 Identifier => Empty,
2084 Iteration_Scheme => L_Iteration_Scheme,
2085 Statements => L_Body));
2087 -- A small optimization: if the aggregate is initialized with a box
2088 -- and the component type has no initialization procedure, remove the
2089 -- useless empty loop.
2091 if Nkind (First (S)) = N_Loop_Statement
2092 and then Is_Empty_List (Statements (First (S)))
2094 return New_List (Make_Null_Statement (Loc));
2104 -- The code built is
2106 -- W_J : Index_Base := L;
2107 -- while W_J < H loop
2108 -- W_J := Index_Base'Succ (W);
2112 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is
2116 -- W_J : Base_Type := L;
2118 W_Iteration_Scheme : Node_Id;
2121 W_Index_Succ : Node_Id;
2122 -- Index_Base'Succ (J)
2124 W_Increment : Node_Id;
2125 -- W_J := Index_Base'Succ (W)
2127 W_Body : constant List_Id := New_List;
2128 -- The statements to execute in the loop
2130 S : constant List_Id := New_List;
2131 -- list of statement
2134 -- If loop bounds define an empty range or are equal return null
2136 if Empty_Range (L, H) or else Equal (L, H) then
2137 Append_To (S, Make_Null_Statement (Loc));
2141 -- Build the decl of W_J
2143 W_J := Make_Temporary (Loc, 'J', L);
2145 Make_Object_Declaration
2147 Defining_Identifier => W_J,
2148 Object_Definition => Index_Base_Name,
2151 -- Theoretically we should do a New_Copy_Tree (L) here, but we know
2152 -- that in this particular case L is a fresh Expr generated by
2153 -- Add which we are the only ones to use.
2155 Append_To (S, W_Decl);
2157 -- Construct " while W_J < H"
2159 W_Iteration_Scheme :=
2160 Make_Iteration_Scheme
2162 Condition => Make_Op_Lt
2164 Left_Opnd => New_Occurrence_Of (W_J, Loc),
2165 Right_Opnd => New_Copy_Tree (H)));
2167 -- Construct the statements to execute in the loop body
2170 Make_Attribute_Reference
2172 Prefix => Index_Base_Name,
2173 Attribute_Name => Name_Succ,
2174 Expressions => New_List (New_Occurrence_Of (W_J, Loc)));
2177 Make_OK_Assignment_Statement
2179 Name => New_Occurrence_Of (W_J, Loc),
2180 Expression => W_Index_Succ);
2182 Append_To (W_Body, W_Increment);
2184 Append_List_To (W_Body,
2185 Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr, In_Loop => True));
2187 -- Construct the final loop
2190 Make_Implicit_Loop_Statement
2192 Identifier => Empty,
2193 Iteration_Scheme => W_Iteration_Scheme,
2194 Statements => W_Body));
2199 --------------------
2200 -- Get_Assoc_Expr --
2201 --------------------
2203 function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id is
2204 Typ : constant Entity_Id := Base_Type (Etype (N));
2207 if Box_Present (Assoc) then
2208 if Is_Scalar_Type (Ctype) then
2209 if Present (Default_Aspect_Component_Value (Typ)) then
2210 return Default_Aspect_Component_Value (Typ);
2211 elsif Present (Default_Aspect_Value (Ctype)) then
2212 return Default_Aspect_Value (Ctype);
2222 return Expression (Assoc);
2226 ---------------------
2227 -- Index_Base_Name --
2228 ---------------------
2230 function Index_Base_Name return Node_Id is
2232 return New_Occurrence_Of (Index_Base, Sloc (N));
2233 end Index_Base_Name;
2235 ------------------------------------
2236 -- Local_Compile_Time_Known_Value --
2237 ------------------------------------
2239 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is
2241 return Compile_Time_Known_Value (E)
2243 (Nkind (E) = N_Attribute_Reference
2244 and then Attribute_Name (E) = Name_Val
2245 and then Compile_Time_Known_Value (First (Expressions (E))));
2246 end Local_Compile_Time_Known_Value;
2248 ----------------------
2249 -- Local_Expr_Value --
2250 ----------------------
2252 function Local_Expr_Value (E : Node_Id) return Uint is
2254 if Compile_Time_Known_Value (E) then
2255 return Expr_Value (E);
2257 return Expr_Value (First (Expressions (E)));
2259 end Local_Expr_Value;
2263 New_Code : constant List_Id := New_List;
2265 Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
2266 Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
2267 -- The aggregate bounds of this specific subaggregate. Note that if the
2268 -- code generated by Build_Array_Aggr_Code is executed then these bounds
2269 -- are OK. Otherwise a Constraint_Error would have been raised.
2271 Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L);
2272 Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
2273 -- After Duplicate_Subexpr these are side-effect free
2282 Nb_Choices : Nat := 0;
2283 Table : Case_Table_Type (1 .. Number_Of_Choices (N));
2284 -- Used to sort all the different choice values
2287 -- Number of elements in the positional aggregate
2289 Others_Assoc : Node_Id := Empty;
2291 -- Start of processing for Build_Array_Aggr_Code
2294 -- First before we start, a special case. if we have a bit packed
2295 -- array represented as a modular type, then clear the value to
2296 -- zero first, to ensure that unused bits are properly cleared.
2301 and then Is_Bit_Packed_Array (Typ)
2302 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ))
2305 Zero : constant Node_Id := Make_Integer_Literal (Loc, Uint_0);
2307 Analyze_And_Resolve (Zero, Packed_Array_Impl_Type (Typ));
2308 Append_To (New_Code,
2309 Make_Assignment_Statement (Loc,
2310 Name => New_Copy_Tree (Into),
2311 Expression => Unchecked_Convert_To (Typ, Zero)));
2315 -- If the component type contains tasks, we need to build a Master
2316 -- entity in the current scope, because it will be needed if build-
2317 -- in-place functions are called in the expanded code.
2319 if Nkind (Parent (N)) = N_Object_Declaration and then Has_Task (Typ) then
2320 Build_Master_Entity (Defining_Identifier (Parent (N)));
2323 -- STEP 1: Process component associations
2325 -- For those associations that may generate a loop, initialize
2326 -- Loop_Actions to collect inserted actions that may be crated.
2328 -- Skip this if no component associations
2330 if No (Expressions (N)) then
2332 -- STEP 1 (a): Sort the discrete choices
2334 Assoc := First (Component_Associations (N));
2335 while Present (Assoc) loop
2336 Choice := First (Choice_List (Assoc));
2337 while Present (Choice) loop
2338 if Nkind (Choice) = N_Others_Choice then
2339 Others_Assoc := Assoc;
2343 Get_Index_Bounds (Choice, Low, High);
2346 Set_Loop_Actions (Assoc, New_List);
2349 Nb_Choices := Nb_Choices + 1;
2351 Table (Nb_Choices) :=
2354 Choice_Node => Get_Assoc_Expr (Assoc));
2362 -- If there is more than one set of choices these must be static
2363 -- and we can therefore sort them. Remember that Nb_Choices does not
2364 -- account for an others choice.
2366 if Nb_Choices > 1 then
2367 Sort_Case_Table (Table);
2370 -- STEP 1 (b): take care of the whole set of discrete choices
2372 for J in 1 .. Nb_Choices loop
2373 Low := Table (J).Choice_Lo;
2374 High := Table (J).Choice_Hi;
2375 Expr := Table (J).Choice_Node;
2376 Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
2379 -- STEP 1 (c): generate the remaining loops to cover others choice
2380 -- We don't need to generate loops over empty gaps, but if there is
2381 -- a single empty range we must analyze the expression for semantics
2383 if Present (Others_Assoc) then
2385 First : Boolean := True;
2389 for J in 0 .. Nb_Choices loop
2393 Low := Add (1, To => Table (J).Choice_Hi);
2396 if J = Nb_Choices then
2399 High := Add (-1, To => Table (J + 1).Choice_Lo);
2402 -- If this is an expansion within an init proc, make
2403 -- sure that discriminant references are replaced by
2404 -- the corresponding discriminal.
2406 if Inside_Init_Proc then
2407 if Is_Entity_Name (Low)
2408 and then Ekind (Entity (Low)) = E_Discriminant
2410 Set_Entity (Low, Discriminal (Entity (Low)));
2413 if Is_Entity_Name (High)
2414 and then Ekind (Entity (High)) = E_Discriminant
2416 Set_Entity (High, Discriminal (Entity (High)));
2421 or else not Empty_Range (Low, High)
2425 -- Duplicate the expression in case we will be generating
2426 -- several loops. As a result the expression is no longer
2427 -- shared between the loops and is reevaluated for each
2430 Expr := Get_Assoc_Expr (Others_Assoc);
2431 Dup_Expr := New_Copy_Tree (Expr);
2432 Set_Parent (Dup_Expr, Parent (Expr));
2434 Set_Loop_Actions (Others_Assoc, New_List);
2436 (Gen_Loop (Low, High, Dup_Expr), To => New_Code);
2442 -- STEP 2: Process positional components
2445 -- STEP 2 (a): Generate the assignments for each positional element
2446 -- Note that here we have to use Aggr_L rather than Aggr_Low because
2447 -- Aggr_L is analyzed and Add wants an analyzed expression.
2449 Expr := First (Expressions (N));
2451 while Present (Expr) loop
2452 Nb_Elements := Nb_Elements + 1;
2453 Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr),
2458 -- STEP 2 (b): Generate final loop if an others choice is present.
2459 -- Here Nb_Elements gives the offset of the last positional element.
2461 if Present (Component_Associations (N)) then
2462 Assoc := Last (Component_Associations (N));
2464 if Nkind (Assoc) = N_Iterated_Component_Association then
2465 -- Ada 2020: generate a loop to have a proper scope for
2466 -- the identifier that typically appears in the expression.
2467 -- The lower bound of the loop is the position after all
2468 -- previous positional components.
2470 Append_List (Gen_Loop (Add (Nb_Elements + 1, To => Aggr_L),
2472 Expression (Assoc)),
2475 -- Ada 2005 (AI-287)
2477 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
2479 Get_Assoc_Expr (Assoc)),
2486 end Build_Array_Aggr_Code;
2488 ----------------------------
2489 -- Build_Record_Aggr_Code --
2490 ----------------------------
2492 function Build_Record_Aggr_Code
2495 Lhs : Node_Id) return List_Id
2497 Loc : constant Source_Ptr := Sloc (N);
2498 L : constant List_Id := New_List;
2499 N_Typ : constant Entity_Id := Etype (N);
2505 Comp_Type : Entity_Id;
2506 Selector : Entity_Id;
2507 Comp_Expr : Node_Id;
2510 -- If this is an internal aggregate, the External_Final_List is an
2511 -- expression for the controller record of the enclosing type.
2513 -- If the current aggregate has several controlled components, this
2514 -- expression will appear in several calls to attach to the finali-
2515 -- zation list, and it must not be shared.
2517 Ancestor_Is_Expression : Boolean := False;
2518 Ancestor_Is_Subtype_Mark : Boolean := False;
2520 Init_Typ : Entity_Id := Empty;
2522 Finalization_Done : Boolean := False;
2523 -- True if Generate_Finalization_Actions has already been called; calls
2524 -- after the first do nothing.
2526 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
2527 -- Returns the value that the given discriminant of an ancestor type
2528 -- should receive (in the absence of a conflict with the value provided
2529 -- by an ancestor part of an extension aggregate).
2531 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id);
2532 -- Check that each of the discriminant values defined by the ancestor
2533 -- part of an extension aggregate match the corresponding values
2534 -- provided by either an association of the aggregate or by the
2535 -- constraint imposed by a parent type (RM95-4.3.2(8)).
2537 function Compatible_Int_Bounds
2538 (Agg_Bounds : Node_Id;
2539 Typ_Bounds : Node_Id) return Boolean;
2540 -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is
2541 -- assumed that both bounds are integer ranges.
2543 procedure Generate_Finalization_Actions;
2544 -- Deal with the various controlled type data structure initializations
2545 -- (but only if it hasn't been done already).
2547 function Get_Constraint_Association (T : Entity_Id) return Node_Id;
2548 -- Returns the first discriminant association in the constraint
2549 -- associated with T, if any, otherwise returns Empty.
2551 function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id;
2552 -- If the ancestor part is an unconstrained type and further ancestors
2553 -- do not provide discriminants for it, check aggregate components for
2554 -- values of the discriminants.
2556 procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id);
2557 -- If Typ is derived, and constrains discriminants of the parent type,
2558 -- these discriminants are not components of the aggregate, and must be
2559 -- initialized. The assignments are appended to List. The same is done
2560 -- if Typ derives fron an already constrained subtype of a discriminated
2563 procedure Init_Stored_Discriminants;
2564 -- If the type is derived and has inherited discriminants, generate
2565 -- explicit assignments for each, using the store constraint of the
2566 -- type. Note that both visible and stored discriminants must be
2567 -- initialized in case the derived type has some renamed and some
2568 -- constrained discriminants.
2570 procedure Init_Visible_Discriminants;
2571 -- If type has discriminants, retrieve their values from aggregate,
2572 -- and generate explicit assignments for each. This does not include
2573 -- discriminants inherited from ancestor, which are handled above.
2574 -- The type of the aggregate is a subtype created ealier using the
2575 -- given values of the discriminant components of the aggregate.
2577 procedure Initialize_Ctrl_Record_Component
2578 (Rec_Comp : Node_Id;
2579 Comp_Typ : Entity_Id;
2580 Init_Expr : Node_Id;
2582 -- Perform the initialization of controlled record component Rec_Comp.
2583 -- Comp_Typ is the component type. Init_Expr is the initialization
2584 -- expression for the record component. Hook-related declarations are
2585 -- inserted prior to aggregate N using Insert_Action. All remaining
2586 -- generated code is added to list Stmts.
2588 procedure Initialize_Record_Component
2589 (Rec_Comp : Node_Id;
2590 Comp_Typ : Entity_Id;
2591 Init_Expr : Node_Id;
2593 -- Perform the initialization of record component Rec_Comp. Comp_Typ
2594 -- is the component type. Init_Expr is the initialization expression
2595 -- of the record component. All generated code is added to list Stmts.
2597 function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
2598 -- Check whether Bounds is a range node and its lower and higher bounds
2599 -- are integers literals.
2601 function Replace_Type (Expr : Node_Id) return Traverse_Result;
2602 -- If the aggregate contains a self-reference, traverse each expression
2603 -- to replace a possible self-reference with a reference to the proper
2604 -- component of the target of the assignment.
2606 function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result;
2607 -- If default expression of a component mentions a discriminant of the
2608 -- type, it must be rewritten as the discriminant of the target object.
2610 ---------------------------------
2611 -- Ancestor_Discriminant_Value --
2612 ---------------------------------
2614 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is
2616 Assoc_Elmt : Elmt_Id;
2617 Aggr_Comp : Entity_Id;
2618 Corresp_Disc : Entity_Id;
2619 Current_Typ : Entity_Id := Base_Type (Typ);
2620 Parent_Typ : Entity_Id;
2621 Parent_Disc : Entity_Id;
2622 Save_Assoc : Node_Id := Empty;
2625 -- First check any discriminant associations to see if any of them
2626 -- provide a value for the discriminant.
2628 if Present (Discriminant_Specifications (Parent (Current_Typ))) then
2629 Assoc := First (Component_Associations (N));
2630 while Present (Assoc) loop
2631 Aggr_Comp := Entity (First (Choices (Assoc)));
2633 if Ekind (Aggr_Comp) = E_Discriminant then
2634 Save_Assoc := Expression (Assoc);
2636 Corresp_Disc := Corresponding_Discriminant (Aggr_Comp);
2637 while Present (Corresp_Disc) loop
2639 -- If found a corresponding discriminant then return the
2640 -- value given in the aggregate. (Note: this is not
2641 -- correct in the presence of side effects. ???)
2643 if Disc = Corresp_Disc then
2644 return Duplicate_Subexpr (Expression (Assoc));
2647 Corresp_Disc := Corresponding_Discriminant (Corresp_Disc);
2655 -- No match found in aggregate, so chain up parent types to find
2656 -- a constraint that defines the value of the discriminant.
2658 Parent_Typ := Etype (Current_Typ);
2659 while Current_Typ /= Parent_Typ loop
2660 if Has_Discriminants (Parent_Typ)
2661 and then not Has_Unknown_Discriminants (Parent_Typ)
2663 Parent_Disc := First_Discriminant (Parent_Typ);
2665 -- We either get the association from the subtype indication
2666 -- of the type definition itself, or from the discriminant
2667 -- constraint associated with the type entity (which is
2668 -- preferable, but it's not always present ???)
2670 if Is_Empty_Elmt_List (Discriminant_Constraint (Current_Typ))
2672 Assoc := Get_Constraint_Association (Current_Typ);
2673 Assoc_Elmt := No_Elmt;
2676 First_Elmt (Discriminant_Constraint (Current_Typ));
2677 Assoc := Node (Assoc_Elmt);
2680 -- Traverse the discriminants of the parent type looking
2681 -- for one that corresponds.
2683 while Present (Parent_Disc) and then Present (Assoc) loop
2684 Corresp_Disc := Parent_Disc;
2685 while Present (Corresp_Disc)
2686 and then Disc /= Corresp_Disc
2688 Corresp_Disc := Corresponding_Discriminant (Corresp_Disc);
2691 if Disc = Corresp_Disc then
2692 if Nkind (Assoc) = N_Discriminant_Association then
2693 Assoc := Expression (Assoc);
2696 -- If the located association directly denotes
2697 -- a discriminant, then use the value of a saved
2698 -- association of the aggregate. This is an approach
2699 -- used to handle certain cases involving multiple
2700 -- discriminants mapped to a single discriminant of
2701 -- a descendant. It's not clear how to locate the
2702 -- appropriate discriminant value for such cases. ???
2704 if Is_Entity_Name (Assoc)
2705 and then Ekind (Entity (Assoc)) = E_Discriminant
2707 Assoc := Save_Assoc;
2710 return Duplicate_Subexpr (Assoc);
2713 Next_Discriminant (Parent_Disc);
2715 if No (Assoc_Elmt) then
2719 Next_Elmt (Assoc_Elmt);
2721 if Present (Assoc_Elmt) then
2722 Assoc := Node (Assoc_Elmt);
2730 Current_Typ := Parent_Typ;
2731 Parent_Typ := Etype (Current_Typ);
2734 -- In some cases there's no ancestor value to locate (such as
2735 -- when an ancestor part given by an expression defines the
2736 -- discriminant value).
2739 end Ancestor_Discriminant_Value;
2741 ----------------------------------
2742 -- Check_Ancestor_Discriminants --
2743 ----------------------------------
2745 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is
2747 Disc_Value : Node_Id;
2751 Discr := First_Discriminant (Base_Type (Anc_Typ));
2752 while Present (Discr) loop
2753 Disc_Value := Ancestor_Discriminant_Value (Discr);
2755 if Present (Disc_Value) then
2756 Cond := Make_Op_Ne (Loc,
2758 Make_Selected_Component (Loc,
2759 Prefix => New_Copy_Tree (Target),
2760 Selector_Name => New_Occurrence_Of (Discr, Loc)),
2761 Right_Opnd => Disc_Value);
2764 Make_Raise_Constraint_Error (Loc,
2766 Reason => CE_Discriminant_Check_Failed));
2769 Next_Discriminant (Discr);
2771 end Check_Ancestor_Discriminants;
2773 ---------------------------
2774 -- Compatible_Int_Bounds --
2775 ---------------------------
2777 function Compatible_Int_Bounds
2778 (Agg_Bounds : Node_Id;
2779 Typ_Bounds : Node_Id) return Boolean
2781 Agg_Lo : constant Uint := Intval (Low_Bound (Agg_Bounds));
2782 Agg_Hi : constant Uint := Intval (High_Bound (Agg_Bounds));
2783 Typ_Lo : constant Uint := Intval (Low_Bound (Typ_Bounds));
2784 Typ_Hi : constant Uint := Intval (High_Bound (Typ_Bounds));
2786 return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi;
2787 end Compatible_Int_Bounds;
2789 -----------------------------------
2790 -- Generate_Finalization_Actions --
2791 -----------------------------------
2793 procedure Generate_Finalization_Actions is
2795 -- Do the work only the first time this is called
2797 if Finalization_Done then
2801 Finalization_Done := True;
2803 -- Determine the external finalization list. It is either the
2804 -- finalization list of the outer scope or the one coming from an
2805 -- outer aggregate. When the target is not a temporary, the proper
2806 -- scope is the scope of the target rather than the potentially
2807 -- transient current scope.
2809 if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then
2810 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2811 Set_Assignment_OK (Ref);
2814 Make_Procedure_Call_Statement (Loc,
2817 (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
2818 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
2820 end Generate_Finalization_Actions;
2822 --------------------------------
2823 -- Get_Constraint_Association --
2824 --------------------------------
2826 function Get_Constraint_Association (T : Entity_Id) return Node_Id is
2833 -- If type is private, get constraint from full view. This was
2834 -- previously done in an instance context, but is needed whenever
2835 -- the ancestor part has a discriminant, possibly inherited through
2836 -- multiple derivations.
2838 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
2839 Typ := Full_View (Typ);
2842 Indic := Subtype_Indication (Type_Definition (Parent (Typ)));
2844 -- Verify that the subtype indication carries a constraint
2846 if Nkind (Indic) = N_Subtype_Indication
2847 and then Present (Constraint (Indic))
2849 return First (Constraints (Constraint (Indic)));
2853 end Get_Constraint_Association;
2855 -------------------------------------
2856 -- Get_Explicit_Discriminant_Value --
2857 -------------------------------------
2859 function Get_Explicit_Discriminant_Value
2860 (D : Entity_Id) return Node_Id
2867 -- The aggregate has been normalized and all associations have a
2870 Assoc := First (Component_Associations (N));
2871 while Present (Assoc) loop
2872 Choice := First (Choices (Assoc));
2874 if Chars (Choice) = Chars (D) then
2875 Val := Expression (Assoc);
2884 end Get_Explicit_Discriminant_Value;
2886 -------------------------------
2887 -- Init_Hidden_Discriminants --
2888 -------------------------------
2890 procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id) is
2891 function Is_Completely_Hidden_Discriminant
2892 (Discr : Entity_Id) return Boolean;
2893 -- Determine whether Discr is a completely hidden discriminant of
2896 ---------------------------------------
2897 -- Is_Completely_Hidden_Discriminant --
2898 ---------------------------------------
2900 function Is_Completely_Hidden_Discriminant
2901 (Discr : Entity_Id) return Boolean
2906 -- Use First/Next_Entity as First/Next_Discriminant do not yield
2907 -- completely hidden discriminants.
2909 Item := First_Entity (Typ);
2910 while Present (Item) loop
2911 if Ekind (Item) = E_Discriminant
2912 and then Is_Completely_Hidden (Item)
2913 and then Chars (Original_Record_Component (Item)) =
2923 end Is_Completely_Hidden_Discriminant;
2927 Base_Typ : Entity_Id;
2929 Discr_Constr : Elmt_Id;
2930 Discr_Init : Node_Id;
2931 Discr_Val : Node_Id;
2932 In_Aggr_Type : Boolean;
2933 Par_Typ : Entity_Id;
2935 -- Start of processing for Init_Hidden_Discriminants
2938 -- The constraints on the hidden discriminants, if present, are kept
2939 -- in the Stored_Constraint list of the type itself, or in that of
2940 -- the base type. If not in the constraints of the aggregate itself,
2941 -- we examine ancestors to find discriminants that are not renamed
2942 -- by other discriminants but constrained explicitly.
2944 In_Aggr_Type := True;
2946 Base_Typ := Base_Type (Typ);
2947 while Is_Derived_Type (Base_Typ)
2949 (Present (Stored_Constraint (Base_Typ))
2951 (In_Aggr_Type and then Present (Stored_Constraint (Typ))))
2953 Par_Typ := Etype (Base_Typ);
2955 if not Has_Discriminants (Par_Typ) then
2959 Discr := First_Discriminant (Par_Typ);
2961 -- We know that one of the stored-constraint lists is present
2963 if Present (Stored_Constraint (Base_Typ)) then
2964 Discr_Constr := First_Elmt (Stored_Constraint (Base_Typ));
2966 -- For private extension, stored constraint may be on full view
2968 elsif Is_Private_Type (Base_Typ)
2969 and then Present (Full_View (Base_Typ))
2970 and then Present (Stored_Constraint (Full_View (Base_Typ)))
2973 First_Elmt (Stored_Constraint (Full_View (Base_Typ)));
2975 -- Otherwise, no discriminant to process
2978 Discr_Constr := No_Elmt;
2981 while Present (Discr) and then Present (Discr_Constr) loop
2982 Discr_Val := Node (Discr_Constr);
2984 -- The parent discriminant is renamed in the derived type,
2985 -- nothing to initialize.
2987 -- type Deriv_Typ (Discr : ...)
2988 -- is new Parent_Typ (Discr => Discr);
2990 if Is_Entity_Name (Discr_Val)
2991 and then Ekind (Entity (Discr_Val)) = E_Discriminant
2995 -- When the parent discriminant is constrained at the type
2996 -- extension level, it does not appear in the derived type.
2998 -- type Deriv_Typ (Discr : ...)
2999 -- is new Parent_Typ (Discr => Discr,
3000 -- Hidden_Discr => Expression);
3002 elsif Is_Completely_Hidden_Discriminant (Discr) then
3005 -- Otherwise initialize the discriminant
3009 Make_OK_Assignment_Statement (Loc,
3011 Make_Selected_Component (Loc,
3012 Prefix => New_Copy_Tree (Target),
3013 Selector_Name => New_Occurrence_Of (Discr, Loc)),
3014 Expression => New_Copy_Tree (Discr_Val));
3016 Append_To (List, Discr_Init);
3019 Next_Elmt (Discr_Constr);
3020 Next_Discriminant (Discr);
3023 In_Aggr_Type := False;
3024 Base_Typ := Base_Type (Par_Typ);
3026 end Init_Hidden_Discriminants;
3028 --------------------------------
3029 -- Init_Visible_Discriminants --
3030 --------------------------------
3032 procedure Init_Visible_Discriminants is
3033 Discriminant : Entity_Id;
3034 Discriminant_Value : Node_Id;
3037 Discriminant := First_Discriminant (Typ);
3038 while Present (Discriminant) loop
3040 Make_Selected_Component (Loc,
3041 Prefix => New_Copy_Tree (Target),
3042 Selector_Name => New_Occurrence_Of (Discriminant, Loc));
3044 Discriminant_Value :=
3045 Get_Discriminant_Value
3046 (Discriminant, Typ, Discriminant_Constraint (N_Typ));
3049 Make_OK_Assignment_Statement (Loc,
3051 Expression => New_Copy_Tree (Discriminant_Value));
3053 Append_To (L, Instr);
3055 Next_Discriminant (Discriminant);
3057 end Init_Visible_Discriminants;
3059 -------------------------------
3060 -- Init_Stored_Discriminants --
3061 -------------------------------
3063 procedure Init_Stored_Discriminants is
3064 Discriminant : Entity_Id;
3065 Discriminant_Value : Node_Id;
3068 Discriminant := First_Stored_Discriminant (Typ);
3069 while Present (Discriminant) loop
3071 Make_Selected_Component (Loc,
3072 Prefix => New_Copy_Tree (Target),
3073 Selector_Name => New_Occurrence_Of (Discriminant, Loc));
3075 Discriminant_Value :=
3076 Get_Discriminant_Value
3077 (Discriminant, N_Typ, Discriminant_Constraint (N_Typ));
3080 Make_OK_Assignment_Statement (Loc,
3082 Expression => New_Copy_Tree (Discriminant_Value));
3084 Append_To (L, Instr);
3086 Next_Stored_Discriminant (Discriminant);
3088 end Init_Stored_Discriminants;
3090 --------------------------------------
3091 -- Initialize_Ctrl_Record_Component --
3092 --------------------------------------
3094 procedure Initialize_Ctrl_Record_Component
3095 (Rec_Comp : Node_Id;
3096 Comp_Typ : Entity_Id;
3097 Init_Expr : Node_Id;
3101 Hook_Clear : Node_Id;
3103 In_Place_Expansion : Boolean;
3104 -- Flag set when a nonlimited controlled function call requires
3105 -- in-place expansion.
3108 -- Perform a preliminary analysis and resolution to determine what
3109 -- the initialization expression denotes. Unanalyzed function calls
3110 -- may appear as identifiers or indexed components.
3112 if Nkind (Init_Expr) in N_Function_Call
3114 | N_Indexed_Component
3115 and then not Analyzed (Init_Expr)
3117 Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
3120 In_Place_Expansion :=
3121 Nkind (Init_Expr) = N_Function_Call
3122 and then not Is_Build_In_Place_Result_Type (Comp_Typ);
3124 -- The initialization expression is a controlled function call.
3125 -- Perform in-place removal of side effects to avoid creating a
3128 -- This in-place expansion is not performed for limited transient
3129 -- objects because the initialization is already done in place.
3131 if In_Place_Expansion then
3133 -- Suppress the removal of side effects by general analysis
3134 -- because this behavior is emulated here. This avoids the
3135 -- generation of a transient scope, which leads to out-of-order
3136 -- adjustment and finalization.
3138 Set_No_Side_Effect_Removal (Init_Expr);
3140 -- Install all hook-related declarations and prepare the clean up
3141 -- statements. The generated code follows the initialization order
3142 -- of individual components and discriminants, rather than being
3143 -- inserted prior to the aggregate. This ensures that a transient
3144 -- component which mentions a discriminant has proper visibility
3145 -- of the discriminant.
3147 Process_Transient_Component
3149 Comp_Typ => Comp_Typ,
3150 Init_Expr => Init_Expr,
3151 Fin_Call => Fin_Call,
3152 Hook_Clear => Hook_Clear,
3156 -- Use the noncontrolled component initialization circuitry to
3157 -- assign the result of the function call to the record component.
3158 -- This also performs tag adjustment and [deep] adjustment of the
3159 -- record component.
3161 Initialize_Record_Component
3162 (Rec_Comp => Rec_Comp,
3163 Comp_Typ => Comp_Typ,
3164 Init_Expr => Init_Expr,
3167 -- At this point the record component is fully initialized. Complete
3168 -- the processing of the controlled record component by finalizing
3169 -- the transient function result.
3171 if In_Place_Expansion then
3172 Process_Transient_Component_Completion
3175 Fin_Call => Fin_Call,
3176 Hook_Clear => Hook_Clear,
3179 end Initialize_Ctrl_Record_Component;
3181 ---------------------------------
3182 -- Initialize_Record_Component --
3183 ---------------------------------
3185 procedure Initialize_Record_Component
3186 (Rec_Comp : Node_Id;
3187 Comp_Typ : Entity_Id;
3188 Init_Expr : Node_Id;
3191 Exceptions_OK : constant Boolean :=
3192 not Restriction_Active (No_Exception_Propagation);
3194 Finalization_OK : constant Boolean := Needs_Finalization (Comp_Typ);
3196 Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
3198 Blk_Stmts : List_Id;
3199 Init_Stmt : Node_Id;
3202 -- Protect the initialization statements from aborts. Generate:
3206 if Finalization_OK and Abort_Allowed then
3207 if Exceptions_OK then
3208 Blk_Stmts := New_List;
3213 Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
3215 -- Otherwise aborts are not allowed. All generated code is added
3216 -- directly to the input list.
3222 -- Initialize the record component. Generate:
3224 -- Rec_Comp := Init_Expr;
3226 -- Note that the initialization expression is NOT replicated because
3227 -- only a single component may be initialized by it.
3230 Make_OK_Assignment_Statement (Loc,
3231 Name => New_Copy_Tree (Rec_Comp),
3232 Expression => Init_Expr);
3233 Set_No_Ctrl_Actions (Init_Stmt);
3235 Append_To (Blk_Stmts, Init_Stmt);
3237 -- Adjust the tag due to a possible view conversion. Generate:
3239 -- Rec_Comp._tag := Full_TypeP;
3241 if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
3242 Append_To (Blk_Stmts,
3243 Make_OK_Assignment_Statement (Loc,
3245 Make_Selected_Component (Loc,
3246 Prefix => New_Copy_Tree (Rec_Comp),
3249 (First_Tag_Component (Full_Typ), Loc)),
3252 Unchecked_Convert_To (RTE (RE_Tag),
3254 (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
3258 -- Adjust the component. Generate:
3260 -- [Deep_]Adjust (Rec_Comp);
3263 and then not Is_Limited_Type (Comp_Typ)
3264 and then not Is_Build_In_Place_Function_Call (Init_Expr)
3268 (Obj_Ref => New_Copy_Tree (Rec_Comp),
3271 -- Guard against a missing [Deep_]Adjust when the component type
3272 -- was not properly frozen.
3274 if Present (Adj_Call) then
3275 Append_To (Blk_Stmts, Adj_Call);
3279 -- Complete the protection of the initialization statements
3281 if Finalization_OK and Abort_Allowed then
3283 -- Wrap the initialization statements in a block to catch a
3284 -- potential exception. Generate:
3288 -- Rec_Comp := Init_Expr;
3289 -- Rec_Comp._tag := Full_TypP;
3290 -- [Deep_]Adjust (Rec_Comp);
3292 -- Abort_Undefer_Direct;
3295 if Exceptions_OK then
3297 Build_Abort_Undefer_Block (Loc,
3301 -- Otherwise exceptions are not propagated. Generate:
3304 -- Rec_Comp := Init_Expr;
3305 -- Rec_Comp._tag := Full_TypP;
3306 -- [Deep_]Adjust (Rec_Comp);
3310 Append_To (Blk_Stmts,
3311 Build_Runtime_Call (Loc, RE_Abort_Undefer));
3314 end Initialize_Record_Component;
3316 -------------------------
3317 -- Is_Int_Range_Bounds --
3318 -------------------------
3320 function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
3322 return Nkind (Bounds) = N_Range
3323 and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
3324 and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
3325 end Is_Int_Range_Bounds;
3331 function Replace_Type (Expr : Node_Id) return Traverse_Result is
3333 -- Note regarding the Root_Type test below: Aggregate components for
3334 -- self-referential types include attribute references to the current
3335 -- instance, of the form: Typ'access, etc.. These references are
3336 -- rewritten as references to the target of the aggregate: the
3337 -- left-hand side of an assignment, the entity in a declaration,
3338 -- or a temporary. Without this test, we would improperly extended
3339 -- this rewriting to attribute references whose prefix was not the
3340 -- type of the aggregate.
3342 if Nkind (Expr) = N_Attribute_Reference
3343 and then Is_Entity_Name (Prefix (Expr))
3344 and then Is_Type (Entity (Prefix (Expr)))
3345 and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr)))
3347 if Is_Entity_Name (Lhs) then
3348 Rewrite (Prefix (Expr), New_Occurrence_Of (Entity (Lhs), Loc));
3352 Make_Attribute_Reference (Loc,
3353 Attribute_Name => Name_Unrestricted_Access,
3354 Prefix => New_Copy_Tree (Lhs)));
3355 Set_Analyzed (Parent (Expr), False);
3362 --------------------------
3363 -- Rewrite_Discriminant --
3364 --------------------------
3366 function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
3368 if Is_Entity_Name (Expr)
3369 and then Present (Entity (Expr))
3370 and then Ekind (Entity (Expr)) = E_In_Parameter
3371 and then Present (Discriminal_Link (Entity (Expr)))
3372 and then Scope (Discriminal_Link (Entity (Expr))) =
3373 Base_Type (Etype (N))
3376 Make_Selected_Component (Loc,
3377 Prefix => New_Copy_Tree (Lhs),
3378 Selector_Name => Make_Identifier (Loc, Chars (Expr))));
3380 -- The generated code will be reanalyzed, but if the reference
3381 -- to the discriminant appears within an already analyzed
3382 -- expression (e.g. a conditional) we must set its proper entity
3383 -- now. Context is an initialization procedure.
3389 end Rewrite_Discriminant;
3391 procedure Replace_Discriminants is
3392 new Traverse_Proc (Rewrite_Discriminant);
3394 procedure Replace_Self_Reference is
3395 new Traverse_Proc (Replace_Type);
3397 -- Start of processing for Build_Record_Aggr_Code
3400 if Has_Self_Reference (N) then
3401 Replace_Self_Reference (N);
3404 -- If the target of the aggregate is class-wide, we must convert it
3405 -- to the actual type of the aggregate, so that the proper components
3406 -- are visible. We know already that the types are compatible.
3408 if Present (Etype (Lhs))
3409 and then Is_Class_Wide_Type (Etype (Lhs))
3411 Target := Unchecked_Convert_To (Typ, Lhs);
3416 -- Deal with the ancestor part of extension aggregates or with the
3417 -- discriminants of the root type.
3419 if Nkind (N) = N_Extension_Aggregate then
3421 Ancestor : constant Node_Id := Ancestor_Part (N);
3426 -- If the ancestor part is a subtype mark "T", we generate
3428 -- init-proc (T (tmp)); if T is constrained and
3429 -- init-proc (S (tmp)); where S applies an appropriate
3430 -- constraint if T is unconstrained
3432 if Is_Entity_Name (Ancestor)
3433 and then Is_Type (Entity (Ancestor))
3435 Ancestor_Is_Subtype_Mark := True;
3437 if Is_Constrained (Entity (Ancestor)) then
3438 Init_Typ := Entity (Ancestor);
3440 -- For an ancestor part given by an unconstrained type mark,
3441 -- create a subtype constrained by appropriate corresponding
3442 -- discriminant values coming from either associations of the
3443 -- aggregate or a constraint on a parent type. The subtype will
3444 -- be used to generate the correct default value for the
3447 elsif Has_Discriminants (Entity (Ancestor)) then
3449 Anc_Typ : constant Entity_Id := Entity (Ancestor);
3450 Anc_Constr : constant List_Id := New_List;
3451 Discrim : Entity_Id;
3452 Disc_Value : Node_Id;
3453 New_Indic : Node_Id;
3454 Subt_Decl : Node_Id;
3457 Discrim := First_Discriminant (Anc_Typ);
3458 while Present (Discrim) loop
3459 Disc_Value := Ancestor_Discriminant_Value (Discrim);
3461 -- If no usable discriminant in ancestors, check
3462 -- whether aggregate has an explicit value for it.
3464 if No (Disc_Value) then
3466 Get_Explicit_Discriminant_Value (Discrim);
3469 Append_To (Anc_Constr, Disc_Value);
3470 Next_Discriminant (Discrim);
3474 Make_Subtype_Indication (Loc,
3475 Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc),
3477 Make_Index_Or_Discriminant_Constraint (Loc,
3478 Constraints => Anc_Constr));
3480 Init_Typ := Create_Itype (Ekind (Anc_Typ), N);
3483 Make_Subtype_Declaration (Loc,
3484 Defining_Identifier => Init_Typ,
3485 Subtype_Indication => New_Indic);
3487 -- Itypes must be analyzed with checks off Declaration
3488 -- must have a parent for proper handling of subsidiary
3491 Set_Parent (Subt_Decl, N);
3492 Analyze (Subt_Decl, Suppress => All_Checks);
3496 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
3497 Set_Assignment_OK (Ref);
3499 if not Is_Interface (Init_Typ) then
3501 Build_Initialization_Call (Loc,
3504 In_Init_Proc => Within_Init_Proc,
3505 With_Default_Init => Has_Default_Init_Comps (N)
3507 Has_Task (Base_Type (Init_Typ))));
3509 if Is_Constrained (Entity (Ancestor))
3510 and then Has_Discriminants (Entity (Ancestor))
3512 Check_Ancestor_Discriminants (Entity (Ancestor));
3515 -- If ancestor type has Default_Initialization_Condition,
3516 -- add a DIC check after the ancestor object is initialized
3519 if Has_DIC (Entity (Ancestor))
3520 and then Present (DIC_Procedure (Entity (Ancestor)))
3524 (Loc, New_Copy_Tree (Ref), Entity (Ancestor)));
3528 -- Handle calls to C++ constructors
3530 elsif Is_CPP_Constructor_Call (Ancestor) then
3531 Init_Typ := Etype (Ancestor);
3532 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
3533 Set_Assignment_OK (Ref);
3536 Build_Initialization_Call (Loc,
3539 In_Init_Proc => Within_Init_Proc,
3540 With_Default_Init => Has_Default_Init_Comps (N),
3541 Constructor_Ref => Ancestor));
3543 -- Ada 2005 (AI-287): If the ancestor part is an aggregate of
3544 -- limited type, a recursive call expands the ancestor. Note that
3545 -- in the limited case, the ancestor part must be either a
3546 -- function call (possibly qualified) or aggregate (definitely
3549 elsif Is_Limited_Type (Etype (Ancestor))
3550 and then Nkind (Unqualify (Ancestor)) in
3551 N_Aggregate | N_Extension_Aggregate
3553 Ancestor_Is_Expression := True;
3555 -- Set up finalization data for enclosing record, because
3556 -- controlled subcomponents of the ancestor part will be
3559 Generate_Finalization_Actions;
3562 Build_Record_Aggr_Code
3563 (N => Unqualify (Ancestor),
3564 Typ => Etype (Unqualify (Ancestor)),
3567 -- If the ancestor part is an expression "E", we generate
3571 -- In Ada 2005, this includes the case of a (possibly qualified)
3572 -- limited function call. The assignment will turn into a
3573 -- build-in-place function call (for further details, see
3574 -- Make_Build_In_Place_Call_In_Assignment).
3577 Ancestor_Is_Expression := True;
3578 Init_Typ := Etype (Ancestor);
3580 -- If the ancestor part is an aggregate, force its full
3581 -- expansion, which was delayed.
3583 if Nkind (Unqualify (Ancestor)) in
3584 N_Aggregate | N_Extension_Aggregate
3586 Set_Analyzed (Ancestor, False);
3587 Set_Analyzed (Expression (Ancestor), False);
3590 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
3591 Set_Assignment_OK (Ref);
3593 -- Make the assignment without usual controlled actions, since
3594 -- we only want to Adjust afterwards, but not to Finalize
3595 -- beforehand. Add manual Adjust when necessary.
3597 Assign := New_List (
3598 Make_OK_Assignment_Statement (Loc,
3600 Expression => Ancestor));
3601 Set_No_Ctrl_Actions (First (Assign));
3603 -- Assign the tag now to make sure that the dispatching call in
3604 -- the subsequent deep_adjust works properly (unless
3605 -- Tagged_Type_Expansion where tags are implicit).
3607 if Tagged_Type_Expansion then
3609 Make_OK_Assignment_Statement (Loc,
3611 Make_Selected_Component (Loc,
3612 Prefix => New_Copy_Tree (Target),
3615 (First_Tag_Component (Base_Type (Typ)), Loc)),
3618 Unchecked_Convert_To (RTE (RE_Tag),
3621 (Access_Disp_Table (Base_Type (Typ)))),
3624 Set_Assignment_OK (Name (Instr));
3625 Append_To (Assign, Instr);
3627 -- Ada 2005 (AI-251): If tagged type has progenitors we must
3628 -- also initialize tags of the secondary dispatch tables.
3630 if Has_Interfaces (Base_Type (Typ)) then
3632 (Typ => Base_Type (Typ),
3634 Stmts_List => Assign,
3635 Init_Tags_List => Assign);
3639 -- Call Adjust manually
3641 if Needs_Finalization (Etype (Ancestor))
3642 and then not Is_Limited_Type (Etype (Ancestor))
3643 and then not Is_Build_In_Place_Function_Call (Ancestor)
3647 (Obj_Ref => New_Copy_Tree (Ref),
3648 Typ => Etype (Ancestor));
3650 -- Guard against a missing [Deep_]Adjust when the ancestor
3651 -- type was not properly frozen.
3653 if Present (Adj_Call) then
3654 Append_To (Assign, Adj_Call);
3659 Make_Unsuppress_Block (Loc, Name_Discriminant_Check, Assign));
3661 if Has_Discriminants (Init_Typ) then
3662 Check_Ancestor_Discriminants (Init_Typ);
3666 pragma Assert (Nkind (N) = N_Extension_Aggregate);
3668 (not (Ancestor_Is_Expression and Ancestor_Is_Subtype_Mark));
3671 -- Generate assignments of hidden discriminants. If the base type is
3672 -- an unchecked union, the discriminants are unknown to the back-end
3673 -- and absent from a value of the type, so assignments for them are
3676 if Has_Discriminants (Typ)
3677 and then not Is_Unchecked_Union (Base_Type (Typ))
3679 Init_Hidden_Discriminants (Typ, L);
3682 -- Normal case (not an extension aggregate)
3685 -- Generate the discriminant expressions, component by component.
3686 -- If the base type is an unchecked union, the discriminants are
3687 -- unknown to the back-end and absent from a value of the type, so
3688 -- assignments for them are not emitted.
3690 if Has_Discriminants (Typ)
3691 and then not Is_Unchecked_Union (Base_Type (Typ))
3693 Init_Hidden_Discriminants (Typ, L);
3695 -- Generate discriminant init values for the visible discriminants
3697 Init_Visible_Discriminants;
3699 if Is_Derived_Type (N_Typ) then
3700 Init_Stored_Discriminants;
3705 -- For CPP types we generate an implicit call to the C++ default
3706 -- constructor to ensure the proper initialization of the _Tag
3709 if Is_CPP_Class (Root_Type (Typ)) and then CPP_Num_Prims (Typ) > 0 then
3710 Invoke_Constructor : declare
3711 CPP_Parent : constant Entity_Id := Enclosing_CPP_Parent (Typ);
3713 procedure Invoke_IC_Proc (T : Entity_Id);
3714 -- Recursive routine used to climb to parents. Required because
3715 -- parents must be initialized before descendants to ensure
3716 -- propagation of inherited C++ slots.
3718 --------------------
3719 -- Invoke_IC_Proc --
3720 --------------------
3722 procedure Invoke_IC_Proc (T : Entity_Id) is
3724 -- Avoid generating extra calls. Initialization required
3725 -- only for types defined from the level of derivation of
3726 -- type of the constructor and the type of the aggregate.
3728 if T = CPP_Parent then
3732 Invoke_IC_Proc (Etype (T));
3734 -- Generate call to the IC routine
3736 if Present (CPP_Init_Proc (T)) then
3738 Make_Procedure_Call_Statement (Loc,
3739 Name => New_Occurrence_Of (CPP_Init_Proc (T), Loc)));
3743 -- Start of processing for Invoke_Constructor
3746 -- Implicit invocation of the C++ constructor
3748 if Nkind (N) = N_Aggregate then
3750 Make_Procedure_Call_Statement (Loc,
3752 New_Occurrence_Of (Base_Init_Proc (CPP_Parent), Loc),
3753 Parameter_Associations => New_List (
3754 Unchecked_Convert_To (CPP_Parent,
3755 New_Copy_Tree (Lhs)))));
3758 Invoke_IC_Proc (Typ);
3759 end Invoke_Constructor;
3762 -- Generate the assignments, component by component
3764 -- tmp.comp1 := Expr1_From_Aggr;
3765 -- tmp.comp2 := Expr2_From_Aggr;
3768 Comp := First (Component_Associations (N));
3769 while Present (Comp) loop
3770 Selector := Entity (First (Choices (Comp)));
3774 if Is_CPP_Constructor_Call (Expression (Comp)) then
3776 Build_Initialization_Call (Loc,
3778 Make_Selected_Component (Loc,
3779 Prefix => New_Copy_Tree (Target),
3780 Selector_Name => New_Occurrence_Of (Selector, Loc)),
3781 Typ => Etype (Selector),
3783 With_Default_Init => True,
3784 Constructor_Ref => Expression (Comp)));
3786 -- Ada 2005 (AI-287): For each default-initialized component generate
3787 -- a call to the corresponding IP subprogram if available.
3789 elsif Box_Present (Comp)
3790 and then Has_Non_Null_Base_Init_Proc (Etype (Selector))
3792 if Ekind (Selector) /= E_Discriminant then
3793 Generate_Finalization_Actions;
3796 -- Ada 2005 (AI-287): If the component type has tasks then
3797 -- generate the activation chain and master entities (except
3798 -- in case of an allocator because in that case these entities
3799 -- are generated by Build_Task_Allocate_Block_With_Init_Stmts).
3802 Ctype : constant Entity_Id := Etype (Selector);
3803 Inside_Allocator : Boolean := False;
3804 P : Node_Id := Parent (N);
3807 if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
3808 while Present (P) loop
3809 if Nkind (P) = N_Allocator then
3810 Inside_Allocator := True;
3817 if not Inside_Init_Proc and not Inside_Allocator then
3818 Build_Activation_Chain_Entity (N);
3824 Build_Initialization_Call (Loc,
3825 Id_Ref => Make_Selected_Component (Loc,
3826 Prefix => New_Copy_Tree (Target),
3828 New_Occurrence_Of (Selector, Loc)),
3829 Typ => Etype (Selector),
3831 With_Default_Init => True));
3833 -- Prepare for component assignment
3835 elsif Ekind (Selector) /= E_Discriminant
3836 or else Nkind (N) = N_Extension_Aggregate
3838 -- All the discriminants have now been assigned
3840 -- This is now a good moment to initialize and attach all the
3841 -- controllers. Their position may depend on the discriminants.
3843 if Ekind (Selector) /= E_Discriminant then
3844 Generate_Finalization_Actions;
3847 Comp_Type := Underlying_Type (Etype (Selector));
3849 Make_Selected_Component (Loc,
3850 Prefix => New_Copy_Tree (Target),
3851 Selector_Name => New_Occurrence_Of (Selector, Loc));
3853 if Nkind (Expression (Comp)) = N_Qualified_Expression then
3854 Expr_Q := Expression (Expression (Comp));
3856 Expr_Q := Expression (Comp);
3859 -- Now either create the assignment or generate the code for the
3860 -- inner aggregate top-down.
3862 if Is_Delayed_Aggregate (Expr_Q) then
3864 -- We have the following case of aggregate nesting inside
3865 -- an object declaration:
3867 -- type Arr_Typ is array (Integer range <>) of ...;
3869 -- type Rec_Typ (...) is record
3870 -- Obj_Arr_Typ : Arr_Typ (A .. B);
3873 -- Obj_Rec_Typ : Rec_Typ := (...,
3874 -- Obj_Arr_Typ => (X => (...), Y => (...)));
3876 -- The length of the ranges of the aggregate and Obj_Add_Typ
3877 -- are equal (B - A = Y - X), but they do not coincide (X /=
3878 -- A and B /= Y). This case requires array sliding which is
3879 -- performed in the following manner:
3881 -- subtype Arr_Sub is Arr_Typ (X .. Y);
3883 -- Temp (X) := (...);
3885 -- Temp (Y) := (...);
3886 -- Obj_Rec_Typ.Obj_Arr_Typ := Temp;
3888 if Ekind (Comp_Type) = E_Array_Subtype
3889 and then Is_Int_Range_Bounds (Aggregate_Bounds (Expr_Q))
3890 and then Is_Int_Range_Bounds (First_Index (Comp_Type))
3892 Compatible_Int_Bounds
3893 (Agg_Bounds => Aggregate_Bounds (Expr_Q),
3894 Typ_Bounds => First_Index (Comp_Type))
3896 -- Create the array subtype with bounds equal to those of
3897 -- the corresponding aggregate.
3900 SubE : constant Entity_Id := Make_Temporary (Loc, 'T');
3902 SubD : constant Node_Id :=
3903 Make_Subtype_Declaration (Loc,
3904 Defining_Identifier => SubE,
3905 Subtype_Indication =>
3906 Make_Subtype_Indication (Loc,
3908 New_Occurrence_Of (Etype (Comp_Type), Loc),
3910 Make_Index_Or_Discriminant_Constraint
3912 Constraints => New_List (
3914 (Aggregate_Bounds (Expr_Q))))));
3916 -- Create a temporary array of the above subtype which
3917 -- will be used to capture the aggregate assignments.
3919 TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N);
3921 TmpD : constant Node_Id :=
3922 Make_Object_Declaration (Loc,
3923 Defining_Identifier => TmpE,
3924 Object_Definition => New_Occurrence_Of (SubE, Loc));
3927 Set_No_Initialization (TmpD);
3928 Append_To (L, SubD);
3929 Append_To (L, TmpD);
3931 -- Expand aggregate into assignments to the temp array
3934 Late_Expansion (Expr_Q, Comp_Type,
3935 New_Occurrence_Of (TmpE, Loc)));
3940 Make_Assignment_Statement (Loc,
3941 Name => New_Copy_Tree (Comp_Expr),
3942 Expression => New_Occurrence_Of (TmpE, Loc)));
3945 -- Normal case (sliding not required)
3949 Late_Expansion (Expr_Q, Comp_Type, Comp_Expr));
3952 -- Expr_Q is not delayed aggregate
3955 if Has_Discriminants (Typ) then
3956 Replace_Discriminants (Expr_Q);
3958 -- If the component is an array type that depends on
3959 -- discriminants, and the expression is a single Others
3960 -- clause, create an explicit subtype for it because the
3961 -- backend has troubles recovering the actual bounds.
3963 if Nkind (Expr_Q) = N_Aggregate
3964 and then Is_Array_Type (Comp_Type)
3965 and then Present (Component_Associations (Expr_Q))
3968 Assoc : constant Node_Id :=
3969 First (Component_Associations (Expr_Q));
3973 if Nkind (First (Choices (Assoc))) = N_Others_Choice
3976 Build_Actual_Subtype_Of_Component
3977 (Comp_Type, Comp_Expr);
3979 -- If the component type does not in fact depend on
3980 -- discriminants, the subtype declaration is empty.
3982 if Present (Decl) then
3983 Append_To (L, Decl);
3984 Set_Etype (Comp_Expr, Defining_Entity (Decl));
3991 if Modify_Tree_For_C
3992 and then Nkind (Expr_Q) = N_Aggregate
3993 and then Is_Array_Type (Etype (Expr_Q))
3994 and then Present (First_Index (Etype (Expr_Q)))
3997 Expr_Q_Type : constant Node_Id := Etype (Expr_Q);
4000 Build_Array_Aggr_Code
4002 Ctype => Component_Type (Expr_Q_Type),
4003 Index => First_Index (Expr_Q_Type),
4006 Is_Scalar_Type (Component_Type (Expr_Q_Type))));
4010 -- Handle an initialization expression of a controlled type
4011 -- in case it denotes a function call. In general such a
4012 -- scenario will produce a transient scope, but this will
4013 -- lead to wrong order of initialization, adjustment, and
4014 -- finalization in the context of aggregates.
4016 -- Target.Comp := Ctrl_Func_Call;
4019 -- Trans_Obj : ... := Ctrl_Func_Call; -- object
4020 -- Target.Comp := Trans_Obj;
4021 -- Finalize (Trans_Obj);
4023 -- Target.Comp._tag := ...;
4024 -- Adjust (Target.Comp);
4026 -- In the example above, the call to Finalize occurs too
4027 -- early and as a result it may leave the record component
4028 -- in a bad state. Finalization of the transient object
4029 -- should really happen after adjustment.
4031 -- To avoid this scenario, perform in-place side-effect
4032 -- removal of the function call. This eliminates the
4033 -- transient property of the function result and ensures
4034 -- correct order of actions.
4036 -- Res : ... := Ctrl_Func_Call;
4037 -- Target.Comp := Res;
4038 -- Target.Comp._tag := ...;
4039 -- Adjust (Target.Comp);
4042 if Needs_Finalization (Comp_Type)
4043 and then Nkind (Expr_Q) /= N_Aggregate
4045 Initialize_Ctrl_Record_Component
4046 (Rec_Comp => Comp_Expr,
4047 Comp_Typ => Etype (Selector),
4048 Init_Expr => Expr_Q,
4051 -- Otherwise perform single component initialization
4054 Initialize_Record_Component
4055 (Rec_Comp => Comp_Expr,
4056 Comp_Typ => Etype (Selector),
4057 Init_Expr => Expr_Q,
4063 -- comment would be good here ???
4065 elsif Ekind (Selector) = E_Discriminant
4066 and then Nkind (N) /= N_Extension_Aggregate
4067 and then Nkind (Parent (N)) = N_Component_Association
4068 and then Is_Constrained (Typ)
4070 -- We must check that the discriminant value imposed by the
4071 -- context is the same as the value given in the subaggregate,
4072 -- because after the expansion into assignments there is no
4073 -- record on which to perform a regular discriminant check.
4080 D_Val := First_Elmt (Discriminant_Constraint (Typ));
4081 Disc := First_Discriminant (Typ);
4082 while Chars (Disc) /= Chars (Selector) loop
4083 Next_Discriminant (Disc);
4087 pragma Assert (Present (D_Val));
4089 -- This check cannot performed for components that are
4090 -- constrained by a current instance, because this is not a
4091 -- value that can be compared with the actual constraint.
4093 if Nkind (Node (D_Val)) /= N_Attribute_Reference
4094 or else not Is_Entity_Name (Prefix (Node (D_Val)))
4095 or else not Is_Type (Entity (Prefix (Node (D_Val))))
4098 Make_Raise_Constraint_Error (Loc,
4101 Left_Opnd => New_Copy_Tree (Node (D_Val)),
4102 Right_Opnd => Expression (Comp)),
4103 Reason => CE_Discriminant_Check_Failed));
4106 -- Find self-reference in previous discriminant assignment,
4107 -- and replace with proper expression.
4114 while Present (Ass) loop
4115 if Nkind (Ass) = N_Assignment_Statement
4116 and then Nkind (Name (Ass)) = N_Selected_Component
4117 and then Chars (Selector_Name (Name (Ass))) =
4121 (Ass, New_Copy_Tree (Expression (Comp)));
4131 -- If the component association was specified with a box and the
4132 -- component type has a Default_Initial_Condition, then generate
4133 -- a call to the DIC procedure.
4135 if Has_DIC (Etype (Selector))
4136 and then Was_Default_Init_Box_Association (Comp)
4137 and then Present (DIC_Procedure (Etype (Selector)))
4140 Build_DIC_Call (Loc,
4141 Make_Selected_Component (Loc,
4142 Prefix => New_Copy_Tree (Target),
4143 Selector_Name => New_Occurrence_Of (Selector, Loc)),
4150 -- If the type is tagged, the tag needs to be initialized (unless we
4151 -- are in VM-mode where tags are implicit). It is done late in the
4152 -- initialization process because in some cases, we call the init
4153 -- proc of an ancestor which will not leave out the right tag.
4155 if Ancestor_Is_Expression then
4158 -- For CPP types we generated a call to the C++ default constructor
4159 -- before the components have been initialized to ensure the proper
4160 -- initialization of the _Tag component (see above).
4162 elsif Is_CPP_Class (Typ) then
4165 elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
4167 Make_OK_Assignment_Statement (Loc,
4169 Make_Selected_Component (Loc,
4170 Prefix => New_Copy_Tree (Target),
4173 (First_Tag_Component (Base_Type (Typ)), Loc)),
4176 Unchecked_Convert_To (RTE (RE_Tag),
4178 (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))),
4181 Append_To (L, Instr);
4183 -- Ada 2005 (AI-251): If the tagged type has been derived from an
4184 -- abstract interfaces we must also initialize the tags of the
4185 -- secondary dispatch tables.
4187 if Has_Interfaces (Base_Type (Typ)) then
4189 (Typ => Base_Type (Typ),
4192 Init_Tags_List => L);
4196 -- If the controllers have not been initialized yet (by lack of non-
4197 -- discriminant components), let's do it now.
4199 Generate_Finalization_Actions;
4202 end Build_Record_Aggr_Code;
4204 -------------------------------
4205 -- Convert_Aggr_In_Allocator --
4206 -------------------------------
4208 procedure Convert_Aggr_In_Allocator
4213 Loc : constant Source_Ptr := Sloc (Aggr);
4214 Typ : constant Entity_Id := Etype (Aggr);
4215 Temp : constant Entity_Id := Defining_Identifier (Decl);
4217 Occ : constant Node_Id :=
4218 Unchecked_Convert_To (Typ,
4219 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Temp, Loc)));
4222 if Is_Array_Type (Typ) then
4223 Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ);
4225 elsif Has_Default_Init_Comps (Aggr) then
4227 L : constant List_Id := New_List;
4228 Init_Stmts : List_Id;
4231 Init_Stmts := Late_Expansion (Aggr, Typ, Occ);
4233 if Has_Task (Typ) then
4234 Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
4235 Insert_Actions (Alloc, L);
4237 Insert_Actions (Alloc, Init_Stmts);
4242 Insert_Actions (Alloc, Late_Expansion (Aggr, Typ, Occ));
4244 end Convert_Aggr_In_Allocator;
4246 --------------------------------
4247 -- Convert_Aggr_In_Assignment --
4248 --------------------------------
4250 procedure Convert_Aggr_In_Assignment (N : Node_Id) is
4251 Aggr : Node_Id := Expression (N);
4252 Typ : constant Entity_Id := Etype (Aggr);
4253 Occ : constant Node_Id := New_Copy_Tree (Name (N));
4256 if Nkind (Aggr) = N_Qualified_Expression then
4257 Aggr := Expression (Aggr);
4260 Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
4261 end Convert_Aggr_In_Assignment;
4263 ---------------------------------
4264 -- Convert_Aggr_In_Object_Decl --
4265 ---------------------------------
4267 procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is
4268 Obj : constant Entity_Id := Defining_Identifier (N);
4269 Aggr : Node_Id := Expression (N);
4270 Loc : constant Source_Ptr := Sloc (Aggr);
4271 Typ : constant Entity_Id := Etype (Aggr);
4272 Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
4274 Has_Transient_Scope : Boolean := False;
4276 function Discriminants_Ok return Boolean;
4277 -- If the object type is constrained, the discriminants in the
4278 -- aggregate must be checked against the discriminants of the subtype.
4279 -- This cannot be done using Apply_Discriminant_Checks because after
4280 -- expansion there is no aggregate left to check.
4282 ----------------------
4283 -- Discriminants_Ok --
4284 ----------------------
4286 function Discriminants_Ok return Boolean is
4287 Cond : Node_Id := Empty;
4296 D := First_Discriminant (Typ);
4297 Disc1 := First_Elmt (Discriminant_Constraint (Typ));
4298 Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj)));
4299 while Present (Disc1) and then Present (Disc2) loop
4300 Val1 := Node (Disc1);
4301 Val2 := Node (Disc2);
4303 if not Is_OK_Static_Expression (Val1)
4304 or else not Is_OK_Static_Expression (Val2)
4306 Check := Make_Op_Ne (Loc,
4307 Left_Opnd => Duplicate_Subexpr (Val1),
4308 Right_Opnd => Duplicate_Subexpr (Val2));
4314 Cond := Make_Or_Else (Loc,
4316 Right_Opnd => Check);
4319 elsif Expr_Value (Val1) /= Expr_Value (Val2) then
4320 Apply_Compile_Time_Constraint_Error (Aggr,
4321 Msg => "incorrect value for discriminant&??",
4322 Reason => CE_Discriminant_Check_Failed,
4327 Next_Discriminant (D);
4332 -- If any discriminant constraint is nonstatic, emit a check
4334 if Present (Cond) then
4336 Make_Raise_Constraint_Error (Loc,
4338 Reason => CE_Discriminant_Check_Failed));
4342 end Discriminants_Ok;
4344 -- Start of processing for Convert_Aggr_In_Object_Decl
4347 Set_Assignment_OK (Occ);
4349 if Nkind (Aggr) = N_Qualified_Expression then
4350 Aggr := Expression (Aggr);
4353 if Has_Discriminants (Typ)
4354 and then Typ /= Etype (Obj)
4355 and then Is_Constrained (Etype (Obj))
4356 and then not Discriminants_Ok
4361 -- If the context is an extended return statement, it has its own
4362 -- finalization machinery (i.e. works like a transient scope) and
4363 -- we do not want to create an additional one, because objects on
4364 -- the finalization list of the return must be moved to the caller's
4365 -- finalization list to complete the return.
4367 -- Similarly if the aggregate is limited, it is built in place, and the
4368 -- controlled components are not assigned to intermediate temporaries
4369 -- so there is no need for a transient scope in this case either.
4371 if Requires_Transient_Scope (Typ)
4372 and then Ekind (Current_Scope) /= E_Return_Statement
4373 and then not Is_Limited_Type (Typ)
4375 Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False);
4376 Has_Transient_Scope := True;
4380 Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ);
4385 -- If Obj is already frozen or if N is wrapped in a transient scope,
4386 -- Stmts do not need to be saved in Initialization_Statements since
4387 -- there is no freezing issue.
4389 if Is_Frozen (Obj) or else Has_Transient_Scope then
4390 Insert_Actions_After (N, Stmts);
4392 Stmt := Make_Compound_Statement (Sloc (N), Actions => Stmts);
4393 Insert_Action_After (N, Stmt);
4395 -- Insert_Action_After may freeze Obj in which case we should
4396 -- remove the compound statement just created and simply insert
4399 if Is_Frozen (Obj) then
4401 Insert_Actions_After (N, Stmts);
4403 Set_Initialization_Statements (Obj, Stmt);
4407 -- If Typ has controlled components and a call to a Slice_Assign
4408 -- procedure is part of the initialization statements, then we
4409 -- need to initialize the array component since Slice_Assign will
4410 -- need to adjust it.
4412 if Has_Controlled_Component (Typ) then
4413 Stmt := First (Stmts);
4415 while Present (Stmt) loop
4416 if Nkind (Stmt) = N_Procedure_Call_Statement
4417 and then Get_TSS_Name (Entity (Name (Stmt)))
4420 Param := First (Parameter_Associations (Stmt));
4423 Build_Initialization_Call
4424 (Sloc (N), New_Copy_Tree (Param), Etype (Param)));
4432 Set_No_Initialization (N);
4433 Initialize_Discriminants (N, Typ);
4434 end Convert_Aggr_In_Object_Decl;
4436 -------------------------------------
4437 -- Convert_Array_Aggr_In_Allocator --
4438 -------------------------------------
4440 procedure Convert_Array_Aggr_In_Allocator
4445 Typ : constant Entity_Id := Etype (Aggr);
4446 Ctyp : constant Entity_Id := Component_Type (Typ);
4447 Aggr_Code : List_Id;
4451 -- The target is an explicit dereference of the allocated object
4453 -- If the assignment can be done directly by the back end, then
4454 -- reset Set_Expansion_Delayed and do not expand further.
4456 if not CodePeer_Mode
4457 and then not Modify_Tree_For_C
4458 and then Aggr_Assignment_OK_For_Backend (Aggr)
4460 New_Aggr := New_Copy_Tree (Aggr);
4461 Set_Expansion_Delayed (New_Aggr, False);
4465 Make_OK_Assignment_Statement (Sloc (New_Aggr),
4467 Expression => New_Aggr));
4469 -- Or else, generate component assignments to it, as for an aggregate
4470 -- that appears on the right-hand side of an assignment statement.
4474 Build_Array_Aggr_Code (Aggr,
4476 Index => First_Index (Typ),
4478 Scalar_Comp => Is_Scalar_Type (Ctyp));
4481 Insert_Actions_After (Decl, Aggr_Code);
4482 end Convert_Array_Aggr_In_Allocator;
4484 ------------------------
4485 -- In_Place_Assign_OK --
4486 ------------------------
4488 function In_Place_Assign_OK
4490 Target_Object : Entity_Id := Empty) return Boolean
4492 Is_Array : constant Boolean := Is_Array_Type (Etype (N));
4500 Parent_Kind : Node_Kind;
4501 Parent_Node : Node_Id;
4503 function Safe_Aggregate (Aggr : Node_Id) return Boolean;
4504 -- Check recursively that each component of a (sub)aggregate does not
4505 -- depend on the variable being assigned to.
4507 function Safe_Component (Expr : Node_Id) return Boolean;
4508 -- Verify that an expression cannot depend on the target being assigned
4509 -- to. Return true for compile-time known values, stand-alone objects,
4510 -- parameters passed by copy, calls to functions that return by copy,
4511 -- selected components thereof only if the aggregate's type is an array,
4512 -- indexed components and slices thereof only if the aggregate's type is
4513 -- a record, and simple expressions involving only these as operands.
4514 -- This is OK whatever the target because, for a component to overlap
4515 -- with the target, it must be either a direct reference to a component
4516 -- of the target, in which case there must be a matching selection or
4517 -- indexation or slicing, or an indirect reference to such a component,
4518 -- which is excluded by the above condition. Additionally, if the target
4519 -- is statically known, return true for arbitrarily nested selections,
4520 -- indexations or slicings, provided that their ultimate prefix is not
4521 -- the target itself.
4523 --------------------
4524 -- Safe_Aggregate --
4525 --------------------
4527 function Safe_Aggregate (Aggr : Node_Id) return Boolean is
4531 if Nkind (Parent (Aggr)) = N_Iterated_Component_Association then
4535 if Present (Expressions (Aggr)) then
4536 Expr := First (Expressions (Aggr));
4537 while Present (Expr) loop
4538 if Nkind (Expr) = N_Aggregate then
4539 if not Safe_Aggregate (Expr) then
4543 elsif not Safe_Component (Expr) then
4551 if Present (Component_Associations (Aggr)) then
4552 Expr := First (Component_Associations (Aggr));
4553 while Present (Expr) loop
4554 if Nkind (Expression (Expr)) = N_Aggregate then
4555 if not Safe_Aggregate (Expression (Expr)) then
4559 -- If association has a box, no way to determine yet whether
4560 -- default can be assigned in place.
4562 elsif Box_Present (Expr) then
4565 elsif not Safe_Component (Expression (Expr)) then
4576 --------------------
4577 -- Safe_Component --
4578 --------------------
4580 function Safe_Component (Expr : Node_Id) return Boolean is
4581 Comp : Node_Id := Expr;
4583 function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean;
4584 -- Do the recursive traversal, after copy. If T_OK is True, return
4585 -- True for a stand-alone object only if the target is statically
4586 -- known and distinct from the object. At the top level, we start
4587 -- with T_OK set to False and set it to True at a deeper level only
4588 -- if we cannot disambiguate the component here without statically
4589 -- knowing the target. Note that this is not optimal, we should do
4590 -- something along the lines of Denotes_Same_Prefix for that.
4592 ---------------------
4593 -- Check_Component --
4594 ---------------------
4596 function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean
4599 function SDO (E : Entity_Id) return Uint;
4600 -- Return the Scope Depth Of the enclosing dynamic scope of E
4606 function SDO (E : Entity_Id) return Uint is
4608 return Scope_Depth (Enclosing_Dynamic_Scope (E));
4611 -- Start of processing for Check_Component
4614 if Is_Overloaded (C) then
4617 elsif Compile_Time_Known_Value (C) then
4622 when N_Attribute_Reference =>
4623 return Check_Component (Prefix (C), T_OK);
4625 when N_Function_Call =>
4626 if Nkind (Name (C)) = N_Explicit_Dereference then
4627 return not Returns_By_Ref (Etype (Name (C)));
4629 return not Returns_By_Ref (Entity (Name (C)));
4632 when N_Indexed_Component | N_Slice =>
4633 -- In a target record, these operations cannot determine
4634 -- alone a component so we can recurse whatever the target.
4635 return Check_Component (Prefix (C), T_OK or else Is_Array);
4637 when N_Selected_Component =>
4638 -- In a target array, this operation cannot determine alone
4639 -- a component so we can recurse whatever the target.
4641 Check_Component (Prefix (C), T_OK or else not Is_Array);
4643 when N_Type_Conversion | N_Unchecked_Type_Conversion =>
4644 return Check_Component (Expression (C), T_OK);
4647 return Check_Component (Left_Opnd (C), T_OK)
4648 and then Check_Component (Right_Opnd (C), T_OK);
4651 return Check_Component (Right_Opnd (C), T_OK);
4654 if Is_Entity_Name (C) and then Is_Object (Entity (C)) then
4655 -- Case of a formal parameter component. It's either
4656 -- trivial if passed by copy or very annoying if not,
4657 -- because in the latter case it's almost equivalent
4658 -- to a dereference, so the path-based disambiguation
4659 -- logic is totally off and we always need the target.
4661 if Is_Formal (Entity (C)) then
4663 -- If it is passed by copy, then this is safe
4665 if Mechanism (Entity (C)) = By_Copy then
4668 -- Otherwise, this is safe if the target is present
4669 -- and is at least as deeply nested as the component.
4672 return Present (Target_Object)
4673 and then not Is_Formal (Target_Object)
4674 and then SDO (Target_Object) >= SDO (Entity (C));
4677 -- For a renamed object, recurse
4679 elsif Present (Renamed_Object (Entity (C))) then
4681 Check_Component (Renamed_Object (Entity (C)), T_OK);
4683 -- If this is safe whatever the target, we are done
4688 -- If there is no target or the component is the target,
4689 -- this is not safe.
4691 elsif No (Target_Object)
4692 or else Entity (C) = Target_Object
4696 -- Case of a formal parameter target. This is safe if it
4697 -- is at most as deeply nested as the component.
4699 elsif Is_Formal (Target_Object) then
4700 return SDO (Target_Object) <= SDO (Entity (C));
4702 -- For distinct stand-alone objects, this is safe
4708 -- For anything else than an object, this is not safe
4714 end Check_Component;
4716 -- Start of processing for Safe_Component
4719 -- If the component appears in an association that may correspond
4720 -- to more than one element, it is not analyzed before expansion
4721 -- into assignments, to avoid side effects. We analyze, but do not
4722 -- resolve the copy, to obtain sufficient entity information for
4723 -- the checks that follow. If component is overloaded we assume
4724 -- an unsafe function call.
4726 if not Analyzed (Comp) then
4727 if Is_Overloaded (Expr) then
4730 elsif Nkind (Expr) = N_Allocator then
4732 -- For now, too complex to analyze
4736 elsif Nkind (Parent (Expr)) = N_Iterated_Component_Association then
4738 -- Ditto for iterated component associations, which in general
4739 -- require an enclosing loop and involve nonstatic expressions.
4744 Comp := New_Copy_Tree (Expr);
4745 Set_Parent (Comp, Parent (Expr));
4749 if Nkind (Comp) = N_Aggregate then
4750 return Safe_Aggregate (Comp);
4752 return Check_Component (Comp, False);
4756 -- Start of processing for In_Place_Assign_OK
4759 -- By-copy semantic cannot be guaranteed for controlled objects
4761 if Needs_Finalization (Etype (N)) then
4765 Parent_Node := Parent (N);
4766 Parent_Kind := Nkind (Parent_Node);
4768 if Parent_Kind = N_Qualified_Expression then
4769 Parent_Node := Parent (Parent_Node);
4770 Parent_Kind := Nkind (Parent_Node);
4773 -- On assignment, sliding can take place, so we cannot do the
4774 -- assignment in place unless the bounds of the aggregate are
4775 -- statically equal to those of the target.
4777 -- If the aggregate is given by an others choice, the bounds are
4778 -- derived from the left-hand side, and the assignment is safe if
4779 -- the expression is.
4782 and then Present (Component_Associations (N))
4783 and then not Is_Others_Aggregate (N)
4785 Aggr_In := First_Index (Etype (N));
4787 -- Context is an assignment
4789 if Parent_Kind = N_Assignment_Statement then
4790 Obj_In := First_Index (Etype (Name (Parent_Node)));
4792 -- Context is an allocator. Check the bounds of the aggregate against
4793 -- those of the designated type, except in the case where the type is
4794 -- unconstrained (and then we can directly return true, see below).
4796 else pragma Assert (Parent_Kind = N_Allocator);
4798 Desig_Typ : constant Entity_Id :=
4799 Designated_Type (Etype (Parent_Node));
4801 if not Is_Constrained (Desig_Typ) then
4805 Obj_In := First_Index (Desig_Typ);
4809 while Present (Aggr_In) loop
4810 Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
4811 Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
4813 -- We require static bounds for the target and a static matching
4814 -- of low bound for the aggregate.
4816 if not Compile_Time_Known_Value (Obj_Lo)
4817 or else not Compile_Time_Known_Value (Obj_Hi)
4818 or else not Compile_Time_Known_Value (Aggr_Lo)
4819 or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
4823 -- For an assignment statement we require static matching of
4824 -- bounds. Ditto for an allocator whose qualified expression
4825 -- is a constrained type. If the expression in the allocator
4826 -- is an unconstrained array, we accept an upper bound that
4827 -- is not static, to allow for nonstatic expressions of the
4828 -- base type. Clearly there are further possibilities (with
4829 -- diminishing returns) for safely building arrays in place
4832 elsif Parent_Kind = N_Assignment_Statement
4833 or else Is_Constrained (Etype (Parent_Node))
4835 if not Compile_Time_Known_Value (Aggr_Hi)
4836 or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
4842 Next_Index (Aggr_In);
4843 Next_Index (Obj_In);
4847 -- Now check the component values themselves, except for an allocator
4848 -- for which the target is newly allocated memory.
4850 if Parent_Kind = N_Allocator then
4853 return Safe_Aggregate (N);
4855 end In_Place_Assign_OK;
4857 ----------------------------
4858 -- Convert_To_Assignments --
4859 ----------------------------
4861 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
4862 Loc : constant Source_Ptr := Sloc (N);
4866 Aggr_Code : List_Id;
4868 Target_Expr : Node_Id;
4869 Parent_Kind : Node_Kind;
4870 Unc_Decl : Boolean := False;
4871 Parent_Node : Node_Id;
4874 pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate);
4875 pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
4876 pragma Assert (Is_Record_Type (Typ));
4878 Parent_Node := Parent (N);
4879 Parent_Kind := Nkind (Parent_Node);
4881 if Parent_Kind = N_Qualified_Expression then
4882 -- Check if we are in an unconstrained declaration because in this
4883 -- case the current delayed expansion mechanism doesn't work when
4884 -- the declared object size depends on the initializing expr.
4886 Parent_Node := Parent (Parent_Node);
4887 Parent_Kind := Nkind (Parent_Node);
4889 if Parent_Kind = N_Object_Declaration then
4891 not Is_Entity_Name (Object_Definition (Parent_Node))
4892 or else (Nkind (N) = N_Aggregate
4895 (Entity (Object_Definition (Parent_Node))))
4896 or else Is_Class_Wide_Type
4897 (Entity (Object_Definition (Parent_Node)));
4901 -- Just set the Delay flag in the cases where the transformation will be
4902 -- done top down from above.
4906 -- Internal aggregate (transformed when expanding the parent)
4908 or else Parent_Kind = N_Aggregate
4909 or else Parent_Kind = N_Extension_Aggregate
4910 or else Parent_Kind = N_Component_Association
4912 -- Allocator (see Convert_Aggr_In_Allocator)
4914 or else Parent_Kind = N_Allocator
4916 -- Object declaration (see Convert_Aggr_In_Object_Decl)
4918 or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
4920 -- Safe assignment (see Convert_Aggr_Assignments). So far only the
4921 -- assignments in init procs are taken into account.
4923 or else (Parent_Kind = N_Assignment_Statement
4924 and then Inside_Init_Proc)
4926 -- (Ada 2005) An inherently limited type in a return statement, which
4927 -- will be handled in a build-in-place fashion, and may be rewritten
4928 -- as an extended return and have its own finalization machinery.
4929 -- In the case of a simple return, the aggregate needs to be delayed
4930 -- until the scope for the return statement has been created, so
4931 -- that any finalization chain will be associated with that scope.
4932 -- For extended returns, we delay expansion to avoid the creation
4933 -- of an unwanted transient scope that could result in premature
4934 -- finalization of the return object (which is built in place
4935 -- within the caller's scope).
4937 or else Is_Build_In_Place_Aggregate_Return (N)
4939 Set_Expansion_Delayed (N);
4943 -- Otherwise, if a transient scope is required, create it now. If we
4944 -- are within an initialization procedure do not create such, because
4945 -- the target of the assignment must not be declared within a local
4946 -- block, and because cleanup will take place on return from the
4947 -- initialization procedure.
4949 -- Should the condition be more restrictive ???
4951 if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then
4952 Establish_Transient_Scope (N, Manage_Sec_Stack => False);
4955 -- If the aggregate is nonlimited, create a temporary, since aggregates
4956 -- have "by copy" semantics. If it is limited and context is an
4957 -- assignment, this is a subaggregate for an enclosing aggregate being
4958 -- expanded. It must be built in place, so use target of the current
4961 if Is_Limited_Type (Typ)
4962 and then Parent_Kind = N_Assignment_Statement
4964 Target_Expr := New_Copy_Tree (Name (Parent_Node));
4965 Insert_Actions (Parent_Node,
4966 Build_Record_Aggr_Code (N, Typ, Target_Expr));
4967 Rewrite (Parent_Node, Make_Null_Statement (Loc));
4969 -- Do not declare a temporary to initialize an aggregate assigned to
4970 -- a target when in-place assignment is possible, i.e. preserving the
4971 -- by-copy semantic of aggregates. This avoids large stack usage and
4972 -- generates more efficient code.
4974 elsif Parent_Kind = N_Assignment_Statement
4975 and then In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)))
4978 Lhs : constant Node_Id := Name (Parent_Node);
4980 -- Apply discriminant check if required
4982 if Has_Discriminants (Etype (N)) then
4983 Apply_Discriminant_Check (N, Etype (Lhs), Lhs);
4986 -- The check just above may have replaced the aggregate with a CE
4988 if Nkind (N) in N_Aggregate | N_Extension_Aggregate then
4989 Target_Expr := New_Copy_Tree (Lhs);
4990 Insert_Actions (Parent_Node,
4991 Build_Record_Aggr_Code (N, Typ, Target_Expr));
4992 Rewrite (Parent_Node, Make_Null_Statement (Loc));
4997 Temp := Make_Temporary (Loc, 'A', N);
4999 -- If the type inherits unknown discriminants, use the view with
5000 -- known discriminants if available.
5002 if Has_Unknown_Discriminants (Typ)
5003 and then Present (Underlying_Record_View (Typ))
5005 T := Underlying_Record_View (Typ);
5011 Make_Object_Declaration (Loc,
5012 Defining_Identifier => Temp,
5013 Object_Definition => New_Occurrence_Of (T, Loc));
5015 Set_No_Initialization (Instr);
5016 Insert_Action (N, Instr);
5017 Initialize_Discriminants (Instr, T);
5019 Target_Expr := New_Occurrence_Of (Temp, Loc);
5020 Aggr_Code := Build_Record_Aggr_Code (N, T, Target_Expr);
5022 -- Save the last assignment statement associated with the aggregate
5023 -- when building a controlled object. This reference is utilized by
5024 -- the finalization machinery when marking an object as successfully
5027 if Needs_Finalization (T) then
5028 Set_Last_Aggregate_Assignment (Temp, Last (Aggr_Code));
5031 Insert_Actions (N, Aggr_Code);
5032 Rewrite (N, New_Occurrence_Of (Temp, Loc));
5033 Analyze_And_Resolve (N, T);
5035 end Convert_To_Assignments;
5037 ---------------------------
5038 -- Convert_To_Positional --
5039 ---------------------------
5041 procedure Convert_To_Positional
5043 Handle_Bit_Packed : Boolean := False)
5045 Typ : constant Entity_Id := Etype (N);
5046 Dims : constant Nat := Number_Dimensions (Typ);
5047 Max_Others_Replicate : constant Nat := Max_Aggregate_Size (N);
5049 Static_Components : Boolean := True;
5051 procedure Check_Static_Components;
5052 -- Check whether all components of the aggregate are compile-time known
5053 -- values, and can be passed as is to the back-end without further
5060 Ixb : Node_Id) return Boolean;
5061 -- Convert the aggregate into a purely positional form if possible after
5062 -- checking that the bounds of all dimensions are known to be static.
5064 function Is_Flat (N : Node_Id; Dims : Nat) return Boolean;
5065 -- Return True if the aggregate N is flat (which is not trivial in the
5066 -- case of multidimensional aggregates).
5068 function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean;
5069 -- Return True if N, an element of a component association list, i.e.
5070 -- N_Component_Association or N_Iterated_Component_Association, has a
5071 -- compile-time known value and can be passed as is to the back-end
5072 -- without further expansion.
5073 -- An Iterated_Component_Association is treated as nonstatic in most
5074 -- cases for now, so there are possibilities for optimization.
5076 -----------------------------
5077 -- Check_Static_Components --
5078 -----------------------------
5080 -- Could use some comments in this body ???
5082 procedure Check_Static_Components is
5087 Static_Components := True;
5089 if Nkind (N) = N_String_Literal then
5092 elsif Present (Expressions (N)) then
5093 Expr := First (Expressions (N));
5094 while Present (Expr) loop
5095 if Nkind (Expr) /= N_Aggregate
5096 or else not Compile_Time_Known_Aggregate (Expr)
5097 or else Expansion_Delayed (Expr)
5099 Static_Components := False;
5107 if Nkind (N) = N_Aggregate
5108 and then Present (Component_Associations (N))
5110 Assoc := First (Component_Associations (N));
5111 while Present (Assoc) loop
5112 if not Is_Static_Element (Assoc, Dims) then
5113 Static_Components := False;
5120 end Check_Static_Components;
5130 Ixb : Node_Id) return Boolean
5132 Loc : constant Source_Ptr := Sloc (N);
5133 Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb));
5134 Lo : constant Node_Id := Type_Low_Bound (Etype (Ix));
5135 Hi : constant Node_Id := Type_High_Bound (Etype (Ix));
5137 function Cannot_Flatten_Next_Aggr (Expr : Node_Id) return Boolean;
5138 -- Return true if Expr is an aggregate for the next dimension that
5139 -- cannot be recursively flattened.
5141 ------------------------------
5142 -- Cannot_Flatten_Next_Aggr --
5143 ------------------------------
5145 function Cannot_Flatten_Next_Aggr (Expr : Node_Id) return Boolean is
5147 return Nkind (Expr) = N_Aggregate
5148 and then Present (Next_Index (Ix))
5150 Flatten (Expr, Dims - 1, Next_Index (Ix), Next_Index (Ixb));
5151 end Cannot_Flatten_Next_Aggr;
5157 Others_Present : Boolean;
5159 -- Start of processing for Flatten
5162 if Nkind (Original_Node (N)) = N_String_Literal then
5166 if not Compile_Time_Known_Value (Lo)
5167 or else not Compile_Time_Known_Value (Hi)
5172 Lov := Expr_Value (Lo);
5173 Hiv := Expr_Value (Hi);
5175 -- Check if there is an others choice
5177 Others_Present := False;
5179 if Present (Component_Associations (N)) then
5185 Assoc := First (Component_Associations (N));
5186 while Present (Assoc) loop
5188 -- If this is a box association, flattening is in general
5189 -- not possible because at this point we cannot tell if the
5190 -- default is static or even exists.
5192 if Box_Present (Assoc) then
5195 elsif Nkind (Assoc) = N_Iterated_Component_Association then
5199 Choice := First (Choice_List (Assoc));
5201 while Present (Choice) loop
5202 if Nkind (Choice) = N_Others_Choice then
5203 Others_Present := True;
5214 -- If the low bound is not known at compile time and others is not
5215 -- present we can proceed since the bounds can be obtained from the
5219 or else (not Compile_Time_Known_Value (Blo) and then Others_Present)
5224 -- Determine if set of alternatives is suitable for conversion and
5225 -- build an array containing the values in sequence.
5228 Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv))
5229 of Node_Id := (others => Empty);
5230 -- The values in the aggregate sorted appropriately
5233 -- Same data as Vals in list form
5236 -- Used to validate Max_Others_Replicate limit
5240 Num : Int := UI_To_Int (Lov);
5246 if Present (Expressions (N)) then
5247 Elmt := First (Expressions (N));
5248 while Present (Elmt) loop
5249 -- In the case of a multidimensional array, check that the
5250 -- aggregate can be recursively flattened.
5252 if Cannot_Flatten_Next_Aggr (Elmt) then
5256 -- Duplicate expression for each index it covers
5258 Vals (Num) := New_Copy_Tree (Elmt);
5265 if No (Component_Associations (N)) then
5269 Elmt := First (Component_Associations (N));
5271 Component_Loop : while Present (Elmt) loop
5272 Expr := Expression (Elmt);
5274 -- In the case of a multidimensional array, check that the
5275 -- aggregate can be recursively flattened.
5277 if Cannot_Flatten_Next_Aggr (Expr) then
5281 Choice := First (Choice_List (Elmt));
5282 Choice_Loop : while Present (Choice) loop
5284 -- If we have an others choice, fill in the missing elements
5285 -- subject to the limit established by Max_Others_Replicate.
5287 if Nkind (Choice) = N_Others_Choice then
5290 -- If the expression involves a construct that generates
5291 -- a loop, we must generate individual assignments and
5292 -- no flattening is possible.
5294 if Nkind (Expr) = N_Quantified_Expression then
5298 for J in Vals'Range loop
5299 if No (Vals (J)) then
5300 Vals (J) := New_Copy_Tree (Expr);
5301 Rep_Count := Rep_Count + 1;
5303 -- Check for maximum others replication. Note that
5304 -- we skip this test if either of the restrictions
5305 -- No_Implicit_Loops or No_Elaboration_Code is
5306 -- active, if this is a preelaborable unit or
5307 -- a predefined unit, or if the unit must be
5308 -- placed in data memory. This also ensures that
5309 -- predefined units get the same level of constant
5310 -- folding in Ada 95 and Ada 2005, where their
5311 -- categorization has changed.
5314 P : constant Entity_Id :=
5315 Cunit_Entity (Current_Sem_Unit);
5318 -- Check if duplication is always OK and, if so,
5319 -- continue processing.
5321 if Restriction_Active (No_Implicit_Loops) then
5324 -- If duplication is not always OK, continue
5325 -- only if either the element is static or is
5326 -- an aggregate (we already know it is OK).
5328 elsif not Is_Static_Element (Elmt, Dims)
5329 and then Nkind (Expr) /= N_Aggregate
5333 -- Check if duplication is OK for elaboration
5334 -- purposes and, if so, continue processing.
5336 elsif Restriction_Active (No_Elaboration_Code)
5338 (Ekind (Current_Scope) = E_Package
5340 Static_Elaboration_Desired (Current_Scope))
5341 or else Is_Preelaborated (P)
5342 or else (Ekind (P) = E_Package_Body
5344 Is_Preelaborated (Spec_Entity (P)))
5346 Is_Predefined_Unit (Get_Source_Unit (P))
5350 -- Otherwise, check that the replication count
5353 elsif Rep_Count > Max_Others_Replicate then
5361 and then Warn_On_Redundant_Constructs
5363 Error_Msg_N ("there are no others?r?", Elmt);
5366 exit Component_Loop;
5368 -- Case of a subtype mark, identifier or expanded name
5370 elsif Is_Entity_Name (Choice)
5371 and then Is_Type (Entity (Choice))
5373 Lo := Type_Low_Bound (Etype (Choice));
5374 Hi := Type_High_Bound (Etype (Choice));
5376 -- Case of subtype indication
5378 elsif Nkind (Choice) = N_Subtype_Indication then
5379 Lo := Low_Bound (Range_Expression (Constraint (Choice)));
5380 Hi := High_Bound (Range_Expression (Constraint (Choice)));
5384 elsif Nkind (Choice) = N_Range then
5385 Lo := Low_Bound (Choice);
5386 Hi := High_Bound (Choice);
5388 -- Normal subexpression case
5390 else pragma Assert (Nkind (Choice) in N_Subexpr);
5391 if not Compile_Time_Known_Value (Choice) then
5395 Choice_Index := UI_To_Int (Expr_Value (Choice));
5397 if Choice_Index in Vals'Range then
5398 Vals (Choice_Index) := New_Copy_Tree (Expr);
5401 -- Choice is statically out-of-range, will be
5402 -- rewritten to raise Constraint_Error.
5410 -- Range cases merge with Lo,Hi set
5412 if not Compile_Time_Known_Value (Lo)
5414 not Compile_Time_Known_Value (Hi)
5419 for J in UI_To_Int (Expr_Value (Lo)) ..
5420 UI_To_Int (Expr_Value (Hi))
5422 Vals (J) := New_Copy_Tree (Expr);
5428 end loop Choice_Loop;
5431 end loop Component_Loop;
5433 -- If we get here the conversion is possible
5436 for J in Vals'Range loop
5437 Append (Vals (J), Vlist);
5440 Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist));
5441 Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N)));
5450 function Is_Flat (N : Node_Id; Dims : Nat) return Boolean is
5457 elsif Nkind (N) = N_Aggregate then
5458 if Present (Component_Associations (N)) then
5462 Elmt := First (Expressions (N));
5463 while Present (Elmt) loop
5464 if not Is_Flat (Elmt, Dims - 1) then
5478 -------------------------
5479 -- Is_Static_Element --
5480 -------------------------
5482 function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean is
5483 Expr : constant Node_Id := Expression (N);
5486 -- In most cases the interesting expressions are unambiguously static
5488 if Compile_Time_Known_Value (Expr) then
5491 elsif Nkind (N) = N_Iterated_Component_Association then
5494 elsif Nkind (Expr) = N_Aggregate
5495 and then Compile_Time_Known_Aggregate (Expr)
5496 and then not Expansion_Delayed (Expr)
5500 -- However, one may write static expressions that are syntactically
5501 -- ambiguous, so preanalyze the expression before checking it again,
5502 -- but only at the innermost level for a multidimensional array.
5505 Preanalyze_And_Resolve (Expr, Component_Type (Typ));
5506 return Compile_Time_Known_Value (Expr);
5511 end Is_Static_Element;
5513 -- Start of processing for Convert_To_Positional
5516 -- Only convert to positional when generating C in case of an
5517 -- object declaration, this is the only case where aggregates are
5520 if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
5524 -- Ada 2005 (AI-287): Do not convert in case of default initialized
5525 -- components because in this case will need to call the corresponding
5528 if Has_Default_Init_Comps (N) then
5532 -- A subaggregate may have been flattened but is not known to be
5533 -- Compile_Time_Known. Set that flag in cases that cannot require
5534 -- elaboration code, so that the aggregate can be used as the
5535 -- initial value of a thread-local variable.
5537 if Is_Flat (N, Dims) then
5538 if Static_Array_Aggregate (N) then
5539 Set_Compile_Time_Known_Aggregate (N);
5545 if Is_Bit_Packed_Array (Typ) and then not Handle_Bit_Packed then
5549 -- Do not convert to positional if controlled components are involved
5550 -- since these require special processing
5552 if Has_Controlled_Component (Typ) then
5556 Check_Static_Components;
5558 -- If the size is known, or all the components are static, try to
5559 -- build a fully positional aggregate.
5561 -- The size of the type may not be known for an aggregate with
5562 -- discriminated array components, but if the components are static
5563 -- it is still possible to verify statically that the length is
5564 -- compatible with the upper bound of the type, and therefore it is
5565 -- worth flattening such aggregates as well.
5569 Flatten (N, Dims, First_Index (Typ), First_Index (Base_Type (Typ)))
5571 if Static_Components then
5572 Set_Compile_Time_Known_Aggregate (N);
5573 Set_Expansion_Delayed (N, False);
5576 Analyze_And_Resolve (N, Typ);
5579 -- If Static_Elaboration_Desired has been specified, diagnose aggregates
5580 -- that will still require initialization code.
5582 if (Ekind (Current_Scope) = E_Package
5583 and then Static_Elaboration_Desired (Current_Scope))
5584 and then Nkind (Parent (N)) = N_Object_Declaration
5590 if Nkind (N) = N_Aggregate and then Present (Expressions (N)) then
5591 Expr := First (Expressions (N));
5592 while Present (Expr) loop
5593 if not Compile_Time_Known_Value (Expr) then
5595 ("non-static object requires elaboration code??", N);
5602 if Present (Component_Associations (N)) then
5603 Error_Msg_N ("object requires elaboration code??", N);
5608 end Convert_To_Positional;
5610 ----------------------------
5611 -- Expand_Array_Aggregate --
5612 ----------------------------
5614 -- Array aggregate expansion proceeds as follows:
5616 -- 1. If requested we generate code to perform all the array aggregate
5617 -- bound checks, specifically
5619 -- (a) Check that the index range defined by aggregate bounds is
5620 -- compatible with corresponding index subtype.
5622 -- (b) If an others choice is present check that no aggregate
5623 -- index is outside the bounds of the index constraint.
5625 -- (c) For multidimensional arrays make sure that all subaggregates
5626 -- corresponding to the same dimension have the same bounds.
5628 -- 2. Check for packed array aggregate which can be converted to a
5629 -- constant so that the aggregate disappears completely.
5631 -- 3. Check case of nested aggregate. Generally nested aggregates are
5632 -- handled during the processing of the parent aggregate.
5634 -- 4. Check if the aggregate can be statically processed. If this is the
5635 -- case pass it as is to Gigi. Note that a necessary condition for
5636 -- static processing is that the aggregate be fully positional.
5638 -- 5. If in-place aggregate expansion is possible (i.e. no need to create
5639 -- a temporary) then mark the aggregate as such and return. Otherwise
5640 -- create a new temporary and generate the appropriate initialization
5643 procedure Expand_Array_Aggregate (N : Node_Id) is
5644 Loc : constant Source_Ptr := Sloc (N);
5646 Typ : constant Entity_Id := Etype (N);
5647 Ctyp : constant Entity_Id := Component_Type (Typ);
5648 -- Typ is the correct constrained array subtype of the aggregate
5649 -- Ctyp is the corresponding component type.
5651 Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
5652 -- Number of aggregate index dimensions
5654 Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id;
5655 Aggr_High : array (1 .. Aggr_Dimension) of Node_Id;
5656 -- Low and High bounds of the constraint for each aggregate index
5658 Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
5659 -- The type of each index
5661 In_Place_Assign_OK_For_Declaration : Boolean := False;
5662 -- True if we are to generate an in-place assignment for a declaration
5664 Maybe_In_Place_OK : Boolean;
5665 -- If the type is neither controlled nor packed and the aggregate
5666 -- is the expression in an assignment, assignment in place may be
5667 -- possible, provided other conditions are met on the LHS.
5669 Others_Present : array (1 .. Aggr_Dimension) of Boolean :=
5671 -- If Others_Present (J) is True, then there is an others choice in one
5672 -- of the subaggregates of N at dimension J.
5674 procedure Build_Constrained_Type (Positional : Boolean);
5675 -- If the subtype is not static or unconstrained, build a constrained
5676 -- type using the computable sizes of the aggregate and its sub-
5679 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id);
5680 -- Checks that the bounds of Aggr_Bounds are within the bounds defined
5683 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos);
5684 -- Checks that in a multidimensional array aggregate all subaggregates
5685 -- corresponding to the same dimension have the same bounds. Sub_Aggr is
5686 -- an array subaggregate. Dim is the dimension corresponding to the
5689 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos);
5690 -- Computes the values of array Others_Present. Sub_Aggr is the array
5691 -- subaggregate we start the computation from. Dim is the dimension
5692 -- corresponding to the subaggregate.
5694 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
5695 -- Checks that if an others choice is present in any subaggregate, no
5696 -- aggregate index is outside the bounds of the index constraint.
5697 -- Sub_Aggr is an array subaggregate. Dim is the dimension corresponding
5698 -- to the subaggregate.
5700 function Safe_Left_Hand_Side (N : Node_Id) return Boolean;
5701 -- In addition to Maybe_In_Place_OK, in order for an aggregate to be
5702 -- built directly into the target of the assignment it must be free
5703 -- of side effects. N is the LHS of an assignment.
5705 ----------------------------
5706 -- Build_Constrained_Type --
5707 ----------------------------
5709 procedure Build_Constrained_Type (Positional : Boolean) is
5710 Loc : constant Source_Ptr := Sloc (N);
5711 Agg_Type : constant Entity_Id := Make_Temporary (Loc, 'A');
5714 Typ : constant Entity_Id := Etype (N);
5715 Indexes : constant List_Id := New_List;
5720 -- If the aggregate is purely positional, all its subaggregates
5721 -- have the same size. We collect the dimensions from the first
5722 -- subaggregate at each level.
5727 for D in 1 .. Number_Dimensions (Typ) loop
5728 Sub_Agg := First (Expressions (Sub_Agg));
5732 while Present (Comp) loop
5739 Low_Bound => Make_Integer_Literal (Loc, 1),
5740 High_Bound => Make_Integer_Literal (Loc, Num)));
5744 -- We know the aggregate type is unconstrained and the aggregate
5745 -- is not processable by the back end, therefore not necessarily
5746 -- positional. Retrieve each dimension bounds (computed earlier).
5748 for D in 1 .. Number_Dimensions (Typ) loop
5751 Low_Bound => Aggr_Low (D),
5752 High_Bound => Aggr_High (D)));
5757 Make_Full_Type_Declaration (Loc,
5758 Defining_Identifier => Agg_Type,
5760 Make_Constrained_Array_Definition (Loc,
5761 Discrete_Subtype_Definitions => Indexes,
5762 Component_Definition =>
5763 Make_Component_Definition (Loc,
5764 Aliased_Present => False,
5765 Subtype_Indication =>
5766 New_Occurrence_Of (Component_Type (Typ), Loc))));
5768 Insert_Action (N, Decl);
5770 Set_Etype (N, Agg_Type);
5771 Set_Is_Itype (Agg_Type);
5772 Freeze_Itype (Agg_Type, N);
5773 end Build_Constrained_Type;
5779 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is
5786 Cond : Node_Id := Empty;
5789 Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi);
5790 Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi);
5792 -- Generate the following test:
5794 -- [constraint_error when
5795 -- Aggr_Lo <= Aggr_Hi and then
5796 -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
5798 -- As an optimization try to see if some tests are trivially vacuous
5799 -- because we are comparing an expression against itself.
5801 if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then
5804 elsif Aggr_Hi = Ind_Hi then
5807 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
5808 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo));
5810 elsif Aggr_Lo = Ind_Lo then
5813 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
5814 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Hi));
5821 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
5822 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)),
5826 Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
5827 Right_Opnd => Duplicate_Subexpr (Ind_Hi)));
5830 if Present (Cond) then
5835 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
5836 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)),
5838 Right_Opnd => Cond);
5840 Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False);
5841 Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False);
5843 Make_Raise_Constraint_Error (Loc,
5845 Reason => CE_Range_Check_Failed));
5849 ----------------------------
5850 -- Check_Same_Aggr_Bounds --
5851 ----------------------------
5853 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
5854 Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr));
5855 Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr));
5856 -- The bounds of this specific subaggregate
5858 Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
5859 Aggr_Hi : constant Node_Id := Aggr_High (Dim);
5860 -- The bounds of the aggregate for this dimension
5862 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
5863 -- The index type for this dimension.xxx
5865 Cond : Node_Id := Empty;
5870 -- If index checks are on generate the test
5872 -- [constraint_error when
5873 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
5875 -- As an optimization try to see if some tests are trivially vacuos
5876 -- because we are comparing an expression against itself. Also for
5877 -- the first dimension the test is trivially vacuous because there
5878 -- is just one aggregate for dimension 1.
5880 if Index_Checks_Suppressed (Ind_Typ) then
5883 elsif Dim = 1 or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi)
5887 elsif Aggr_Hi = Sub_Hi then
5890 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
5891 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo));
5893 elsif Aggr_Lo = Sub_Lo then
5896 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
5897 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi));
5904 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
5905 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)),
5909 Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
5910 Right_Opnd => Duplicate_Subexpr (Sub_Hi)));
5913 if Present (Cond) then
5915 Make_Raise_Constraint_Error (Loc,
5917 Reason => CE_Length_Check_Failed));
5920 -- Now look inside the subaggregate to see if there is more work
5922 if Dim < Aggr_Dimension then
5924 -- Process positional components
5926 if Present (Expressions (Sub_Aggr)) then
5927 Expr := First (Expressions (Sub_Aggr));
5928 while Present (Expr) loop
5929 Check_Same_Aggr_Bounds (Expr, Dim + 1);
5934 -- Process component associations
5936 if Present (Component_Associations (Sub_Aggr)) then
5937 Assoc := First (Component_Associations (Sub_Aggr));
5938 while Present (Assoc) loop
5939 Expr := Expression (Assoc);
5940 Check_Same_Aggr_Bounds (Expr, Dim + 1);
5945 end Check_Same_Aggr_Bounds;
5947 ----------------------------
5948 -- Compute_Others_Present --
5949 ----------------------------
5951 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is
5956 if Present (Component_Associations (Sub_Aggr)) then
5957 Assoc := Last (Component_Associations (Sub_Aggr));
5959 if Nkind (First (Choice_List (Assoc))) = N_Others_Choice then
5960 Others_Present (Dim) := True;
5962 -- An others_clause may be superfluous if previous components
5963 -- cover the full given range of a constrained array. In such
5964 -- a case an others_clause does not contribute any additional
5965 -- components and has not been analyzed. We analyze it now to
5966 -- detect type errors in the expression, even though no code
5967 -- will be generated for it.
5969 if Dim = Aggr_Dimension
5970 and then Nkind (Assoc) /= N_Iterated_Component_Association
5971 and then not Analyzed (Expression (Assoc))
5972 and then not Box_Present (Assoc)
5974 Preanalyze_And_Resolve (Expression (Assoc), Ctyp);
5979 -- Now look inside the subaggregate to see if there is more work
5981 if Dim < Aggr_Dimension then
5983 -- Process positional components
5985 if Present (Expressions (Sub_Aggr)) then
5986 Expr := First (Expressions (Sub_Aggr));
5987 while Present (Expr) loop
5988 Compute_Others_Present (Expr, Dim + 1);
5993 -- Process component associations
5995 if Present (Component_Associations (Sub_Aggr)) then
5996 Assoc := First (Component_Associations (Sub_Aggr));
5997 while Present (Assoc) loop
5998 Expr := Expression (Assoc);
5999 Compute_Others_Present (Expr, Dim + 1);
6004 end Compute_Others_Present;
6010 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is
6011 Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
6012 Aggr_Hi : constant Node_Id := Aggr_High (Dim);
6013 -- The bounds of the aggregate for this dimension
6015 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
6016 -- The index type for this dimension
6018 Need_To_Check : Boolean := False;
6020 Choices_Lo : Node_Id := Empty;
6021 Choices_Hi : Node_Id := Empty;
6022 -- The lowest and highest discrete choices for a named subaggregate
6024 Nb_Choices : Int := -1;
6025 -- The number of discrete non-others choices in this subaggregate
6027 Nb_Elements : Uint := Uint_0;
6028 -- The number of elements in a positional aggregate
6030 Cond : Node_Id := Empty;
6037 -- Check if we have an others choice. If we do make sure that this
6038 -- subaggregate contains at least one element in addition to the
6041 if Range_Checks_Suppressed (Ind_Typ) then
6042 Need_To_Check := False;
6044 elsif Present (Expressions (Sub_Aggr))
6045 and then Present (Component_Associations (Sub_Aggr))
6047 Need_To_Check := True;
6049 elsif Present (Component_Associations (Sub_Aggr)) then
6050 Assoc := Last (Component_Associations (Sub_Aggr));
6052 if Nkind (First (Choice_List (Assoc))) /= N_Others_Choice then
6053 Need_To_Check := False;
6056 -- Count the number of discrete choices. Start with -1 because
6057 -- the others choice does not count.
6059 -- Is there some reason we do not use List_Length here ???
6062 Assoc := First (Component_Associations (Sub_Aggr));
6063 while Present (Assoc) loop
6064 Choice := First (Choice_List (Assoc));
6065 while Present (Choice) loop
6066 Nb_Choices := Nb_Choices + 1;
6073 -- If there is only an others choice nothing to do
6075 Need_To_Check := (Nb_Choices > 0);
6079 Need_To_Check := False;
6082 -- If we are dealing with a positional subaggregate with an others
6083 -- choice then compute the number or positional elements.
6085 if Need_To_Check and then Present (Expressions (Sub_Aggr)) then
6086 Expr := First (Expressions (Sub_Aggr));
6087 Nb_Elements := Uint_0;
6088 while Present (Expr) loop
6089 Nb_Elements := Nb_Elements + 1;
6093 -- If the aggregate contains discrete choices and an others choice
6094 -- compute the smallest and largest discrete choice values.
6096 elsif Need_To_Check then
6097 Compute_Choices_Lo_And_Choices_Hi : declare
6099 Table : Case_Table_Type (1 .. Nb_Choices);
6100 -- Used to sort all the different choice values
6107 Assoc := First (Component_Associations (Sub_Aggr));
6108 while Present (Assoc) loop
6109 Choice := First (Choice_List (Assoc));
6110 while Present (Choice) loop
6111 if Nkind (Choice) = N_Others_Choice then
6115 Get_Index_Bounds (Choice, Low, High);
6116 Table (J).Choice_Lo := Low;
6117 Table (J).Choice_Hi := High;
6126 -- Sort the discrete choices
6128 Sort_Case_Table (Table);
6130 Choices_Lo := Table (1).Choice_Lo;
6131 Choices_Hi := Table (Nb_Choices).Choice_Hi;
6132 end Compute_Choices_Lo_And_Choices_Hi;
6135 -- If no others choice in this subaggregate, or the aggregate
6136 -- comprises only an others choice, nothing to do.
6138 if not Need_To_Check then
6141 -- If we are dealing with an aggregate containing an others choice
6142 -- and positional components, we generate the following test:
6144 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
6145 -- Ind_Typ'Pos (Aggr_Hi)
6147 -- raise Constraint_Error;
6150 -- in the general case, but the following simpler test:
6152 -- [constraint_error when
6153 -- Aggr_Lo + (Nb_Elements - 1) > Aggr_Hi];
6155 -- instead if the index type is a signed integer.
6157 elsif Nb_Elements > Uint_0 then
6158 if Nb_Elements = Uint_1 then
6161 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
6162 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi));
6164 elsif Is_Signed_Integer_Type (Ind_Typ) then
6169 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
6171 Make_Integer_Literal (Loc, Nb_Elements - 1)),
6172 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi));
6180 Make_Attribute_Reference (Loc,
6181 Prefix => New_Occurrence_Of (Ind_Typ, Loc),
6182 Attribute_Name => Name_Pos,
6185 (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
6186 Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
6189 Make_Attribute_Reference (Loc,
6190 Prefix => New_Occurrence_Of (Ind_Typ, Loc),
6191 Attribute_Name => Name_Pos,
6192 Expressions => New_List (
6193 Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
6196 -- If we are dealing with an aggregate containing an others choice
6197 -- and discrete choices we generate the following test:
6199 -- [constraint_error when
6200 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
6207 Left_Opnd => Duplicate_Subexpr_Move_Checks (Choices_Lo),
6208 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo)),
6212 Left_Opnd => Duplicate_Subexpr (Choices_Hi),
6213 Right_Opnd => Duplicate_Subexpr (Aggr_Hi)));
6216 if Present (Cond) then
6218 Make_Raise_Constraint_Error (Loc,
6220 Reason => CE_Length_Check_Failed));
6221 -- Questionable reason code, shouldn't that be a
6222 -- CE_Range_Check_Failed ???
6225 -- Now look inside the subaggregate to see if there is more work
6227 if Dim < Aggr_Dimension then
6229 -- Process positional components
6231 if Present (Expressions (Sub_Aggr)) then
6232 Expr := First (Expressions (Sub_Aggr));
6233 while Present (Expr) loop
6234 Others_Check (Expr, Dim + 1);
6239 -- Process component associations
6241 if Present (Component_Associations (Sub_Aggr)) then
6242 Assoc := First (Component_Associations (Sub_Aggr));
6243 while Present (Assoc) loop
6244 Expr := Expression (Assoc);
6245 Others_Check (Expr, Dim + 1);
6252 -------------------------
6253 -- Safe_Left_Hand_Side --
6254 -------------------------
6256 function Safe_Left_Hand_Side (N : Node_Id) return Boolean is
6257 function Is_Safe_Index (Indx : Node_Id) return Boolean;
6258 -- If the left-hand side includes an indexed component, check that
6259 -- the indexes are free of side effects.
6265 function Is_Safe_Index (Indx : Node_Id) return Boolean is
6267 if Is_Entity_Name (Indx) then
6270 elsif Nkind (Indx) = N_Integer_Literal then
6273 elsif Nkind (Indx) = N_Function_Call
6274 and then Is_Entity_Name (Name (Indx))
6275 and then Has_Pragma_Pure_Function (Entity (Name (Indx)))
6279 elsif Nkind (Indx) = N_Type_Conversion
6280 and then Is_Safe_Index (Expression (Indx))
6289 -- Start of processing for Safe_Left_Hand_Side
6292 if Is_Entity_Name (N) then
6295 elsif Nkind (N) in N_Explicit_Dereference | N_Selected_Component
6296 and then Safe_Left_Hand_Side (Prefix (N))
6300 elsif Nkind (N) = N_Indexed_Component
6301 and then Safe_Left_Hand_Side (Prefix (N))
6302 and then Is_Safe_Index (First (Expressions (N)))
6306 elsif Nkind (N) = N_Unchecked_Type_Conversion then
6307 return Safe_Left_Hand_Side (Expression (N));
6312 end Safe_Left_Hand_Side;
6317 -- Holds the temporary aggregate value
6320 -- Holds the declaration of Tmp
6322 Aggr_Code : List_Id;
6323 Parent_Node : Node_Id;
6324 Parent_Kind : Node_Kind;
6326 -- Start of processing for Expand_Array_Aggregate
6329 -- Do not touch the special aggregates of attributes used for Asm calls
6331 if Is_RTE (Ctyp, RE_Asm_Input_Operand)
6332 or else Is_RTE (Ctyp, RE_Asm_Output_Operand)
6336 -- Do not expand an aggregate for an array type which contains tasks if
6337 -- the aggregate is associated with an unexpanded return statement of a
6338 -- build-in-place function. The aggregate is expanded when the related
6339 -- return statement (rewritten into an extended return) is processed.
6340 -- This delay ensures that any temporaries and initialization code
6341 -- generated for the aggregate appear in the proper return block and
6342 -- use the correct _chain and _master.
6344 elsif Has_Task (Base_Type (Etype (N)))
6345 and then Nkind (Parent (N)) = N_Simple_Return_Statement
6346 and then Is_Build_In_Place_Function
6347 (Return_Applies_To (Return_Statement_Entity (Parent (N))))
6351 -- Do not attempt expansion if error already detected. We may reach this
6352 -- point in spite of previous errors when compiling with -gnatq, to
6353 -- force all possible errors (this is the usual ACATS mode).
6355 elsif Error_Posted (N) then
6359 -- If the semantic analyzer has determined that aggregate N will raise
6360 -- Constraint_Error at run time, then the aggregate node has been
6361 -- replaced with an N_Raise_Constraint_Error node and we should
6364 pragma Assert (not Raises_Constraint_Error (N));
6368 -- Check that the index range defined by aggregate bounds is
6369 -- compatible with corresponding index subtype.
6371 Index_Compatibility_Check : declare
6372 Aggr_Index_Range : Node_Id := First_Index (Typ);
6373 -- The current aggregate index range
6375 Index_Constraint : Node_Id := First_Index (Etype (Typ));
6376 -- The corresponding index constraint against which we have to
6377 -- check the above aggregate index range.
6380 Compute_Others_Present (N, 1);
6382 for J in 1 .. Aggr_Dimension loop
6383 -- There is no need to emit a check if an others choice is present
6384 -- for this array aggregate dimension since in this case one of
6385 -- N's subaggregates has taken its bounds from the context and
6386 -- these bounds must have been checked already. In addition all
6387 -- subaggregates corresponding to the same dimension must all have
6388 -- the same bounds (checked in (c) below).
6390 if not Range_Checks_Suppressed (Etype (Index_Constraint))
6391 and then not Others_Present (J)
6393 -- We don't use Checks.Apply_Range_Check here because it emits
6394 -- a spurious check. Namely it checks that the range defined by
6395 -- the aggregate bounds is nonempty. But we know this already
6398 Check_Bounds (Aggr_Index_Range, Index_Constraint);
6401 -- Save the low and high bounds of the aggregate index as well as
6402 -- the index type for later use in checks (b) and (c) below.
6404 Aggr_Low (J) := Low_Bound (Aggr_Index_Range);
6405 Aggr_High (J) := High_Bound (Aggr_Index_Range);
6407 Aggr_Index_Typ (J) := Etype (Index_Constraint);
6409 Next_Index (Aggr_Index_Range);
6410 Next_Index (Index_Constraint);
6412 end Index_Compatibility_Check;
6416 -- If an others choice is present check that no aggregate index is
6417 -- outside the bounds of the index constraint.
6419 Others_Check (N, 1);
6423 -- For multidimensional arrays make sure that all subaggregates
6424 -- corresponding to the same dimension have the same bounds.
6426 if Aggr_Dimension > 1 then
6427 Check_Same_Aggr_Bounds (N, 1);
6432 -- If we have a default component value, or simple initialization is
6433 -- required for the component type, then we replace <> in component
6434 -- associations by the required default value.
6437 Default_Val : Node_Id;
6441 if (Present (Default_Aspect_Component_Value (Typ))
6442 or else Needs_Simple_Initialization (Ctyp))
6443 and then Present (Component_Associations (N))
6445 Assoc := First (Component_Associations (N));
6446 while Present (Assoc) loop
6447 if Nkind (Assoc) = N_Component_Association
6448 and then Box_Present (Assoc)
6450 Set_Box_Present (Assoc, False);
6452 if Present (Default_Aspect_Component_Value (Typ)) then
6453 Default_Val := Default_Aspect_Component_Value (Typ);
6455 Default_Val := Get_Simple_Init_Val (Ctyp, N);
6458 Set_Expression (Assoc, New_Copy_Tree (Default_Val));
6459 Analyze_And_Resolve (Expression (Assoc), Ctyp);
6469 -- Here we test for is packed array aggregate that we can handle at
6470 -- compile time. If so, return with transformation done. Note that we do
6471 -- this even if the aggregate is nested, because once we have done this
6472 -- processing, there is no more nested aggregate.
6474 if Packed_Array_Aggregate_Handled (N) then
6478 -- At this point we try to convert to positional form
6480 Convert_To_Positional (N);
6482 -- If the result is no longer an aggregate (e.g. it may be a string
6483 -- literal, or a temporary which has the needed value), then we are
6484 -- done, since there is no longer a nested aggregate.
6486 if Nkind (N) /= N_Aggregate then
6489 -- We are also done if the result is an analyzed aggregate, indicating
6490 -- that Convert_To_Positional succeeded and reanalyzed the rewritten
6493 elsif Analyzed (N) and then Is_Rewrite_Substitution (N) then
6497 -- If all aggregate components are compile-time known and the aggregate
6498 -- has been flattened, nothing left to do. The same occurs if the
6499 -- aggregate is used to initialize the components of a statically
6500 -- allocated dispatch table.
6502 if Compile_Time_Known_Aggregate (N)
6503 or else Is_Static_Dispatch_Table_Aggregate (N)
6505 Set_Expansion_Delayed (N, False);
6509 -- Now see if back end processing is possible
6511 if Backend_Processing_Possible (N) then
6513 -- If the aggregate is static but the constraints are not, build
6514 -- a static subtype for the aggregate, so that Gigi can place it
6515 -- in static memory. Perform an unchecked_conversion to the non-
6516 -- static type imposed by the context.
6519 Itype : constant Entity_Id := Etype (N);
6521 Needs_Type : Boolean := False;
6524 Index := First_Index (Itype);
6525 while Present (Index) loop
6526 if not Is_OK_Static_Subtype (Etype (Index)) then
6535 Build_Constrained_Type (Positional => True);
6536 Rewrite (N, Unchecked_Convert_To (Itype, N));
6546 -- Delay expansion for nested aggregates: it will be taken care of when
6547 -- the parent aggregate is expanded.
6549 Parent_Node := Parent (N);
6550 Parent_Kind := Nkind (Parent_Node);
6552 if Parent_Kind = N_Qualified_Expression then
6553 Parent_Node := Parent (Parent_Node);
6554 Parent_Kind := Nkind (Parent_Node);
6557 if Parent_Kind = N_Aggregate
6558 or else Parent_Kind = N_Extension_Aggregate
6559 or else Parent_Kind = N_Component_Association
6560 or else (Parent_Kind = N_Object_Declaration
6561 and then Needs_Finalization (Typ))
6562 or else (Parent_Kind = N_Assignment_Statement
6563 and then Inside_Init_Proc)
6565 Set_Expansion_Delayed (N, not Static_Array_Aggregate (N));
6571 -- Check whether in-place aggregate expansion is possible
6573 -- For object declarations we build the aggregate in place, unless
6574 -- the array is bit-packed.
6576 -- For assignments we do the assignment in place if all the component
6577 -- associations have compile-time known values, or are default-
6578 -- initialized limited components, e.g. tasks. For other cases we
6579 -- create a temporary. The analysis for safety of on-line assignment
6580 -- is delicate, i.e. we don't know how to do it fully yet ???
6582 -- For allocators we assign to the designated object in place if the
6583 -- aggregate meets the same conditions as other in-place assignments.
6584 -- In this case the aggregate may not come from source but was created
6585 -- for default initialization, e.g. with Initialize_Scalars.
6587 if Requires_Transient_Scope (Typ) then
6588 Establish_Transient_Scope (N, Manage_Sec_Stack => False);
6591 -- An array of limited components is built in place
6593 if Is_Limited_Type (Typ) then
6594 Maybe_In_Place_OK := True;
6596 elsif Has_Default_Init_Comps (N) then
6597 Maybe_In_Place_OK := False;
6599 elsif Is_Bit_Packed_Array (Typ)
6600 or else Has_Controlled_Component (Typ)
6602 Maybe_In_Place_OK := False;
6604 elsif Parent_Kind = N_Assignment_Statement then
6605 Maybe_In_Place_OK :=
6606 In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)));
6608 elsif Parent_Kind = N_Allocator then
6609 Maybe_In_Place_OK := In_Place_Assign_OK (N);
6612 Maybe_In_Place_OK := False;
6615 -- If this is an array of tasks, it will be expanded into build-in-place
6616 -- assignments. Build an activation chain for the tasks now.
6618 if Has_Task (Etype (N)) then
6619 Build_Activation_Chain_Entity (N);
6622 -- Perform in-place expansion of aggregate in an object declaration.
6623 -- Note: actions generated for the aggregate will be captured in an
6624 -- expression-with-actions statement so that they can be transferred
6625 -- to freeze actions later if there is an address clause for the
6626 -- object. (Note: we don't use a block statement because this would
6627 -- cause generated freeze nodes to be elaborated in the wrong scope).
6629 -- Arrays of limited components must be built in place. The code
6630 -- previously excluded controlled components but this is an old
6631 -- oversight: the rules in 7.6 (17) are clear.
6633 if Comes_From_Source (Parent_Node)
6634 and then Parent_Kind = N_Object_Declaration
6635 and then Present (Expression (Parent_Node))
6637 Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ)
6638 and then not Is_Bit_Packed_Array (Typ)
6640 In_Place_Assign_OK_For_Declaration := True;
6641 Tmp := Defining_Identifier (Parent_Node);
6642 Set_No_Initialization (Parent_Node);
6643 Set_Expression (Parent_Node, Empty);
6645 -- Set kind and type of the entity, for use in the analysis
6646 -- of the subsequent assignments. If the nominal type is not
6647 -- constrained, build a subtype from the known bounds of the
6648 -- aggregate. If the declaration has a subtype mark, use it,
6649 -- otherwise use the itype of the aggregate.
6651 Set_Ekind (Tmp, E_Variable);
6653 if not Is_Constrained (Typ) then
6654 Build_Constrained_Type (Positional => False);
6656 elsif Is_Entity_Name (Object_Definition (Parent_Node))
6657 and then Is_Constrained (Entity (Object_Definition (Parent_Node)))
6659 Set_Etype (Tmp, Entity (Object_Definition (Parent_Node)));
6662 Set_Size_Known_At_Compile_Time (Typ, False);
6663 Set_Etype (Tmp, Typ);
6666 elsif Maybe_In_Place_OK and then Parent_Kind = N_Allocator then
6667 Set_Expansion_Delayed (N);
6670 -- Limited arrays in return statements are expanded when
6671 -- enclosing construct is expanded.
6673 elsif Maybe_In_Place_OK
6674 and then Parent_Kind = N_Simple_Return_Statement
6676 Set_Expansion_Delayed (N);
6679 -- In the remaining cases the aggregate appears in the RHS of an
6680 -- assignment, which may be part of the expansion of an object
6681 -- delaration. If the aggregate is an actual in a call, itself
6682 -- possibly in a RHS, building it in the target is not possible.
6684 elsif Maybe_In_Place_OK
6685 and then Nkind (Parent_Node) not in N_Subprogram_Call
6686 and then Safe_Left_Hand_Side (Name (Parent_Node))
6688 Tmp := Name (Parent_Node);
6690 if Etype (Tmp) /= Etype (N) then
6691 Apply_Length_Check (N, Etype (Tmp));
6693 if Nkind (N) = N_Raise_Constraint_Error then
6695 -- Static error, nothing further to expand
6701 -- If a slice assignment has an aggregate with a single others_choice,
6702 -- the assignment can be done in place even if bounds are not static,
6703 -- by converting it into a loop over the discrete range of the slice.
6705 elsif Maybe_In_Place_OK
6706 and then Nkind (Name (Parent_Node)) = N_Slice
6707 and then Is_Others_Aggregate (N)
6709 Tmp := Name (Parent_Node);
6711 -- Set type of aggregate to be type of lhs in assignment, in order
6712 -- to suppress redundant length checks.
6714 Set_Etype (N, Etype (Tmp));
6718 -- In-place aggregate expansion is not possible
6721 Maybe_In_Place_OK := False;
6722 Tmp := Make_Temporary (Loc, 'A', N);
6724 Make_Object_Declaration (Loc,
6725 Defining_Identifier => Tmp,
6726 Object_Definition => New_Occurrence_Of (Typ, Loc));
6727 Set_No_Initialization (Tmp_Decl, True);
6728 Set_Warnings_Off (Tmp);
6730 -- If we are within a loop, the temporary will be pushed on the
6731 -- stack at each iteration. If the aggregate is the expression
6732 -- for an allocator, it will be immediately copied to the heap
6733 -- and can be reclaimed at once. We create a transient scope
6734 -- around the aggregate for this purpose.
6736 if Ekind (Current_Scope) = E_Loop
6737 and then Parent_Kind = N_Allocator
6739 Establish_Transient_Scope (N, Manage_Sec_Stack => False);
6742 Insert_Action (N, Tmp_Decl);
6745 -- Construct and insert the aggregate code. We can safely suppress index
6746 -- checks because this code is guaranteed not to raise CE on index
6747 -- checks. However we should *not* suppress all checks.
6753 if Nkind (Tmp) = N_Defining_Identifier then
6754 Target := New_Occurrence_Of (Tmp, Loc);
6757 if Has_Default_Init_Comps (N)
6758 and then not Maybe_In_Place_OK
6760 -- Ada 2005 (AI-287): This case has not been analyzed???
6762 raise Program_Error;
6765 -- Name in assignment is explicit dereference
6767 Target := New_Copy (Tmp);
6770 -- If we are to generate an in-place assignment for a declaration or
6771 -- an assignment statement, and the assignment can be done directly
6772 -- by the back end, then do not expand further.
6774 -- ??? We can also do that if in-place expansion is not possible but
6775 -- then we could go into an infinite recursion.
6777 if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK)
6778 and then not CodePeer_Mode
6779 and then not Modify_Tree_For_C
6780 and then not Possible_Bit_Aligned_Component (Target)
6781 and then not Is_Possibly_Unaligned_Slice (Target)
6782 and then Aggr_Assignment_OK_For_Backend (N)
6784 if Maybe_In_Place_OK then
6790 Make_Assignment_Statement (Loc,
6792 Expression => New_Copy_Tree (N)));
6796 Build_Array_Aggr_Code (N,
6798 Index => First_Index (Typ),
6800 Scalar_Comp => Is_Scalar_Type (Ctyp));
6803 -- Save the last assignment statement associated with the aggregate
6804 -- when building a controlled object. This reference is utilized by
6805 -- the finalization machinery when marking an object as successfully
6808 if Needs_Finalization (Typ)
6809 and then Is_Entity_Name (Target)
6810 and then Present (Entity (Target))
6811 and then Ekind (Entity (Target)) in E_Constant | E_Variable
6813 Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
6817 -- If the aggregate is the expression in a declaration, the expanded
6818 -- code must be inserted after it. The defining entity might not come
6819 -- from source if this is part of an inlined body, but the declaration
6821 -- The test below looks very specialized and kludgy???
6823 if Comes_From_Source (Tmp)
6825 (Nkind (Parent (N)) = N_Object_Declaration
6826 and then Comes_From_Source (Parent (N))
6827 and then Tmp = Defining_Entity (Parent (N)))
6829 if Parent_Kind /= N_Object_Declaration or else Is_Frozen (Tmp) then
6830 Insert_Actions_After (Parent_Node, Aggr_Code);
6833 Comp_Stmt : constant Node_Id :=
6834 Make_Compound_Statement
6835 (Sloc (Parent_Node), Actions => Aggr_Code);
6837 Insert_Action_After (Parent_Node, Comp_Stmt);
6838 Set_Initialization_Statements (Tmp, Comp_Stmt);
6842 Insert_Actions (N, Aggr_Code);
6845 -- If the aggregate has been assigned in place, remove the original
6848 if Parent_Kind = N_Assignment_Statement and then Maybe_In_Place_OK then
6849 Rewrite (Parent_Node, Make_Null_Statement (Loc));
6851 -- Or else, if a temporary was created, replace the aggregate with it
6853 elsif Parent_Kind /= N_Object_Declaration
6854 or else Tmp /= Defining_Identifier (Parent_Node)
6856 Rewrite (N, New_Occurrence_Of (Tmp, Loc));
6857 Analyze_And_Resolve (N, Typ);
6859 end Expand_Array_Aggregate;
6861 ------------------------
6862 -- Expand_N_Aggregate --
6863 ------------------------
6865 procedure Expand_N_Aggregate (N : Node_Id) is
6866 T : constant Entity_Id := Etype (N);
6868 -- Record aggregate case
6870 if Is_Record_Type (T)
6871 and then not Is_Private_Type (T)
6873 Expand_Record_Aggregate (N);
6875 elsif Has_Aspect (T, Aspect_Aggregate) then
6876 Expand_Container_Aggregate (N);
6878 -- Array aggregate case
6881 -- A special case, if we have a string subtype with bounds 1 .. N,
6882 -- where N is known at compile time, and the aggregate is of the
6883 -- form (others => 'x'), with a single choice and no expressions,
6884 -- and N is less than 80 (an arbitrary limit for now), then replace
6885 -- the aggregate by the equivalent string literal (but do not mark
6886 -- it as static since it is not).
6888 -- Note: this entire circuit is redundant with respect to code in
6889 -- Expand_Array_Aggregate that collapses others choices to positional
6890 -- form, but there are two problems with that circuit:
6892 -- a) It is limited to very small cases due to ill-understood
6893 -- interactions with bootstrapping. That limit is removed by
6894 -- use of the No_Implicit_Loops restriction.
6896 -- b) It incorrectly ends up with the resulting expressions being
6897 -- considered static when they are not. For example, the
6898 -- following test should fail:
6900 -- pragma Restrictions (No_Implicit_Loops);
6901 -- package NonSOthers4 is
6902 -- B : constant String (1 .. 6) := (others => 'A');
6903 -- DH : constant String (1 .. 8) := B & "BB";
6905 -- pragma Export (C, X, Link_Name => DH);
6908 -- But it succeeds (DH looks static to pragma Export)
6910 -- To be sorted out ???
6912 if Present (Component_Associations (N)) then
6914 CA : constant Node_Id := First (Component_Associations (N));
6915 MX : constant := 80;
6918 if Nkind (First (Choice_List (CA))) = N_Others_Choice
6919 and then Nkind (Expression (CA)) = N_Character_Literal
6920 and then No (Expressions (N))
6923 X : constant Node_Id := First_Index (T);
6924 EC : constant Node_Id := Expression (CA);
6925 CV : constant Uint := Char_Literal_Value (EC);
6926 CC : constant Int := UI_To_Int (CV);
6929 if Nkind (X) = N_Range
6930 and then Compile_Time_Known_Value (Low_Bound (X))
6931 and then Expr_Value (Low_Bound (X)) = 1
6932 and then Compile_Time_Known_Value (High_Bound (X))
6935 Hi : constant Uint := Expr_Value (High_Bound (X));
6941 for J in 1 .. UI_To_Int (Hi) loop
6942 Store_String_Char (Char_Code (CC));
6946 Make_String_Literal (Sloc (N),
6947 Strval => End_String));
6949 if CC >= Int (2 ** 16) then
6950 Set_Has_Wide_Wide_Character (N);
6951 elsif CC >= Int (2 ** 8) then
6952 Set_Has_Wide_Character (N);
6955 Analyze_And_Resolve (N, T);
6956 Set_Is_Static_Expression (N, False);
6966 -- Not that special case, so normal expansion of array aggregate
6968 Expand_Array_Aggregate (N);
6972 when RE_Not_Available =>
6974 end Expand_N_Aggregate;
6976 --------------------------------
6977 -- Expand_Container_Aggregate --
6978 --------------------------------
6980 procedure Expand_Container_Aggregate (N : Node_Id) is
6981 Loc : constant Source_Ptr := Sloc (N);
6982 Typ : constant Entity_Id := Etype (N);
6983 Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
6985 Empty_Subp : Node_Id := Empty;
6986 Add_Named_Subp : Node_Id := Empty;
6987 Add_Unnamed_Subp : Node_Id := Empty;
6988 New_Indexed_Subp : Node_Id := Empty;
6989 Assign_Indexed_Subp : Node_Id := Empty;
6991 Aggr_Code : constant List_Id := New_List;
6992 Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N);
6997 Init_Stat : Node_Id;
7000 -- The following are used when the size of the aggregate is not
7001 -- static and requires a dynamic evaluation.
7003 Siz_Exp : Node_Id := Empty;
7004 Count_Type : Entity_Id;
7006 function Aggregate_Size return Int;
7007 -- Compute number of entries in aggregate, including choices
7008 -- that cover a range or subtype, as well as iterated constructs.
7009 -- Return -1 if the size is not known statically, in which case
7010 -- allocate a default size for the aggregate, or build an expression
7011 -- to estimate the size dynamically.
7013 function Build_Siz_Exp (Comp : Node_Id) return Int;
7014 -- When the aggregate contains a single Iterated_Component_Association
7015 -- or Element_Association with non-static bounds, build an expression
7016 -- to be used as the allocated size of the container. This may be an
7017 -- overestimate if a filter is present, but is a safe approximation.
7019 procedure Expand_Iterated_Component (Comp : Node_Id);
7020 -- Handle iterated_component_association and iterated_Element
7021 -- association by generating a loop over the specified range,
7022 -- given either by a loop parameter specification or an iterator
7025 --------------------
7026 -- Aggregate_Size --
7027 --------------------
7029 function Aggregate_Size return Int is
7035 procedure Add_Range_Size;
7036 -- Compute number of components specified by a component association
7037 -- given by a range or subtype name.
7039 --------------------
7040 -- Add_Range_Size --
7041 --------------------
7043 procedure Add_Range_Size is
7045 -- The bounds of the discrete range are integers or enumeration
7048 if Nkind (Lo) = N_Integer_Literal then
7049 Siz := Siz + UI_To_Int (Intval (Hi))
7050 - UI_To_Int (Intval (Lo)) + 1;
7052 Siz := Siz + UI_To_Int (Enumeration_Pos (Hi))
7053 - UI_To_Int (Enumeration_Pos (Lo)) + 1;
7058 -- Aggregate is either all positional or all named.
7060 if Present (Expressions (N)) then
7061 Siz := List_Length (Expressions (N));
7064 if Present (Component_Associations (N)) then
7065 Comp := First (Component_Associations (N));
7066 -- If there is a single component association it can be
7067 -- an iterated component with dynamic bounds or an element
7068 -- iterator over an iterable object. If it is an array
7069 -- we can use the attribute Length to get its size;
7070 -- for a predefined container the function Length plays
7071 -- the same role. There is no available mechanism for
7072 -- user-defined containers. For now we treat all of these
7075 if List_Length (Component_Associations (N)) = 1
7076 and then Nkind (Comp) in N_Iterated_Component_Association |
7077 N_Iterated_Element_Association
7079 return Build_Siz_Exp (Comp);
7082 -- Otherwise all associations must specify static sizes.
7084 while Present (Comp) loop
7085 Choice := First (Choice_List (Comp));
7087 while Present (Choice) loop
7090 if Nkind (Choice) = N_Range then
7091 Lo := Low_Bound (Choice);
7092 Hi := High_Bound (Choice);
7095 elsif Is_Entity_Name (Choice)
7096 and then Is_Type (Entity (Choice))
7098 Lo := Type_Low_Bound (Entity (Choice));
7099 Hi := Type_High_Bound (Entity (Choice));
7105 New_Copy_Tree (Hi)));
7108 -- Single choice (syntax excludes a subtype
7127 function Build_Siz_Exp (Comp : Node_Id) return Int is
7130 if Nkind (Comp) = N_Range then
7131 Lo := Low_Bound (Comp);
7132 Hi := High_Bound (Comp);
7136 -- Compute static size when possible.
7138 if Is_Static_Expression (Lo)
7139 and then Is_Static_Expression (Hi)
7141 if Nkind (Lo) = N_Integer_Literal then
7142 Siz := UI_To_Int (Intval (Hi)) - UI_To_Int (Intval (Lo)) + 1;
7144 Siz := UI_To_Int (Enumeration_Pos (Hi))
7145 - UI_To_Int (Enumeration_Pos (Lo)) + 1;
7151 Make_Op_Add (Sloc (Comp),
7153 Make_Op_Subtract (Sloc (Comp),
7154 Left_Opnd => New_Copy_Tree (Hi),
7155 Right_Opnd => New_Copy_Tree (Lo)),
7157 Make_Integer_Literal (Loc, 1));
7161 elsif Nkind (Comp) = N_Iterated_Component_Association then
7162 return Build_Siz_Exp (First (Discrete_Choices (Comp)));
7164 elsif Nkind (Comp) = N_Iterated_Element_Association then
7165 return -1; -- TBD, build expression for size of the domain
7172 -------------------------------
7173 -- Expand_Iterated_Component --
7174 -------------------------------
7176 procedure Expand_Iterated_Component (Comp : Node_Id) is
7177 Expr : constant Node_Id := Expression (Comp);
7179 Key_Expr : Node_Id := Empty;
7180 Loop_Id : Entity_Id;
7182 L_Iteration_Scheme : Node_Id;
7183 Loop_Stat : Node_Id;
7188 if Nkind (Comp) = N_Iterated_Element_Association then
7189 Key_Expr := Key_Expression (Comp);
7191 -- We create a new entity as loop identifier in all cases,
7192 -- as is done for generated loops elsewhere, as the loop
7193 -- structure has been previously analyzed.
7195 if Present (Iterator_Specification (Comp)) then
7197 -- Either an Iterator_Specification of a Loop_Parameter_
7198 -- Specification is present.
7200 L_Iteration_Scheme :=
7201 Make_Iteration_Scheme (Loc,
7202 Iterator_Specification => Iterator_Specification (Comp));
7204 Make_Defining_Identifier (Loc,
7205 Chars => Chars (Defining_Identifier
7206 (Iterator_Specification (Comp))));
7207 Set_Defining_Identifier
7208 (Iterator_Specification (L_Iteration_Scheme), Loop_Id);
7211 L_Iteration_Scheme :=
7212 Make_Iteration_Scheme (Loc,
7213 Loop_Parameter_Specification =>
7214 Loop_Parameter_Specification (Comp));
7216 Make_Defining_Identifier (Loc,
7217 Chars => Chars (Defining_Identifier
7218 (Loop_Parameter_Specification (Comp))));
7219 Set_Defining_Identifier
7220 (Loop_Parameter_Specification
7221 (L_Iteration_Scheme), Loop_Id);
7225 -- Iterated_Component_Association.
7228 Make_Defining_Identifier (Loc,
7229 Chars => Chars (Defining_Identifier (Comp)));
7231 if Present (Iterator_Specification (Comp)) then
7232 L_Iteration_Scheme :=
7233 Make_Iteration_Scheme (Loc,
7234 Iterator_Specification => Iterator_Specification (Comp));
7237 -- Loop_Parameter_Specifcation is parsed with a choice list.
7238 -- where the range is the first (and only) choice.
7240 L_Range := Relocate_Node (First (Discrete_Choices (Comp)));
7242 L_Iteration_Scheme :=
7243 Make_Iteration_Scheme (Loc,
7244 Loop_Parameter_Specification =>
7245 Make_Loop_Parameter_Specification (Loc,
7246 Defining_Identifier => Loop_Id,
7247 Discrete_Subtype_Definition => L_Range));
7251 -- Build insertion statement. For a positional aggregate, only the
7252 -- expression is needed. For a named aggregate, the loop variable,
7253 -- whose type is that of the key, is an additional parameter for
7254 -- the insertion operation.
7255 -- If a Key_Expression is present, it serves as the additional
7256 -- parameter. Otherwise the key is given by the loop parameter
7259 if Present (Add_Unnamed_Subp)
7260 and then No (Add_Named_Subp)
7263 (Make_Procedure_Call_Statement (Loc,
7264 Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc),
7265 Parameter_Associations =>
7266 New_List (New_Occurrence_Of (Temp, Loc),
7267 New_Copy_Tree (Expr))));
7269 -- Named or indexed aggregate, for which a key is present,
7270 -- possibly with a specified key_expression.
7272 if Present (Key_Expr) then
7273 Params := New_List (New_Occurrence_Of (Temp, Loc),
7274 New_Copy_Tree (Key_Expr),
7275 New_Copy_Tree (Expr));
7277 Params := New_List (New_Occurrence_Of (Temp, Loc),
7278 New_Occurrence_Of (Loop_Id, Loc),
7279 New_Copy_Tree (Expr));
7283 (Make_Procedure_Call_Statement (Loc,
7284 Name => New_Occurrence_Of (Entity (Add_Named_Subp), Loc),
7285 Parameter_Associations => Params));
7288 Loop_Stat := Make_Implicit_Loop_Statement
7290 Identifier => Empty,
7291 Iteration_Scheme => L_Iteration_Scheme,
7292 Statements => Stats);
7293 Append (Loop_Stat, Aggr_Code);
7295 end Expand_Iterated_Component;
7297 -- Start of processing for Expand_Container_Aggregate
7300 Parse_Aspect_Aggregate (Asp,
7301 Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
7302 New_Indexed_Subp, Assign_Indexed_Subp);
7304 -- The constructor for bounded containers is a function with
7305 -- a parameter that sets the size of the container. If the
7306 -- size cannot be determined statically we use a default value
7307 -- or a dynamic expression.
7309 Siz := Aggregate_Size;
7311 if Ekind (Entity (Empty_Subp)) = E_Function
7312 and then Present (First_Formal (Entity (Empty_Subp)))
7314 Default := Default_Value (First_Formal (Entity (Empty_Subp)));
7316 -- If aggregate size is not static, we can use default value
7317 -- of formal parameter for allocation. We assume that this
7318 -- (implementation-dependent) value is static, even though
7319 -- the AI does not require it.
7321 -- Create declaration for size: a constant literal in the simple
7322 -- case, an expression if iterated component associations may be
7323 -- involved, the default otherwise.
7325 Count_Type := Etype (First_Formal (Entity (Empty_Subp)));
7327 if No (Siz_Exp) then
7328 Siz := UI_To_Int (Intval (Default));
7329 Siz_Exp := Make_Integer_Literal (Loc, Siz);
7332 Siz_Exp := Make_Type_Conversion (Loc,
7334 New_Occurrence_Of (Count_Type, Loc),
7335 Expression => Siz_Exp);
7339 Siz_Exp := Make_Integer_Literal (Loc, Siz);
7342 Siz_Decl := Make_Object_Declaration (Loc,
7343 Defining_Identifier => Make_Temporary (Loc, 'S', N),
7344 Object_Definition =>
7345 New_Occurrence_Of (Count_Type, Loc),
7346 Expression => Siz_Exp);
7347 Append (Siz_Decl, Aggr_Code);
7349 if Nkind (Siz_Exp) = N_Integer_Literal then
7351 Make_Object_Declaration (Loc,
7352 Defining_Identifier => Temp,
7353 Object_Definition => New_Occurrence_Of (Typ, Loc),
7354 Expression => Make_Function_Call (Loc,
7355 Name => New_Occurrence_Of (Entity (Empty_Subp), Loc),
7356 Parameter_Associations =>
7359 (Defining_Identifier (Siz_Decl), Loc))));
7363 Make_Object_Declaration (Loc,
7364 Defining_Identifier => Temp,
7365 Object_Definition => New_Occurrence_Of (Typ, Loc),
7366 Expression => Make_Function_Call (Loc,
7368 New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
7369 Parameter_Associations =>
7371 Make_Integer_Literal (Loc, 1),
7373 (Defining_Identifier (Siz_Decl), Loc))));
7376 Append (Init_Stat, Aggr_Code);
7378 -- Size is dynamic: Create declaration for object, and intitialize
7379 -- with a call to the null container, or an assignment to it.
7383 Make_Object_Declaration (Loc,
7384 Defining_Identifier => Temp,
7385 Object_Definition => New_Occurrence_Of (Typ, Loc));
7387 Insert_Action (N, Decl);
7389 -- The Empty entity is either a parameterless function, or
7392 if Ekind (Entity (Empty_Subp)) = E_Function then
7393 Init_Stat := Make_Assignment_Statement (Loc,
7394 Name => New_Occurrence_Of (Temp, Loc),
7395 Expression => Make_Function_Call (Loc,
7396 Name => New_Occurrence_Of (Entity (Empty_Subp), Loc)));
7399 Init_Stat := Make_Assignment_Statement (Loc,
7400 Name => New_Occurrence_Of (Temp, Loc),
7401 Expression => New_Occurrence_Of (Entity (Empty_Subp), Loc));
7404 Append (Init_Stat, Aggr_Code);
7407 ---------------------------
7408 -- Positional aggregate --
7409 ---------------------------
7411 -- If the aggregate is positional the aspect must include
7412 -- an Add_Unnamed subprogram.
7414 if Present (Add_Unnamed_Subp) then
7415 if Present (Expressions (N)) then
7417 Insert : constant Entity_Id := Entity (Add_Unnamed_Subp);
7422 Comp := First (Expressions (N));
7423 while Present (Comp) loop
7424 Stat := Make_Procedure_Call_Statement (Loc,
7425 Name => New_Occurrence_Of (Insert, Loc),
7426 Parameter_Associations =>
7427 New_List (New_Occurrence_Of (Temp, Loc),
7428 New_Copy_Tree (Comp)));
7429 Append (Stat, Aggr_Code);
7435 -- Indexed aggregates are handled below. Unnamed aggregates
7436 -- such as sets may include iterated component associations.
7438 if No (New_Indexed_Subp) then
7439 Comp := First (Component_Associations (N));
7440 while Present (Comp) loop
7441 if Nkind (Comp) = N_Iterated_Component_Association then
7442 Expand_Iterated_Component (Comp);
7448 ---------------------
7449 -- Named_Aggregate --
7450 ---------------------
7452 elsif Present (Add_Named_Subp) then
7454 Insert : constant Entity_Id := Entity (Add_Named_Subp);
7458 Comp := First (Component_Associations (N));
7460 -- Each component association may contain several choices;
7461 -- generate an insertion statement for each.
7463 while Present (Comp) loop
7464 if Nkind (Comp) in N_Iterated_Component_Association
7465 | N_Iterated_Element_Association
7467 Expand_Iterated_Component (Comp);
7469 Key := First (Choices (Comp));
7471 while Present (Key) loop
7472 Stat := Make_Procedure_Call_Statement (Loc,
7473 Name => New_Occurrence_Of (Insert, Loc),
7474 Parameter_Associations =>
7475 New_List (New_Occurrence_Of (Temp, Loc),
7476 New_Copy_Tree (Key),
7477 New_Copy_Tree (Expression (Comp))));
7478 Append (Stat, Aggr_Code);
7489 -----------------------
7490 -- Indexed_Aggregate --
7491 -----------------------
7493 -- For an indexed aggregate there must be an Assigned_Indexeed
7494 -- subprogram. Note that unlike array aggregates, a container
7495 -- aggregate must be fully positional or fully indexed. In the
7496 -- first case the expansion has already taken place.
7497 -- TBA: the keys for an indexed aggregate must provide a dense
7498 -- range with no repetitions.
7500 if Present (Assign_Indexed_Subp)
7501 and then Present (Component_Associations (N))
7504 Insert : constant Entity_Id := Entity (Assign_Indexed_Subp);
7505 Index_Type : constant Entity_Id :=
7506 Etype (Next_Formal (First_Formal (Insert)));
7508 function Expand_Range_Component
7510 Expr : Node_Id) return Node_Id;
7511 -- Transform a component assoication with a range into an
7512 -- explicit loop. If the choice is a subtype name, it is
7513 -- rewritten as a range with the corresponding bounds, which
7514 -- are known to be static.
7522 -----------------------------
7523 -- Expand_Raange_Component --
7524 -----------------------------
7526 function Expand_Range_Component
7528 Expr : Node_Id) return Node_Id
7530 Loop_Id : constant Entity_Id :=
7531 Make_Temporary (Loc, 'T');
7533 L_Iteration_Scheme : Node_Id;
7537 L_Iteration_Scheme :=
7538 Make_Iteration_Scheme (Loc,
7539 Loop_Parameter_Specification =>
7540 Make_Loop_Parameter_Specification (Loc,
7541 Defining_Identifier => Loop_Id,
7542 Discrete_Subtype_Definition => New_Copy_Tree (Rng)));
7545 (Make_Procedure_Call_Statement (Loc,
7547 New_Occurrence_Of (Entity (Assign_Indexed_Subp), Loc),
7548 Parameter_Associations =>
7549 New_List (New_Occurrence_Of (Temp, Loc),
7550 New_Occurrence_Of (Loop_Id, Loc),
7551 New_Copy_Tree (Expr))));
7553 return Make_Implicit_Loop_Statement
7555 Identifier => Empty,
7556 Iteration_Scheme => L_Iteration_Scheme,
7557 Statements => Stats);
7558 end Expand_Range_Component;
7563 -- Modify the call to the constructor to allocate the
7564 -- required size for the aggregwte : call the provided
7565 -- constructor rather than the Empty aggregate.
7567 Index := Make_Op_Add (Loc,
7568 Left_Opnd => New_Copy_Tree (Type_Low_Bound (Index_Type)),
7569 Right_Opnd => Make_Integer_Literal (Loc, Siz - 1));
7571 Set_Expression (Init_Stat,
7572 Make_Function_Call (Loc,
7574 New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
7575 Parameter_Associations =>
7577 New_Copy_Tree (Type_Low_Bound (Index_Type)),
7581 if Present (Expressions (N)) then
7582 Comp := First (Expressions (N));
7584 while Present (Comp) loop
7586 -- Compute index position for successive components
7587 -- in the list of expressions, and use the indexed
7588 -- assignment procedure for each.
7590 Index := Make_Op_Add (Loc,
7591 Left_Opnd => Type_Low_Bound (Index_Type),
7592 Right_Opnd => Make_Integer_Literal (Loc, Pos));
7594 Stat := Make_Procedure_Call_Statement (Loc,
7595 Name => New_Occurrence_Of (Insert, Loc),
7596 Parameter_Associations =>
7597 New_List (New_Occurrence_Of (Temp, Loc),
7599 New_Copy_Tree (Comp)));
7603 Append (Stat, Aggr_Code);
7608 if Present (Component_Associations (N)) then
7609 Comp := First (Component_Associations (N));
7611 -- The choice may be a static value, or a range with
7614 while Present (Comp) loop
7615 if Nkind (Comp) = N_Component_Association then
7616 Key := First (Choices (Comp));
7617 while Present (Key) loop
7619 -- If the expression is a box, the corresponding
7620 -- component (s) is left uninitialized.
7622 if Box_Present (Comp) then
7625 elsif Nkind (Key) = N_Range then
7627 -- Create loop for tne specified range,
7628 -- with copies of the expression.
7631 Expand_Range_Component (Key, Expression (Comp));
7634 Stat := Make_Procedure_Call_Statement (Loc,
7635 Name => New_Occurrence_Of
7636 (Entity (Assign_Indexed_Subp), Loc),
7637 Parameter_Associations =>
7638 New_List (New_Occurrence_Of (Temp, Loc),
7639 New_Copy_Tree (Key),
7640 New_Copy_Tree (Expression (Comp))));
7643 Append (Stat, Aggr_Code);
7650 -- Iterated component association. Discard
7651 -- positional insertion procedure.
7653 Add_Named_Subp := Assign_Indexed_Subp;
7654 Add_Unnamed_Subp := Empty;
7655 Expand_Iterated_Component (Comp);
7664 Insert_Actions (N, Aggr_Code);
7665 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7666 Analyze_And_Resolve (N, Typ);
7667 end Expand_Container_Aggregate;
7669 ------------------------------
7670 -- Expand_N_Delta_Aggregate --
7671 ------------------------------
7673 procedure Expand_N_Delta_Aggregate (N : Node_Id) is
7674 Loc : constant Source_Ptr := Sloc (N);
7675 Typ : constant Entity_Id := Etype (Expression (N));
7680 Make_Object_Declaration (Loc,
7681 Defining_Identifier => Make_Temporary (Loc, 'T'),
7682 Object_Definition => New_Occurrence_Of (Typ, Loc),
7683 Expression => New_Copy_Tree (Expression (N)));
7685 if Is_Array_Type (Etype (N)) then
7686 Expand_Delta_Array_Aggregate (N, New_List (Decl));
7688 Expand_Delta_Record_Aggregate (N, New_List (Decl));
7690 end Expand_N_Delta_Aggregate;
7692 ----------------------------------
7693 -- Expand_Delta_Array_Aggregate --
7694 ----------------------------------
7696 procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id) is
7697 Loc : constant Source_Ptr := Sloc (N);
7698 Temp : constant Entity_Id := Defining_Identifier (First (Deltas));
7701 function Generate_Loop (C : Node_Id) return Node_Id;
7702 -- Generate a loop containing individual component assignments for
7703 -- choices that are ranges, subtype indications, subtype names, and
7704 -- iterated component associations.
7710 function Generate_Loop (C : Node_Id) return Node_Id is
7711 Sl : constant Source_Ptr := Sloc (C);
7715 if Nkind (Parent (C)) = N_Iterated_Component_Association then
7717 Make_Defining_Identifier (Loc,
7718 Chars => (Chars (Defining_Identifier (Parent (C)))));
7720 Ix := Make_Temporary (Sl, 'I');
7724 Make_Loop_Statement (Loc,
7726 Make_Iteration_Scheme (Sl,
7727 Loop_Parameter_Specification =>
7728 Make_Loop_Parameter_Specification (Sl,
7729 Defining_Identifier => Ix,
7730 Discrete_Subtype_Definition => New_Copy_Tree (C))),
7732 Statements => New_List (
7733 Make_Assignment_Statement (Sl,
7735 Make_Indexed_Component (Sl,
7736 Prefix => New_Occurrence_Of (Temp, Sl),
7737 Expressions => New_List (New_Occurrence_Of (Ix, Sl))),
7738 Expression => New_Copy_Tree (Expression (Assoc)))),
7739 End_Label => Empty);
7746 -- Start of processing for Expand_Delta_Array_Aggregate
7749 Assoc := First (Component_Associations (N));
7750 while Present (Assoc) loop
7751 Choice := First (Choice_List (Assoc));
7752 if Nkind (Assoc) = N_Iterated_Component_Association then
7753 while Present (Choice) loop
7754 Append_To (Deltas, Generate_Loop (Choice));
7759 while Present (Choice) loop
7761 -- Choice can be given by a range, a subtype indication, a
7762 -- subtype name, a scalar value, or an entity.
7764 if Nkind (Choice) = N_Range
7765 or else (Is_Entity_Name (Choice)
7766 and then Is_Type (Entity (Choice)))
7768 Append_To (Deltas, Generate_Loop (Choice));
7770 elsif Nkind (Choice) = N_Subtype_Indication then
7772 Generate_Loop (Range_Expression (Constraint (Choice))));
7776 Make_Assignment_Statement (Sloc (Choice),
7778 Make_Indexed_Component (Sloc (Choice),
7779 Prefix => New_Occurrence_Of (Temp, Loc),
7780 Expressions => New_List (New_Copy_Tree (Choice))),
7781 Expression => New_Copy_Tree (Expression (Assoc))));
7791 Insert_Actions (N, Deltas);
7792 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7793 end Expand_Delta_Array_Aggregate;
7795 -----------------------------------
7796 -- Expand_Delta_Record_Aggregate --
7797 -----------------------------------
7799 procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id) is
7800 Loc : constant Source_Ptr := Sloc (N);
7801 Temp : constant Entity_Id := Defining_Identifier (First (Deltas));
7806 Assoc := First (Component_Associations (N));
7808 while Present (Assoc) loop
7809 Choice := First (Choice_List (Assoc));
7810 while Present (Choice) loop
7812 Make_Assignment_Statement (Sloc (Choice),
7814 Make_Selected_Component (Sloc (Choice),
7815 Prefix => New_Occurrence_Of (Temp, Loc),
7816 Selector_Name => Make_Identifier (Loc, Chars (Choice))),
7817 Expression => New_Copy_Tree (Expression (Assoc))));
7824 Insert_Actions (N, Deltas);
7825 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7826 end Expand_Delta_Record_Aggregate;
7828 ----------------------------------
7829 -- Expand_N_Extension_Aggregate --
7830 ----------------------------------
7832 -- If the ancestor part is an expression, add a component association for
7833 -- the parent field. If the type of the ancestor part is not the direct
7834 -- parent of the expected type, build recursively the needed ancestors.
7835 -- If the ancestor part is a subtype_mark, replace aggregate with a
7836 -- declaration for a temporary of the expected type, followed by
7837 -- individual assignments to the given components.
7839 procedure Expand_N_Extension_Aggregate (N : Node_Id) is
7840 A : constant Node_Id := Ancestor_Part (N);
7841 Loc : constant Source_Ptr := Sloc (N);
7842 Typ : constant Entity_Id := Etype (N);
7845 -- If the ancestor is a subtype mark, an init proc must be called
7846 -- on the resulting object which thus has to be materialized in
7849 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
7850 Convert_To_Assignments (N, Typ);
7852 -- The extension aggregate is transformed into a record aggregate
7853 -- of the following form (c1 and c2 are inherited components)
7855 -- (Exp with c3 => a, c4 => b)
7856 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c3 => a, c4 => b)
7861 if Tagged_Type_Expansion then
7862 Expand_Record_Aggregate (N,
7865 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc),
7868 -- No tag is needed in the case of a VM
7871 Expand_Record_Aggregate (N, Parent_Expr => A);
7876 when RE_Not_Available =>
7878 end Expand_N_Extension_Aggregate;
7880 -----------------------------
7881 -- Expand_Record_Aggregate --
7882 -----------------------------
7884 procedure Expand_Record_Aggregate
7886 Orig_Tag : Node_Id := Empty;
7887 Parent_Expr : Node_Id := Empty)
7889 Loc : constant Source_Ptr := Sloc (N);
7890 Comps : constant List_Id := Component_Associations (N);
7891 Typ : constant Entity_Id := Etype (N);
7892 Base_Typ : constant Entity_Id := Base_Type (Typ);
7894 Static_Components : Boolean := True;
7895 -- Flag to indicate whether all components are compile-time known,
7896 -- and the aggregate can be constructed statically and handled by
7897 -- the back-end. Set to False by Component_OK_For_Backend.
7899 procedure Build_Back_End_Aggregate;
7900 -- Build a proper aggregate to be handled by the back-end
7902 function Compile_Time_Known_Composite_Value (N : Node_Id) return Boolean;
7903 -- Returns true if N is an expression of composite type which can be
7904 -- fully evaluated at compile time without raising constraint error.
7905 -- Such expressions can be passed as is to Gigi without any expansion.
7907 -- This returns true for N_Aggregate with Compile_Time_Known_Aggregate
7908 -- set and constants whose expression is such an aggregate, recursively.
7910 function Component_OK_For_Backend return Boolean;
7911 -- Check for presence of a component which makes it impossible for the
7912 -- backend to process the aggregate, thus requiring the use of a series
7913 -- of assignment statements. Cases checked for are a nested aggregate
7914 -- needing Late_Expansion, the presence of a tagged component which may
7915 -- need tag adjustment, and a bit unaligned component reference.
7917 -- We also force expansion into assignments if a component is of a
7918 -- mutable type (including a private type with discriminants) because
7919 -- in that case the size of the component to be copied may be smaller
7920 -- than the side of the target, and there is no simple way for gigi
7921 -- to compute the size of the object to be copied.
7923 -- NOTE: This is part of the ongoing work to define precisely the
7924 -- interface between front-end and back-end handling of aggregates.
7925 -- In general it is desirable to pass aggregates as they are to gigi,
7926 -- in order to minimize elaboration code. This is one case where the
7927 -- semantics of Ada complicate the analysis and lead to anomalies in
7928 -- the gcc back-end if the aggregate is not expanded into assignments.
7930 -- NOTE: This sets the global Static_Components to False in most, but
7931 -- not all, cases when it returns False.
7933 function Has_Per_Object_Constraint (L : List_Id) return Boolean;
7934 -- Return True if any element of L has Has_Per_Object_Constraint set.
7935 -- L should be the Choices component of an N_Component_Association.
7937 function Has_Visible_Private_Ancestor (Id : E) return Boolean;
7938 -- If any ancestor of the current type is private, the aggregate
7939 -- cannot be built in place. We cannot rely on Has_Private_Ancestor,
7940 -- because it will not be set when type and its parent are in the
7941 -- same scope, and the parent component needs expansion.
7943 function Top_Level_Aggregate (N : Node_Id) return Node_Id;
7944 -- For nested aggregates return the ultimate enclosing aggregate; for
7945 -- non-nested aggregates return N.
7947 ------------------------------
7948 -- Build_Back_End_Aggregate --
7949 ------------------------------
7951 procedure Build_Back_End_Aggregate is
7954 Tag_Value : Node_Id;
7957 if Nkind (N) = N_Aggregate then
7959 -- If the aggregate is static and can be handled by the back-end,
7960 -- nothing left to do.
7962 if Static_Components then
7963 Set_Compile_Time_Known_Aggregate (N);
7964 Set_Expansion_Delayed (N, False);
7968 -- If no discriminants, nothing special to do
7970 if not Has_Discriminants (Typ) then
7973 -- Case of discriminants present
7975 elsif Is_Derived_Type (Typ) then
7977 -- For untagged types, non-stored discriminants are replaced with
7978 -- stored discriminants, which are the ones that gigi uses to
7979 -- describe the type and its components.
7981 Generate_Aggregate_For_Derived_Type : declare
7982 procedure Prepend_Stored_Values (T : Entity_Id);
7983 -- Scan the list of stored discriminants of the type, and add
7984 -- their values to the aggregate being built.
7986 ---------------------------
7987 -- Prepend_Stored_Values --
7988 ---------------------------
7990 procedure Prepend_Stored_Values (T : Entity_Id) is
7992 First_Comp : Node_Id := Empty;
7995 Discr := First_Stored_Discriminant (T);
7996 while Present (Discr) loop
7998 Make_Component_Association (Loc,
7999 Choices => New_List (
8000 New_Occurrence_Of (Discr, Loc)),
8003 (Get_Discriminant_Value
8006 Discriminant_Constraint (Typ))));
8008 if No (First_Comp) then
8009 Prepend_To (Component_Associations (N), New_Comp);
8011 Insert_After (First_Comp, New_Comp);
8014 First_Comp := New_Comp;
8015 Next_Stored_Discriminant (Discr);
8017 end Prepend_Stored_Values;
8021 Constraints : constant List_Id := New_List;
8025 Num_Disc : Nat := 0;
8026 Num_Gird : Nat := 0;
8028 -- Start of processing for Generate_Aggregate_For_Derived_Type
8031 -- Remove the associations for the discriminant of derived type
8034 First_Comp : Node_Id;
8037 First_Comp := First (Component_Associations (N));
8038 while Present (First_Comp) loop
8042 if Ekind (Entity (First (Choices (Comp)))) =
8046 Num_Disc := Num_Disc + 1;
8051 -- Insert stored discriminant associations in the correct
8052 -- order. If there are more stored discriminants than new
8053 -- discriminants, there is at least one new discriminant that
8054 -- constrains more than one of the stored discriminants. In
8055 -- this case we need to construct a proper subtype of the
8056 -- parent type, in order to supply values to all the
8057 -- components. Otherwise there is one-one correspondence
8058 -- between the constraints and the stored discriminants.
8060 Discr := First_Stored_Discriminant (Base_Type (Typ));
8061 while Present (Discr) loop
8062 Num_Gird := Num_Gird + 1;
8063 Next_Stored_Discriminant (Discr);
8066 -- Case of more stored discriminants than new discriminants
8068 if Num_Gird > Num_Disc then
8070 -- Create a proper subtype of the parent type, which is the
8071 -- proper implementation type for the aggregate, and convert
8072 -- it to the intended target type.
8074 Discr := First_Stored_Discriminant (Base_Type (Typ));
8075 while Present (Discr) loop
8078 (Get_Discriminant_Value
8081 Discriminant_Constraint (Typ)));
8083 Append (New_Comp, Constraints);
8084 Next_Stored_Discriminant (Discr);
8088 Make_Subtype_Declaration (Loc,
8089 Defining_Identifier => Make_Temporary (Loc, 'T'),
8090 Subtype_Indication =>
8091 Make_Subtype_Indication (Loc,
8093 New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
8095 Make_Index_Or_Discriminant_Constraint
8096 (Loc, Constraints)));
8098 Insert_Action (N, Decl);
8099 Prepend_Stored_Values (Base_Type (Typ));
8101 Set_Etype (N, Defining_Identifier (Decl));
8104 Rewrite (N, Unchecked_Convert_To (Typ, N));
8107 -- Case where we do not have fewer new discriminants than
8108 -- stored discriminants, so in this case we can simply use the
8109 -- stored discriminants of the subtype.
8112 Prepend_Stored_Values (Typ);
8114 end Generate_Aggregate_For_Derived_Type;
8117 if Is_Tagged_Type (Typ) then
8119 -- In the tagged case, _parent and _tag component must be created
8121 -- Reset Null_Present unconditionally. Tagged records always have
8122 -- at least one field (the tag or the parent).
8124 Set_Null_Record_Present (N, False);
8126 -- When the current aggregate comes from the expansion of an
8127 -- extension aggregate, the parent expr is replaced by an
8128 -- aggregate formed by selected components of this expr.
8130 if Present (Parent_Expr) and then Is_Empty_List (Comps) then
8131 Comp := First_Component_Or_Discriminant (Typ);
8132 while Present (Comp) loop
8134 -- Skip all expander-generated components
8136 if not Comes_From_Source (Original_Record_Component (Comp))
8142 Make_Selected_Component (Loc,
8144 Unchecked_Convert_To (Typ,
8145 Duplicate_Subexpr (Parent_Expr, True)),
8146 Selector_Name => New_Occurrence_Of (Comp, Loc));
8149 Make_Component_Association (Loc,
8150 Choices => New_List (
8151 New_Occurrence_Of (Comp, Loc)),
8152 Expression => New_Comp));
8154 Analyze_And_Resolve (New_Comp, Etype (Comp));
8157 Next_Component_Or_Discriminant (Comp);
8161 -- Compute the value for the Tag now, if the type is a root it
8162 -- will be included in the aggregate right away, otherwise it will
8163 -- be propagated to the parent aggregate.
8165 if Present (Orig_Tag) then
8166 Tag_Value := Orig_Tag;
8168 elsif not Tagged_Type_Expansion then
8174 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
8177 -- For a derived type, an aggregate for the parent is formed with
8178 -- all the inherited components.
8180 if Is_Derived_Type (Typ) then
8182 First_Comp : Node_Id;
8183 Parent_Comps : List_Id;
8184 Parent_Aggr : Node_Id;
8185 Parent_Name : Node_Id;
8188 -- Remove the inherited component association from the
8189 -- aggregate and store them in the parent aggregate
8191 First_Comp := First (Component_Associations (N));
8192 Parent_Comps := New_List;
8193 while Present (First_Comp)
8195 Scope (Original_Record_Component
8196 (Entity (First (Choices (First_Comp))))) /=
8202 Append (Comp, Parent_Comps);
8206 Make_Aggregate (Loc,
8207 Component_Associations => Parent_Comps);
8208 Set_Etype (Parent_Aggr, Etype (Base_Type (Typ)));
8210 -- Find the _parent component
8212 Comp := First_Component (Typ);
8213 while Chars (Comp) /= Name_uParent loop
8214 Next_Component (Comp);
8217 Parent_Name := New_Occurrence_Of (Comp, Loc);
8219 -- Insert the parent aggregate
8221 Prepend_To (Component_Associations (N),
8222 Make_Component_Association (Loc,
8223 Choices => New_List (Parent_Name),
8224 Expression => Parent_Aggr));
8226 -- Expand recursively the parent propagating the right Tag
8228 Expand_Record_Aggregate
8229 (Parent_Aggr, Tag_Value, Parent_Expr);
8231 -- The ancestor part may be a nested aggregate that has
8232 -- delayed expansion: recheck now.
8234 if not Component_OK_For_Backend then
8235 Convert_To_Assignments (N, Typ);
8239 -- For a root type, the tag component is added (unless compiling
8240 -- for the VMs, where tags are implicit).
8242 elsif Tagged_Type_Expansion then
8244 Tag_Name : constant Node_Id :=
8246 (First_Tag_Component (Typ), Loc);
8247 Typ_Tag : constant Entity_Id := RTE (RE_Tag);
8248 Conv_Node : constant Node_Id :=
8249 Unchecked_Convert_To (Typ_Tag, Tag_Value);
8252 Set_Etype (Conv_Node, Typ_Tag);
8253 Prepend_To (Component_Associations (N),
8254 Make_Component_Association (Loc,
8255 Choices => New_List (Tag_Name),
8256 Expression => Conv_Node));
8260 end Build_Back_End_Aggregate;
8262 ----------------------------------------
8263 -- Compile_Time_Known_Composite_Value --
8264 ----------------------------------------
8266 function Compile_Time_Known_Composite_Value
8267 (N : Node_Id) return Boolean
8270 -- If we have an entity name, then see if it is the name of a
8271 -- constant and if so, test the corresponding constant value.
8273 if Is_Entity_Name (N) then
8275 E : constant Entity_Id := Entity (N);
8278 if Ekind (E) /= E_Constant then
8281 V := Constant_Value (E);
8283 and then Compile_Time_Known_Composite_Value (V);
8287 -- We have a value, see if it is compile time known
8290 if Nkind (N) = N_Aggregate then
8291 return Compile_Time_Known_Aggregate (N);
8294 -- All other types of values are not known at compile time
8299 end Compile_Time_Known_Composite_Value;
8301 ------------------------------
8302 -- Component_OK_For_Backend --
8303 ------------------------------
8305 function Component_OK_For_Backend return Boolean is
8315 while Present (C) loop
8317 -- If the component has box initialization, expansion is needed
8318 -- and component is not ready for backend.
8320 if Box_Present (C) then
8324 if Nkind (Expression (C)) = N_Qualified_Expression then
8325 Expr_Q := Expression (Expression (C));
8327 Expr_Q := Expression (C);
8330 -- Return False for array components whose bounds raise
8331 -- constraint error.
8334 Comp : constant Entity_Id := First (Choices (C));
8338 if Present (Etype (Comp))
8339 and then Is_Array_Type (Etype (Comp))
8341 Indx := First_Index (Etype (Comp));
8342 while Present (Indx) loop
8343 if Nkind (Type_Low_Bound (Etype (Indx))) =
8344 N_Raise_Constraint_Error
8345 or else Nkind (Type_High_Bound (Etype (Indx))) =
8346 N_Raise_Constraint_Error
8356 -- Return False if the aggregate has any associations for tagged
8357 -- components that may require tag adjustment.
8359 -- These are cases where the source expression may have a tag that
8360 -- could differ from the component tag (e.g., can occur for type
8361 -- conversions and formal parameters). (Tag adjustment not needed
8362 -- if Tagged_Type_Expansion because object tags are implicit in
8365 if Is_Tagged_Type (Etype (Expr_Q))
8367 (Nkind (Expr_Q) = N_Type_Conversion
8369 (Is_Entity_Name (Expr_Q)
8370 and then Is_Formal (Entity (Expr_Q))))
8371 and then Tagged_Type_Expansion
8373 Static_Components := False;
8376 elsif Is_Delayed_Aggregate (Expr_Q) then
8377 Static_Components := False;
8380 elsif Nkind (Expr_Q) = N_Quantified_Expression then
8381 Static_Components := False;
8384 elsif Possible_Bit_Aligned_Component (Expr_Q) then
8385 Static_Components := False;
8388 elsif Modify_Tree_For_C
8389 and then Nkind (C) = N_Component_Association
8390 and then Has_Per_Object_Constraint (Choices (C))
8392 Static_Components := False;
8395 elsif Modify_Tree_For_C
8396 and then Nkind (Expr_Q) = N_Identifier
8397 and then Is_Array_Type (Etype (Expr_Q))
8399 Static_Components := False;
8402 elsif Modify_Tree_For_C
8403 and then Nkind (Expr_Q) = N_Type_Conversion
8404 and then Is_Array_Type (Etype (Expr_Q))
8406 Static_Components := False;
8410 if Is_Elementary_Type (Etype (Expr_Q)) then
8411 if not Compile_Time_Known_Value (Expr_Q) then
8412 Static_Components := False;
8415 elsif not Compile_Time_Known_Composite_Value (Expr_Q) then
8416 Static_Components := False;
8418 if Is_Private_Type (Etype (Expr_Q))
8419 and then Has_Discriminants (Etype (Expr_Q))
8429 end Component_OK_For_Backend;
8431 -------------------------------
8432 -- Has_Per_Object_Constraint --
8433 -------------------------------
8435 function Has_Per_Object_Constraint (L : List_Id) return Boolean is
8436 N : Node_Id := First (L);
8438 while Present (N) loop
8439 if Is_Entity_Name (N)
8440 and then Present (Entity (N))
8441 and then Has_Per_Object_Constraint (Entity (N))
8450 end Has_Per_Object_Constraint;
8452 -----------------------------------
8453 -- Has_Visible_Private_Ancestor --
8454 -----------------------------------
8456 function Has_Visible_Private_Ancestor (Id : E) return Boolean is
8457 R : constant Entity_Id := Root_Type (Id);
8458 T1 : Entity_Id := Id;
8462 if Is_Private_Type (T1) then
8472 end Has_Visible_Private_Ancestor;
8474 -------------------------
8475 -- Top_Level_Aggregate --
8476 -------------------------
8478 function Top_Level_Aggregate (N : Node_Id) return Node_Id is
8483 while Present (Parent (Aggr))
8484 and then Nkind (Parent (Aggr)) in
8485 N_Aggregate | N_Component_Association
8487 Aggr := Parent (Aggr);
8491 end Top_Level_Aggregate;
8495 Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N);
8497 -- Start of processing for Expand_Record_Aggregate
8500 -- If the aggregate is to be assigned to a full access variable, we have
8501 -- to prevent a piecemeal assignment even if the aggregate is to be
8502 -- expanded. We create a temporary for the aggregate, and assign the
8503 -- temporary instead, so that the back end can generate an atomic move
8506 if Is_Full_Access_Aggregate (N) then
8509 -- No special management required for aggregates used to initialize
8510 -- statically allocated dispatch tables
8512 elsif Is_Static_Dispatch_Table_Aggregate (N) then
8516 -- If the pragma Aggregate_Individually_Assign is set, always convert to
8519 if Aggregate_Individually_Assign then
8520 Convert_To_Assignments (N, Typ);
8522 -- Ada 2005 (AI-318-2): We need to convert to assignments if components
8523 -- are build-in-place function calls. The assignments will each turn
8524 -- into a build-in-place function call. If components are all static,
8525 -- we can pass the aggregate to the back end regardless of limitedness.
8527 -- Extension aggregates, aggregates in extended return statements, and
8528 -- aggregates for C++ imported types must be expanded.
8530 elsif Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
8531 if Nkind (Parent (N)) not in
8532 N_Component_Association | N_Object_Declaration
8534 Convert_To_Assignments (N, Typ);
8536 elsif Nkind (N) = N_Extension_Aggregate
8537 or else Convention (Typ) = Convention_CPP
8539 Convert_To_Assignments (N, Typ);
8541 elsif not Size_Known_At_Compile_Time (Typ)
8542 or else not Component_OK_For_Backend
8543 or else not Static_Components
8545 Convert_To_Assignments (N, Typ);
8547 -- In all other cases, build a proper aggregate to be handled by
8551 Build_Back_End_Aggregate;
8554 -- Gigi doesn't properly handle temporaries of variable size so we
8555 -- generate it in the front-end
8557 elsif not Size_Known_At_Compile_Time (Typ)
8558 and then Tagged_Type_Expansion
8560 Convert_To_Assignments (N, Typ);
8562 -- An aggregate used to initialize a controlled object must be turned
8563 -- into component assignments as the components themselves may require
8564 -- finalization actions such as adjustment.
8566 elsif Needs_Finalization (Typ) then
8567 Convert_To_Assignments (N, Typ);
8569 -- Ada 2005 (AI-287): In case of default initialized components we
8570 -- convert the aggregate into assignments.
8572 elsif Has_Default_Init_Comps (N) then
8573 Convert_To_Assignments (N, Typ);
8577 elsif not Component_OK_For_Backend then
8578 Convert_To_Assignments (N, Typ);
8580 -- If an ancestor is private, some components are not inherited and we
8581 -- cannot expand into a record aggregate.
8583 elsif Has_Visible_Private_Ancestor (Typ) then
8584 Convert_To_Assignments (N, Typ);
8586 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
8587 -- is not able to handle the aggregate for Late_Request.
8589 elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
8590 Convert_To_Assignments (N, Typ);
8592 -- If the tagged types covers interface types we need to initialize all
8593 -- hidden components containing pointers to secondary dispatch tables.
8595 elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then
8596 Convert_To_Assignments (N, Typ);
8598 -- If some components are mutable, the size of the aggregate component
8599 -- may be distinct from the default size of the type component, so
8600 -- we need to expand to insure that the back-end copies the proper
8601 -- size of the data. However, if the aggregate is the initial value of
8602 -- a constant, the target is immutable and might be built statically
8603 -- if components are appropriate.
8605 elsif Has_Mutable_Components (Typ)
8607 (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration
8608 or else not Constant_Present (Parent (Top_Level_Aggr))
8609 or else not Static_Components)
8611 Convert_To_Assignments (N, Typ);
8613 -- If the type involved has bit aligned components, then we are not sure
8614 -- that the back end can handle this case correctly.
8616 elsif Type_May_Have_Bit_Aligned_Components (Typ) then
8617 Convert_To_Assignments (N, Typ);
8619 -- When generating C, only generate an aggregate when declaring objects
8620 -- since C does not support aggregates in e.g. assignment statements.
8622 elsif Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
8623 Convert_To_Assignments (N, Typ);
8625 -- In all other cases, build a proper aggregate to be handled by gigi
8628 Build_Back_End_Aggregate;
8630 end Expand_Record_Aggregate;
8632 ---------------------
8633 -- Get_Base_Object --
8634 ---------------------
8636 function Get_Base_Object (N : Node_Id) return Entity_Id is
8640 R := Get_Referenced_Object (N);
8642 while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice
8644 R := Get_Referenced_Object (Prefix (R));
8647 if Is_Entity_Name (R) and then Is_Object (Entity (R)) then
8652 end Get_Base_Object;
8654 ----------------------------
8655 -- Has_Default_Init_Comps --
8656 ----------------------------
8658 function Has_Default_Init_Comps (N : Node_Id) return Boolean is
8659 Comps : constant List_Id := Component_Associations (N);
8664 pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate);
8670 if Has_Self_Reference (N) then
8674 -- Check if any direct component has default initialized components
8677 while Present (C) loop
8678 if Box_Present (C) then
8685 -- Recursive call in case of aggregate expression
8688 while Present (C) loop
8689 Expr := Expression (C);
8692 and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
8693 and then Has_Default_Init_Comps (Expr)
8702 end Has_Default_Init_Comps;
8704 ----------------------------------------
8705 -- Is_Build_In_Place_Aggregate_Return --
8706 ----------------------------------------
8708 function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is
8709 P : Node_Id := Parent (N);
8712 while Nkind (P) = N_Qualified_Expression loop
8716 if Nkind (P) = N_Simple_Return_Statement then
8719 elsif Nkind (Parent (P)) = N_Extended_Return_Statement then
8727 Is_Build_In_Place_Function
8728 (Return_Applies_To (Return_Statement_Entity (P)));
8729 end Is_Build_In_Place_Aggregate_Return;
8731 --------------------------
8732 -- Is_Delayed_Aggregate --
8733 --------------------------
8735 function Is_Delayed_Aggregate (N : Node_Id) return Boolean is
8736 Node : Node_Id := N;
8737 Kind : Node_Kind := Nkind (Node);
8740 if Kind = N_Qualified_Expression then
8741 Node := Expression (Node);
8742 Kind := Nkind (Node);
8745 if Kind not in N_Aggregate | N_Extension_Aggregate then
8748 return Expansion_Delayed (Node);
8750 end Is_Delayed_Aggregate;
8752 --------------------------------
8753 -- Is_CCG_Supported_Aggregate --
8754 --------------------------------
8756 function Is_CCG_Supported_Aggregate
8757 (N : Node_Id) return Boolean
8759 P : Node_Id := Parent (N);
8762 -- Aggregates are not supported for nonstandard rep clauses, since they
8763 -- may lead to extra padding fields in CCG.
8765 if Is_Record_Type (Etype (N))
8766 and then Has_Non_Standard_Rep (Etype (N))
8771 while Present (P) and then Nkind (P) = N_Aggregate loop
8775 -- Check cases where aggregates are supported by the CCG backend
8777 if Nkind (P) = N_Object_Declaration then
8779 P_Typ : constant Entity_Id := Etype (Defining_Identifier (P));
8782 if Is_Record_Type (P_Typ) then
8785 return Compile_Time_Known_Bounds (P_Typ);
8789 elsif Nkind (P) = N_Qualified_Expression then
8790 if Nkind (Parent (P)) = N_Object_Declaration then
8792 P_Typ : constant Entity_Id :=
8793 Etype (Defining_Identifier (Parent (P)));
8795 if Is_Record_Type (P_Typ) then
8798 return Compile_Time_Known_Bounds (P_Typ);
8802 elsif Nkind (Parent (P)) = N_Allocator then
8808 end Is_CCG_Supported_Aggregate;
8810 ----------------------------------------
8811 -- Is_Static_Dispatch_Table_Aggregate --
8812 ----------------------------------------
8814 function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean is
8815 Typ : constant Entity_Id := Base_Type (Etype (N));
8818 return Building_Static_Dispatch_Tables
8819 and then Tagged_Type_Expansion
8821 -- Avoid circularity when rebuilding the compiler
8823 and then not Is_RTU (Cunit_Entity (Get_Source_Unit (N)), Ada_Tags)
8824 and then (Is_RTE (Typ, RE_Dispatch_Table_Wrapper)
8826 Is_RTE (Typ, RE_Address_Array)
8828 Is_RTE (Typ, RE_Type_Specific_Data)
8830 Is_RTE (Typ, RE_Tag_Table)
8832 Is_RTE (Typ, RE_Object_Specific_Data)
8834 Is_RTE (Typ, RE_Interface_Data)
8836 Is_RTE (Typ, RE_Interfaces_Array)
8838 Is_RTE (Typ, RE_Interface_Data_Element));
8839 end Is_Static_Dispatch_Table_Aggregate;
8841 -----------------------------
8842 -- Is_Two_Dim_Packed_Array --
8843 -----------------------------
8845 function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean is
8846 C : constant Int := UI_To_Int (Component_Size (Typ));
8848 return Number_Dimensions (Typ) = 2
8849 and then Is_Bit_Packed_Array (Typ)
8850 and then (C = 1 or else C = 2 or else C = 4);
8851 end Is_Two_Dim_Packed_Array;
8853 --------------------
8854 -- Late_Expansion --
8855 --------------------
8857 function Late_Expansion
8860 Target : Node_Id) return List_Id
8862 Aggr_Code : List_Id;
8866 if Is_Array_Type (Typ) then
8867 -- If the assignment can be done directly by the back end, then
8868 -- reset Set_Expansion_Delayed and do not expand further.
8870 if not CodePeer_Mode
8871 and then not Modify_Tree_For_C
8872 and then not Possible_Bit_Aligned_Component (Target)
8873 and then not Is_Possibly_Unaligned_Slice (Target)
8874 and then Aggr_Assignment_OK_For_Backend (N)
8876 New_Aggr := New_Copy_Tree (N);
8877 Set_Expansion_Delayed (New_Aggr, False);
8881 Make_OK_Assignment_Statement (Sloc (New_Aggr),
8883 Expression => New_Aggr));
8885 -- Or else, generate component assignments to it
8889 Build_Array_Aggr_Code
8891 Ctype => Component_Type (Typ),
8892 Index => First_Index (Typ),
8894 Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
8895 Indexes => No_List);
8898 -- Directly or indirectly (e.g. access protected procedure) a record
8901 Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target);
8904 -- Save the last assignment statement associated with the aggregate
8905 -- when building a controlled object. This reference is utilized by
8906 -- the finalization machinery when marking an object as successfully
8909 if Needs_Finalization (Typ)
8910 and then Is_Entity_Name (Target)
8911 and then Present (Entity (Target))
8912 and then Ekind (Entity (Target)) in E_Constant | E_Variable
8914 Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
8920 ----------------------------------
8921 -- Make_OK_Assignment_Statement --
8922 ----------------------------------
8924 function Make_OK_Assignment_Statement
8927 Expression : Node_Id) return Node_Id
8930 Set_Assignment_OK (Name);
8931 return Make_Assignment_Statement (Sloc, Name, Expression);
8932 end Make_OK_Assignment_Statement;
8934 ------------------------
8935 -- Max_Aggregate_Size --
8936 ------------------------
8938 function Max_Aggregate_Size
8940 Default_Size : Nat := 5000) return Nat
8942 function Use_Small_Size (N : Node_Id) return Boolean;
8943 -- True if we should return a very small size, which means large
8944 -- aggregates will be implemented as a loop when possible (potentially
8945 -- transformed to memset calls).
8947 function Aggr_Context (N : Node_Id) return Node_Id;
8948 -- Return the context in which the aggregate appears, not counting
8949 -- qualified expressions and similar.
8955 function Aggr_Context (N : Node_Id) return Node_Id is
8956 Result : Node_Id := Parent (N);
8958 if Nkind (Result) in N_Qualified_Expression
8960 | N_Unchecked_Type_Conversion
8963 | N_Component_Association
8966 Result := Aggr_Context (Result);
8972 --------------------
8973 -- Use_Small_Size --
8974 --------------------
8976 function Use_Small_Size (N : Node_Id) return Boolean is
8977 C : constant Node_Id := Aggr_Context (N);
8978 -- The decision depends on the context in which the aggregate occurs,
8979 -- and for variable declarations, whether we are nested inside a
8983 -- True for assignment statements and similar
8985 when N_Assignment_Statement
8986 | N_Simple_Return_Statement
8988 | N_Attribute_Reference
8992 -- True for nested variable declarations. False for library level
8993 -- variables, and for constants (whether or not nested).
8995 when N_Object_Declaration =>
8996 return not Constant_Present (C)
8997 and then Ekind (Current_Scope) in Subprogram_Kind;
8999 -- False for all other contexts
9008 Typ : constant Entity_Id := Etype (N);
9010 -- Start of processing for Max_Aggregate_Size
9013 -- We use a small limit in CodePeer mode where we favor loops instead of
9014 -- thousands of single assignments (from large aggregates).
9016 -- We also increase the limit to 2**24 (about 16 million) if
9017 -- Restrictions (No_Elaboration_Code) or Restrictions
9018 -- (No_Implicit_Loops) is specified, since in either case we are at risk
9019 -- of declaring the program illegal because of this limit. We also
9020 -- increase the limit when Static_Elaboration_Desired, given that this
9021 -- means that objects are intended to be placed in data memory.
9023 -- Same if the aggregate is for a packed two-dimensional array, because
9024 -- if components are static it is much more efficient to construct a
9025 -- one-dimensional equivalent array with static components.
9027 if CodePeer_Mode then
9029 elsif Restriction_Active (No_Elaboration_Code)
9030 or else Restriction_Active (No_Implicit_Loops)
9031 or else Is_Two_Dim_Packed_Array (Typ)
9032 or else (Ekind (Current_Scope) = E_Package
9033 and then Static_Elaboration_Desired (Current_Scope))
9036 elsif Use_Small_Size (N) then
9040 return Default_Size;
9041 end Max_Aggregate_Size;
9043 -----------------------
9044 -- Number_Of_Choices --
9045 -----------------------
9047 function Number_Of_Choices (N : Node_Id) return Nat is
9051 Nb_Choices : Nat := 0;
9054 if Present (Expressions (N)) then
9058 Assoc := First (Component_Associations (N));
9059 while Present (Assoc) loop
9060 Choice := First (Choice_List (Assoc));
9061 while Present (Choice) loop
9062 if Nkind (Choice) /= N_Others_Choice then
9063 Nb_Choices := Nb_Choices + 1;
9073 end Number_Of_Choices;
9075 ------------------------------------
9076 -- Packed_Array_Aggregate_Handled --
9077 ------------------------------------
9079 -- The current version of this procedure will handle at compile time
9080 -- any array aggregate that meets these conditions:
9082 -- One and two dimensional, bit packed
9083 -- Underlying packed type is modular type
9084 -- Bounds are within 32-bit Int range
9085 -- All bounds and values are static
9087 -- Note: for now, in the 2-D case, we only handle component sizes of
9088 -- 1, 2, 4 (cases where an integral number of elements occupies a byte).
9090 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is
9091 Loc : constant Source_Ptr := Sloc (N);
9092 Typ : constant Entity_Id := Etype (N);
9093 Ctyp : constant Entity_Id := Component_Type (Typ);
9095 Not_Handled : exception;
9096 -- Exception raised if this aggregate cannot be handled
9099 -- Handle one- or two dimensional bit packed array
9101 if not Is_Bit_Packed_Array (Typ)
9102 or else Number_Dimensions (Typ) > 2
9107 -- If two-dimensional, check whether it can be folded, and transformed
9108 -- into a one-dimensional aggregate for the Packed_Array_Impl_Type of
9109 -- the original type.
9111 if Number_Dimensions (Typ) = 2 then
9112 return Two_Dim_Packed_Array_Handled (N);
9115 if not Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)) then
9119 if not Is_Scalar_Type (Ctyp) then
9124 Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
9128 -- Bounds of index type
9132 -- Values of bounds if compile time known
9134 function Get_Component_Val (N : Node_Id) return Uint;
9135 -- Given a expression value N of the component type Ctyp, returns a
9136 -- value of Csiz (component size) bits representing this value. If
9137 -- the value is nonstatic or any other reason exists why the value
9138 -- cannot be returned, then Not_Handled is raised.
9140 -----------------------
9141 -- Get_Component_Val --
9142 -----------------------
9144 function Get_Component_Val (N : Node_Id) return Uint is
9148 -- We have to analyze the expression here before doing any further
9149 -- processing here. The analysis of such expressions is deferred
9150 -- till expansion to prevent some problems of premature analysis.
9152 Analyze_And_Resolve (N, Ctyp);
9154 -- Must have a compile time value. String literals have to be
9155 -- converted into temporaries as well, because they cannot easily
9156 -- be converted into their bit representation.
9158 if not Compile_Time_Known_Value (N)
9159 or else Nkind (N) = N_String_Literal
9164 Val := Expr_Rep_Value (N);
9166 -- Adjust for bias, and strip proper number of bits
9168 if Has_Biased_Representation (Ctyp) then
9169 Val := Val - Expr_Value (Type_Low_Bound (Ctyp));
9172 return Val mod Uint_2 ** Csiz;
9173 end Get_Component_Val;
9175 -- Here we know we have a one dimensional bit packed array
9178 Get_Index_Bounds (First_Index (Typ), Lo, Hi);
9180 -- Cannot do anything if bounds are dynamic
9182 if not Compile_Time_Known_Value (Lo)
9184 not Compile_Time_Known_Value (Hi)
9189 -- Or are silly out of range of int bounds
9191 Lob := Expr_Value (Lo);
9192 Hib := Expr_Value (Hi);
9194 if not UI_Is_In_Int_Range (Lob)
9196 not UI_Is_In_Int_Range (Hib)
9201 -- At this stage we have a suitable aggregate for handling at compile
9202 -- time. The only remaining checks are that the values of expressions
9203 -- in the aggregate are compile-time known (checks are performed by
9204 -- Get_Component_Val), and that any subtypes or ranges are statically
9207 -- If the aggregate is not fully positional at this stage, then
9208 -- convert it to positional form. Either this will fail, in which
9209 -- case we can do nothing, or it will succeed, in which case we have
9210 -- succeeded in handling the aggregate and transforming it into a
9211 -- modular value, or it will stay an aggregate, in which case we
9212 -- have failed to create a packed value for it.
9214 if Present (Component_Associations (N)) then
9215 Convert_To_Positional (N, Handle_Bit_Packed => True);
9216 return Nkind (N) /= N_Aggregate;
9219 -- Otherwise we are all positional, so convert to proper value
9222 Lov : constant Int := UI_To_Int (Lob);
9223 Hiv : constant Int := UI_To_Int (Hib);
9225 Len : constant Nat := Int'Max (0, Hiv - Lov + 1);
9226 -- The length of the array (number of elements)
9228 Aggregate_Val : Uint;
9229 -- Value of aggregate. The value is set in the low order bits of
9230 -- this value. For the little-endian case, the values are stored
9231 -- from low-order to high-order and for the big-endian case the
9232 -- values are stored from high-order to low-order. Note that gigi
9233 -- will take care of the conversions to left justify the value in
9234 -- the big endian case (because of left justified modular type
9235 -- processing), so we do not have to worry about that here.
9238 -- Integer literal for resulting constructed value
9241 -- Shift count from low order for next value
9244 -- Shift increment for loop
9247 -- Next expression from positional parameters of aggregate
9249 Left_Justified : Boolean;
9250 -- Set True if we are filling the high order bits of the target
9251 -- value (i.e. the value is left justified).
9254 -- For little endian, we fill up the low order bits of the target
9255 -- value. For big endian we fill up the high order bits of the
9256 -- target value (which is a left justified modular value).
9258 Left_Justified := Bytes_Big_Endian;
9260 -- Switch justification if using -gnatd8
9262 if Debug_Flag_8 then
9263 Left_Justified := not Left_Justified;
9266 -- Switch justfification if reverse storage order
9268 if Reverse_Storage_Order (Base_Type (Typ)) then
9269 Left_Justified := not Left_Justified;
9272 if Left_Justified then
9273 Shift := Csiz * (Len - 1);
9280 -- Loop to set the values
9283 Aggregate_Val := Uint_0;
9285 Expr := First (Expressions (N));
9286 Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
9288 for J in 2 .. Len loop
9289 Shift := Shift + Incr;
9292 Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
9296 -- Now we can rewrite with the proper value
9298 Lit := Make_Integer_Literal (Loc, Intval => Aggregate_Val);
9299 Set_Print_In_Hex (Lit);
9301 -- Construct the expression using this literal. Note that it is
9302 -- important to qualify the literal with its proper modular type
9303 -- since universal integer does not have the required range and
9304 -- also this is a left justified modular type, which is important
9305 -- in the big-endian case.
9308 Unchecked_Convert_To (Typ,
9309 Make_Qualified_Expression (Loc,
9311 New_Occurrence_Of (Packed_Array_Impl_Type (Typ), Loc),
9312 Expression => Lit)));
9314 Analyze_And_Resolve (N, Typ);
9322 end Packed_Array_Aggregate_Handled;
9324 ----------------------------
9325 -- Has_Mutable_Components --
9326 ----------------------------
9328 function Has_Mutable_Components (Typ : Entity_Id) return Boolean is
9333 Comp := First_Component (Typ);
9334 while Present (Comp) loop
9335 Ctyp := Underlying_Type (Etype (Comp));
9336 if Is_Record_Type (Ctyp)
9337 and then Has_Discriminants (Ctyp)
9338 and then not Is_Constrained (Ctyp)
9343 Next_Component (Comp);
9347 end Has_Mutable_Components;
9349 ------------------------------
9350 -- Initialize_Discriminants --
9351 ------------------------------
9353 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is
9354 Loc : constant Source_Ptr := Sloc (N);
9355 Bas : constant Entity_Id := Base_Type (Typ);
9356 Par : constant Entity_Id := Etype (Bas);
9357 Decl : constant Node_Id := Parent (Par);
9361 if Is_Tagged_Type (Bas)
9362 and then Is_Derived_Type (Bas)
9363 and then Has_Discriminants (Par)
9364 and then Has_Discriminants (Bas)
9365 and then Number_Discriminants (Bas) /= Number_Discriminants (Par)
9366 and then Nkind (Decl) = N_Full_Type_Declaration
9367 and then Nkind (Type_Definition (Decl)) = N_Record_Definition
9369 Present (Variant_Part (Component_List (Type_Definition (Decl))))
9370 and then Nkind (N) /= N_Extension_Aggregate
9373 -- Call init proc to set discriminants.
9374 -- There should eventually be a special procedure for this ???
9376 Ref := New_Occurrence_Of (Defining_Identifier (N), Loc);
9377 Insert_Actions_After (N,
9378 Build_Initialization_Call (Sloc (N), Ref, Typ));
9380 end Initialize_Discriminants;
9387 (Obj_Type : Entity_Id;
9388 Typ : Entity_Id) return Boolean
9390 L1, L2, H1, H2 : Node_Id;
9393 -- No sliding if the type of the object is not established yet, if it is
9394 -- an unconstrained type whose actual subtype comes from the aggregate,
9395 -- or if the two types are identical.
9397 if not Is_Array_Type (Obj_Type) then
9400 elsif not Is_Constrained (Obj_Type) then
9403 elsif Typ = Obj_Type then
9407 -- Sliding can only occur along the first dimension
9409 Get_Index_Bounds (First_Index (Typ), L1, H1);
9410 Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
9412 if not Is_OK_Static_Expression (L1) or else
9413 not Is_OK_Static_Expression (L2) or else
9414 not Is_OK_Static_Expression (H1) or else
9415 not Is_OK_Static_Expression (H2)
9419 return Expr_Value (L1) /= Expr_Value (L2)
9421 Expr_Value (H1) /= Expr_Value (H2);
9426 ---------------------------------
9427 -- Process_Transient_Component --
9428 ---------------------------------
9430 procedure Process_Transient_Component
9432 Comp_Typ : Entity_Id;
9433 Init_Expr : Node_Id;
9434 Fin_Call : out Node_Id;
9435 Hook_Clear : out Node_Id;
9436 Aggr : Node_Id := Empty;
9437 Stmts : List_Id := No_List)
9439 procedure Add_Item (Item : Node_Id);
9440 -- Insert arbitrary node Item into the tree depending on the values of
9447 procedure Add_Item (Item : Node_Id) is
9449 if Present (Aggr) then
9450 Insert_Action (Aggr, Item);
9452 pragma Assert (Present (Stmts));
9453 Append_To (Stmts, Item);
9459 Hook_Assign : Node_Id;
9460 Hook_Decl : Node_Id;
9464 Res_Typ : Entity_Id;
9466 -- Start of processing for Process_Transient_Component
9469 -- Add the access type, which provides a reference to the function
9470 -- result. Generate:
9472 -- type Res_Typ is access all Comp_Typ;
9474 Res_Typ := Make_Temporary (Loc, 'A');
9475 Set_Ekind (Res_Typ, E_General_Access_Type);
9476 Set_Directly_Designated_Type (Res_Typ, Comp_Typ);
9479 (Make_Full_Type_Declaration (Loc,
9480 Defining_Identifier => Res_Typ,
9482 Make_Access_To_Object_Definition (Loc,
9483 All_Present => True,
9484 Subtype_Indication => New_Occurrence_Of (Comp_Typ, Loc))));
9486 -- Add the temporary which captures the result of the function call.
9489 -- Res : constant Res_Typ := Init_Expr'Reference;
9491 -- Note that this temporary is effectively a transient object because
9492 -- its lifetime is bounded by the current array or record component.
9494 Res_Id := Make_Temporary (Loc, 'R');
9495 Set_Ekind (Res_Id, E_Constant);
9496 Set_Etype (Res_Id, Res_Typ);
9498 -- Mark the transient object as successfully processed to avoid double
9501 Set_Is_Finalized_Transient (Res_Id);
9503 -- Signal the general finalization machinery that this transient object
9504 -- should not be considered for finalization actions because its cleanup
9505 -- will be performed by Process_Transient_Component_Completion.
9507 Set_Is_Ignored_Transient (Res_Id);
9510 Make_Object_Declaration (Loc,
9511 Defining_Identifier => Res_Id,
9512 Constant_Present => True,
9513 Object_Definition => New_Occurrence_Of (Res_Typ, Loc),
9515 Make_Reference (Loc, New_Copy_Tree (Init_Expr)));
9517 Add_Item (Res_Decl);
9519 -- Construct all pieces necessary to hook and finalize the transient
9522 Build_Transient_Object_Statements
9523 (Obj_Decl => Res_Decl,
9524 Fin_Call => Fin_Call,
9525 Hook_Assign => Hook_Assign,
9526 Hook_Clear => Hook_Clear,
9527 Hook_Decl => Hook_Decl,
9528 Ptr_Decl => Ptr_Decl);
9530 -- Add the access type which provides a reference to the transient
9531 -- result. Generate:
9533 -- type Ptr_Typ is access all Comp_Typ;
9535 Add_Item (Ptr_Decl);
9537 -- Add the temporary which acts as a hook to the transient result.
9540 -- Hook : Ptr_Typ := null;
9542 Add_Item (Hook_Decl);
9544 -- Attach the transient result to the hook. Generate:
9546 -- Hook := Ptr_Typ (Res);
9548 Add_Item (Hook_Assign);
9550 -- The original initialization expression now references the value of
9551 -- the temporary function result. Generate:
9556 Make_Explicit_Dereference (Loc,
9557 Prefix => New_Occurrence_Of (Res_Id, Loc)));
9558 end Process_Transient_Component;
9560 --------------------------------------------
9561 -- Process_Transient_Component_Completion --
9562 --------------------------------------------
9564 procedure Process_Transient_Component_Completion
9568 Hook_Clear : Node_Id;
9571 Exceptions_OK : constant Boolean :=
9572 not Restriction_Active (No_Exception_Propagation);
9575 pragma Assert (Present (Hook_Clear));
9577 -- Generate the following code if exception propagation is allowed:
9580 -- Abort : constant Boolean := Triggered_By_Abort;
9582 -- Abort : constant Boolean := False; -- no abort
9584 -- E : Exception_Occurrence;
9585 -- Raised : Boolean := False;
9592 -- [Deep_]Finalize (Res.all);
9596 -- if not Raised then
9598 -- Save_Occurrence (E,
9599 -- Get_Curent_Excep.all.all);
9605 -- if Raised and then not Abort then
9606 -- Raise_From_Controlled_Operation (E);
9610 if Exceptions_OK then
9611 Abort_And_Exception : declare
9612 Blk_Decls : constant List_Id := New_List;
9613 Blk_Stmts : constant List_Id := New_List;
9614 Fin_Stmts : constant List_Id := New_List;
9616 Fin_Data : Finalization_Exception_Data;
9619 -- Create the declarations of the two flags and the exception
9622 Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
9627 if Abort_Allowed then
9628 Append_To (Blk_Stmts,
9629 Build_Runtime_Call (Loc, RE_Abort_Defer));
9632 -- Wrap the hook clear and the finalization call in order to trap
9633 -- a potential exception.
9635 Append_To (Fin_Stmts, Hook_Clear);
9637 if Present (Fin_Call) then
9638 Append_To (Fin_Stmts, Fin_Call);
9641 Append_To (Blk_Stmts,
9642 Make_Block_Statement (Loc,
9643 Handled_Statement_Sequence =>
9644 Make_Handled_Sequence_Of_Statements (Loc,
9645 Statements => Fin_Stmts,
9646 Exception_Handlers => New_List (
9647 Build_Exception_Handler (Fin_Data)))));
9652 if Abort_Allowed then
9653 Append_To (Blk_Stmts,
9654 Build_Runtime_Call (Loc, RE_Abort_Undefer));
9657 -- Reraise the potential exception with a proper "upgrade" to
9658 -- Program_Error if needed.
9660 Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
9662 -- Wrap everything in a block
9665 Make_Block_Statement (Loc,
9666 Declarations => Blk_Decls,
9667 Handled_Statement_Sequence =>
9668 Make_Handled_Sequence_Of_Statements (Loc,
9669 Statements => Blk_Stmts)));
9670 end Abort_And_Exception;
9672 -- Generate the following code if exception propagation is not allowed
9673 -- and aborts are allowed:
9678 -- [Deep_]Finalize (Res.all);
9680 -- Abort_Undefer_Direct;
9683 elsif Abort_Allowed then
9684 Abort_Only : declare
9685 Blk_Stmts : constant List_Id := New_List;
9688 Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
9689 Append_To (Blk_Stmts, Hook_Clear);
9691 if Present (Fin_Call) then
9692 Append_To (Blk_Stmts, Fin_Call);
9696 Build_Abort_Undefer_Block (Loc,
9701 -- Otherwise generate:
9704 -- [Deep_]Finalize (Res.all);
9707 Append_To (Stmts, Hook_Clear);
9709 if Present (Fin_Call) then
9710 Append_To (Stmts, Fin_Call);
9713 end Process_Transient_Component_Completion;
9715 ---------------------
9716 -- Sort_Case_Table --
9717 ---------------------
9719 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
9720 L : constant Int := Case_Table'First;
9721 U : constant Int := Case_Table'Last;
9729 T := Case_Table (K + 1);
9733 and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
9734 Expr_Value (T.Choice_Lo)
9736 Case_Table (J) := Case_Table (J - 1);
9740 Case_Table (J) := T;
9743 end Sort_Case_Table;
9745 ----------------------------
9746 -- Static_Array_Aggregate --
9747 ----------------------------
9749 function Static_Array_Aggregate (N : Node_Id) return Boolean is
9750 function Is_Static_Component (Nod : Node_Id) return Boolean;
9751 -- Return True if Nod has a compile-time known value and can be passed
9752 -- as is to the back-end without further expansion.
9754 ---------------------------
9755 -- Is_Static_Component --
9756 ---------------------------
9758 function Is_Static_Component (Nod : Node_Id) return Boolean is
9760 if Nkind (Nod) in N_Integer_Literal | N_Real_Literal then
9763 elsif Is_Entity_Name (Nod)
9764 and then Present (Entity (Nod))
9765 and then Ekind (Entity (Nod)) = E_Enumeration_Literal
9769 elsif Nkind (Nod) = N_Aggregate
9770 and then Compile_Time_Known_Aggregate (Nod)
9777 end Is_Static_Component;
9781 Bounds : constant Node_Id := Aggregate_Bounds (N);
9782 Typ : constant Entity_Id := Etype (N);
9789 -- Start of processing for Static_Array_Aggregate
9792 if Is_Packed (Typ) or else Has_Discriminants (Component_Type (Typ)) then
9797 and then Nkind (Bounds) = N_Range
9798 and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
9799 and then Nkind (High_Bound (Bounds)) = N_Integer_Literal
9801 Lo := Low_Bound (Bounds);
9802 Hi := High_Bound (Bounds);
9804 if No (Component_Associations (N)) then
9806 -- Verify that all components are static
9808 Expr := First (Expressions (N));
9809 while Present (Expr) loop
9810 if not Is_Static_Component (Expr) then
9820 -- We allow only a single named association, either a static
9821 -- range or an others_clause, with a static expression.
9823 Expr := First (Component_Associations (N));
9825 if Present (Expressions (N)) then
9828 elsif Present (Next (Expr)) then
9831 elsif Present (Next (First (Choice_List (Expr)))) then
9835 -- The aggregate is static if all components are literals,
9836 -- or else all its components are static aggregates for the
9837 -- component type. We also limit the size of a static aggregate
9838 -- to prevent runaway static expressions.
9840 if not Is_Static_Component (Expression (Expr)) then
9844 if not Aggr_Size_OK (N) then
9848 -- Create a positional aggregate with the right number of
9849 -- copies of the expression.
9851 Agg := Make_Aggregate (Sloc (N), New_List, No_List);
9853 for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi))
9855 Append_To (Expressions (Agg), New_Copy (Expression (Expr)));
9857 -- The copied expression must be analyzed and resolved.
9858 -- Besides setting the type, this ensures that static
9859 -- expressions are appropriately marked as such.
9862 (Last (Expressions (Agg)), Component_Type (Typ));
9865 Set_Aggregate_Bounds (Agg, Bounds);
9866 Set_Etype (Agg, Typ);
9869 Set_Compile_Time_Known_Aggregate (N);
9878 end Static_Array_Aggregate;
9880 ----------------------------------
9881 -- Two_Dim_Packed_Array_Handled --
9882 ----------------------------------
9884 function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is
9885 Loc : constant Source_Ptr := Sloc (N);
9886 Typ : constant Entity_Id := Etype (N);
9887 Ctyp : constant Entity_Id := Component_Type (Typ);
9888 Comp_Size : constant Int := UI_To_Int (Component_Size (Typ));
9889 Packed_Array : constant Entity_Id :=
9890 Packed_Array_Impl_Type (Base_Type (Typ));
9893 -- Expression in original aggregate
9896 -- One-dimensional subaggregate
9900 -- For now, only deal with cases where an integral number of elements
9901 -- fit in a single byte. This includes the most common boolean case.
9903 if not (Comp_Size = 1 or else
9904 Comp_Size = 2 or else
9910 Convert_To_Positional (N, Handle_Bit_Packed => True);
9912 -- Verify that all components are static
9914 if Nkind (N) = N_Aggregate
9915 and then Compile_Time_Known_Aggregate (N)
9919 -- The aggregate may have been reanalyzed and converted already
9921 elsif Nkind (N) /= N_Aggregate then
9924 -- If component associations remain, the aggregate is not static
9926 elsif Present (Component_Associations (N)) then
9930 One_Dim := First (Expressions (N));
9931 while Present (One_Dim) loop
9932 if Present (Component_Associations (One_Dim)) then
9936 One_Comp := First (Expressions (One_Dim));
9937 while Present (One_Comp) loop
9938 if not Is_OK_Static_Expression (One_Comp) then
9949 -- Two-dimensional aggregate is now fully positional so pack one
9950 -- dimension to create a static one-dimensional array, and rewrite
9951 -- as an unchecked conversion to the original type.
9954 Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array));
9955 -- The packed array type is a byte array
9958 -- Number of components accumulated in current byte
9961 -- Assembled list of packed values for equivalent aggregate
9964 -- Integer value of component
9967 -- Step size for packing
9970 -- Endian-dependent start position for packing
9973 -- Current insertion position
9976 -- Component of packed array being assembled
9983 -- Account for endianness. See corresponding comment in
9984 -- Packed_Array_Aggregate_Handled concerning the following.
9988 xor Reverse_Storage_Order (Base_Type (Typ))
9990 Init_Shift := Byte_Size - Comp_Size;
9997 -- Iterate over each subaggregate
9999 Shift := Init_Shift;
10000 One_Dim := First (Expressions (N));
10001 while Present (One_Dim) loop
10002 One_Comp := First (Expressions (One_Dim));
10003 while Present (One_Comp) loop
10004 if Packed_Num = Byte_Size / Comp_Size then
10006 -- Byte is complete, add to list of expressions
10008 Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
10010 Shift := Init_Shift;
10014 Comp_Val := Expr_Rep_Value (One_Comp);
10016 -- Adjust for bias, and strip proper number of bits
10018 if Has_Biased_Representation (Ctyp) then
10019 Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp));
10022 Comp_Val := Comp_Val mod Uint_2 ** Comp_Size;
10023 Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift);
10024 Shift := Shift + Incr;
10026 Packed_Num := Packed_Num + 1;
10033 if Packed_Num > 0 then
10035 -- Add final incomplete byte if present
10037 Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
10041 Unchecked_Convert_To (Typ,
10042 Make_Qualified_Expression (Loc,
10043 Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc),
10044 Expression => Make_Aggregate (Loc, Expressions => Comps))));
10045 Analyze_And_Resolve (N);
10048 end Two_Dim_Packed_Array_Handled;