1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Expander
; use Expander
;
36 with Exp_Util
; use Exp_Util
;
37 with Exp_Ch3
; use Exp_Ch3
;
38 with Exp_Ch6
; use Exp_Ch6
;
39 with Exp_Ch7
; use Exp_Ch7
;
40 with Exp_Ch9
; use Exp_Ch9
;
41 with Exp_Disp
; use Exp_Disp
;
42 with Exp_Tss
; use Exp_Tss
;
43 with Freeze
; use Freeze
;
44 with Itypes
; use Itypes
;
46 with Namet
; use Namet
;
47 with Nmake
; use Nmake
;
48 with Nlists
; use Nlists
;
50 with Restrict
; use Restrict
;
51 with Rident
; use Rident
;
52 with Rtsfind
; use Rtsfind
;
53 with Ttypes
; use Ttypes
;
55 with Sem_Aggr
; use Sem_Aggr
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Case
; use Sem_Case
;
58 with Sem_Ch3
; use Sem_Ch3
;
59 with Sem_Ch8
; use Sem_Ch8
;
60 with Sem_Ch13
; use Sem_Ch13
;
61 with Sem_Eval
; use Sem_Eval
;
62 with Sem_Mech
; use Sem_Mech
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Type
; use Sem_Type
;
65 with Sem_Util
; use Sem_Util
;
66 use Sem_Util
.Storage_Model_Support
;
67 with Sinfo
; use Sinfo
;
68 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
69 with Sinfo
.Utils
; use Sinfo
.Utils
;
70 with Snames
; use Snames
;
71 with Stand
; use Stand
;
72 with Stringt
; use Stringt
;
73 with Tbuild
; use Tbuild
;
74 with Uintp
; use Uintp
;
75 with Urealp
; use Urealp
;
76 with Warnsw
; use Warnsw
;
78 package body Exp_Aggr
is
80 function Build_Assignment_With_Temporary
83 Source
: Node_Id
) return List_Id
;
84 -- Returns a list of actions to assign Source to Target of type Typ using
85 -- an extra temporary, which can potentially be large.
87 type Case_Bounds
is record
90 Choice_Node
: Node_Id
;
93 type Case_Table_Type
is array (Nat
range <>) of Case_Bounds
;
94 -- Table type used by Check_Case_Choices procedure
96 procedure Expand_Delta_Array_Aggregate
(N
: Node_Id
; Deltas
: List_Id
);
97 procedure Expand_Delta_Record_Aggregate
(N
: Node_Id
; Deltas
: List_Id
);
98 procedure Expand_Container_Aggregate
(N
: Node_Id
);
100 function Get_Base_Object
(N
: Node_Id
) return Entity_Id
;
101 -- Return the base object, i.e. the outermost prefix object, that N refers
102 -- to statically, or Empty if it cannot be determined. The assumption is
103 -- that all dereferences are explicit in the tree rooted at N.
105 function Has_Default_Init_Comps
(N
: Node_Id
) return Boolean;
106 -- N is an aggregate (record or array). Checks the presence of default
107 -- initialization (<>) in any component (Ada 2005: AI-287).
109 procedure Initialize_Component
115 -- Perform the initialization of component Comp with expected type
116 -- Comp_Typ of aggregate N. Init_Expr denotes the initialization
117 -- expression of the component. All generated code is added to Stmts.
119 function Is_CCG_Supported_Aggregate
(N
: Node_Id
) return Boolean;
120 -- Return True if aggregate N is located in a context supported by the
121 -- CCG backend; False otherwise.
123 function Is_Static_Dispatch_Table_Aggregate
(N
: Node_Id
) return Boolean;
124 -- Returns true if N is an aggregate used to initialize the components
125 -- of a statically allocated dispatch table.
127 function Late_Expansion
130 Target
: Node_Id
) return List_Id
;
131 -- This routine implements top-down expansion of nested aggregates. In
132 -- doing so, it avoids the generation of temporaries at each level. N is
133 -- a nested record or array aggregate with the Expansion_Delayed flag.
134 -- Typ is the expected type of the aggregate. Target is a (duplicatable)
135 -- expression that will hold the result of the aggregate expansion.
137 function Make_OK_Assignment_Statement
140 Expression
: Node_Id
) return Node_Id
;
141 -- This is like Make_Assignment_Statement, except that Assignment_OK
142 -- is set in the left operand. All assignments built by this unit use
143 -- this routine. This is needed to deal with assignments to initialized
144 -- constants that are done in place.
148 Obj_Type
: Entity_Id
;
149 Typ
: Entity_Id
) return Boolean;
150 -- A static array aggregate in an object declaration can in most cases be
151 -- expanded in place. The one exception is when the aggregate is given
152 -- with component associations that specify different bounds from those of
153 -- the type definition in the object declaration. In this pathological
154 -- case the aggregate must slide, and we must introduce an intermediate
155 -- temporary to hold it.
157 -- The same holds in an assignment to one-dimensional array of arrays,
158 -- when a component may be given with bounds that differ from those of the
161 function Number_Of_Choices
(N
: Node_Id
) return Nat
;
162 -- Returns the number of discrete choices (not including the others choice
163 -- if present) contained in (sub-)aggregate N.
165 procedure Sort_Case_Table
(Case_Table
: in out Case_Table_Type
);
166 -- Sort the Case Table using the Lower Bound of each Choice as the key.
167 -- A simple insertion sort is used since the number of choices in a case
168 -- statement of variant part will usually be small and probably in near
171 ------------------------------------------------------
172 -- Local subprograms for Record Aggregate Expansion --
173 ------------------------------------------------------
175 function Is_Build_In_Place_Aggregate_Return
(N
: Node_Id
) return Boolean;
176 -- True if N is an aggregate (possibly qualified or a dependent expression
177 -- of a conditional expression, and possibly recursively so) that is being
178 -- returned from a build-in-place function. Such qualified and conditional
179 -- expressions are transparent for this purpose because an enclosing return
180 -- is propagated resp. distributed into these expressions by the expander.
182 function Build_Record_Aggr_Code
185 Lhs
: Node_Id
) return List_Id
;
186 -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
187 -- aggregate. Target is an expression containing the location on which the
188 -- component by component assignments will take place. Returns the list of
189 -- assignments plus all other adjustments needed for tagged and controlled
192 procedure Convert_To_Assignments
(N
: Node_Id
; Typ
: Entity_Id
);
193 -- Transform a record aggregate into a sequence of assignments performed
194 -- component by component. N is an N_Aggregate or N_Extension_Aggregate.
195 -- Typ is the type of the record aggregate.
197 procedure Expand_Record_Aggregate
199 Orig_Tag
: Node_Id
:= Empty
;
200 Parent_Expr
: Node_Id
:= Empty
);
201 -- This is the top level procedure for record aggregate expansion.
202 -- Expansion for record aggregates needs expand aggregates for tagged
203 -- record types. Specifically Expand_Record_Aggregate adds the Tag
204 -- field in front of the Component_Association list that was created
205 -- during resolution by Resolve_Record_Aggregate.
207 -- N is the record aggregate node.
208 -- Orig_Tag is the value of the Tag that has to be provided for this
209 -- specific aggregate. It carries the tag corresponding to the type
210 -- of the outermost aggregate during the recursive expansion
211 -- Parent_Expr is the ancestor part of the original extension
214 function Has_Mutable_Components
(Typ
: Entity_Id
) return Boolean;
215 -- Return true if one of the components is of a discriminated type with
216 -- defaults. An aggregate for a type with mutable components must be
217 -- expanded into individual assignments.
219 function In_Place_Assign_OK
221 Target_Object
: Entity_Id
:= Empty
) return Boolean;
222 -- Predicate to determine whether an aggregate assignment can be done in
223 -- place, because none of the new values can depend on the components of
224 -- the target of the assignment.
226 procedure Initialize_Discriminants
(N
: Node_Id
; Typ
: Entity_Id
);
227 -- If the type of the aggregate is a type extension with renamed discrimi-
228 -- nants, we must initialize the hidden discriminants of the parent.
229 -- Otherwise, the target object must not be initialized. The discriminants
230 -- are initialized by calling the initialization procedure for the type.
231 -- This is incorrect if the initialization of other components has any
232 -- side effects. We restrict this call to the case where the parent type
233 -- has a variant part, because this is the only case where the hidden
234 -- discriminants are accessed, namely when calling discriminant checking
235 -- functions of the parent type, and when applying a stream attribute to
236 -- an object of the derived type.
238 -----------------------------------------------------
239 -- Local Subprograms for Array Aggregate Expansion --
240 -----------------------------------------------------
242 function Aggr_Assignment_OK_For_Backend
(N
: Node_Id
) return Boolean;
243 -- Returns true if an aggregate assignment can be done by the back end
245 function Aggr_Size_OK
(N
: Node_Id
) return Boolean;
246 -- Very large static aggregates present problems to the back-end, and are
247 -- transformed into assignments and loops. This function verifies that the
248 -- total number of components of an aggregate is acceptable for rewriting
249 -- into a purely positional static form. Aggr_Size_OK must be called before
252 -- This function also detects and warns about one-component aggregates that
253 -- appear in a nonstatic context. Even if the component value is static,
254 -- such an aggregate must be expanded into an assignment.
256 function Backend_Processing_Possible
(N
: Node_Id
) return Boolean;
257 -- This function checks if array aggregate N can be processed directly
258 -- by the backend. If this is the case, True is returned.
260 function Build_Array_Aggr_Code
265 Scalar_Comp
: Boolean;
266 Indexes
: List_Id
:= No_List
) return List_Id
;
267 -- This recursive routine returns a list of statements containing the
268 -- loops and assignments that are needed for the expansion of the array
271 -- N is the (sub-)aggregate node to be expanded into code. This node has
272 -- been fully analyzed, and its Etype is properly set.
274 -- Index is the index node corresponding to the array subaggregate N
276 -- Into is the target expression into which we are copying the aggregate.
277 -- Note that this node may not have been analyzed yet, and so the Etype
278 -- field may not be set.
280 -- Scalar_Comp is True if the component type of the aggregate is scalar
282 -- Indexes is the current list of expressions used to index the object we
285 procedure Convert_Array_Aggr_In_Allocator
289 -- If the aggregate appears within an allocator and can be expanded in
290 -- place, this routine generates the individual assignments to components
291 -- of the designated object. This is an optimization over the general
292 -- case, where a temporary is first created on the stack and then used to
293 -- construct the allocated object on the heap.
295 procedure Convert_To_Positional
297 Handle_Bit_Packed
: Boolean := False);
298 -- If possible, convert named notation to positional notation. This
299 -- conversion is possible only in some static cases. If the conversion is
300 -- possible, then N is rewritten with the analyzed converted aggregate.
301 -- The parameter Handle_Bit_Packed is usually set False (since we do
302 -- not expect the back end to handle bit packed arrays, so the normal case
303 -- of conversion is pointless), but in the special case of a call from
304 -- Packed_Array_Aggregate_Handled, we set this parameter to True, since
305 -- these are cases we handle in there.
307 procedure Expand_Array_Aggregate
(N
: Node_Id
);
308 -- This is the top-level routine to perform array aggregate expansion.
309 -- N is the N_Aggregate node to be expanded.
311 function Is_Two_Dim_Packed_Array
(Typ
: Entity_Id
) return Boolean;
312 -- For 2D packed array aggregates with constant bounds and constant scalar
313 -- components, it is preferable to pack the inner aggregates because the
314 -- whole matrix can then be presented to the back-end as a one-dimensional
315 -- list of literals. This is much more efficient than expanding into single
316 -- component assignments. This function determines if the type Typ is for
317 -- an array that is suitable for this optimization: it returns True if Typ
318 -- is a two dimensional bit packed array with component size 1, 2, or 4.
320 function Max_Aggregate_Size
322 Default_Size
: Nat
:= 5000) return Nat
;
323 -- Return the max size for a static aggregate N. Return Default_Size if no
324 -- other special criteria trigger.
326 function Packed_Array_Aggregate_Handled
(N
: Node_Id
) return Boolean;
327 -- Given an array aggregate, this function handles the case of a packed
328 -- array aggregate with all constant values, where the aggregate can be
329 -- evaluated at compile time. If this is possible, then N is rewritten
330 -- to be its proper compile time value with all the components properly
331 -- assembled. The expression is analyzed and resolved and True is returned.
332 -- If this transformation is not possible, N is unchanged and False is
335 function Two_Dim_Packed_Array_Handled
(N
: Node_Id
) return Boolean;
336 -- If the type of the aggregate is a two-dimensional bit_packed array
337 -- it may be transformed into an array of bytes with constant values,
338 -- and presented to the back-end as a static value. The function returns
339 -- false if this transformation cannot be performed. THis is similar to,
340 -- and reuses part of the machinery in Packed_Array_Aggregate_Handled.
342 ------------------------------------
343 -- Aggr_Assignment_OK_For_Backend --
344 ------------------------------------
346 -- Back-end processing by Gigi/gcc is possible only if all the following
347 -- conditions are met:
349 -- 1. N consists of a single OTHERS choice, possibly recursively, or
350 -- of a single choice, possibly recursively, if it is surrounded by
351 -- a qualified expression whose subtype mark is unconstrained.
353 -- 2. The array type has no null ranges (the purpose of this is to
354 -- avoid a bogus warning for an out-of-range value).
356 -- 3. The array type has no atomic components
358 -- 4. The component type is elementary
360 -- 5. The component size is a multiple of Storage_Unit
362 -- 6. The component size is Storage_Unit or the value is of the form
363 -- M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit)
364 -- and M in 0 .. A-1. This can also be viewed as K occurrences of
365 -- the Storage_Unit value M, concatenated together.
367 -- The ultimate goal is to generate a call to a fast memset routine
368 -- specifically optimized for the target.
370 function Aggr_Assignment_OK_For_Backend
(N
: Node_Id
) return Boolean is
372 function Is_OK_Aggregate
(Aggr
: Node_Id
) return Boolean;
373 -- Return true if Aggr is suitable for back-end assignment
375 ---------------------
376 -- Is_OK_Aggregate --
377 ---------------------
379 function Is_OK_Aggregate
(Aggr
: Node_Id
) return Boolean is
380 Assoc
: constant List_Id
:= Component_Associations
(Aggr
);
383 -- An "others" aggregate is most likely OK, but see below
385 if Is_Others_Aggregate
(Aggr
) then
388 -- An aggregate with a single choice requires a qualified expression
389 -- whose subtype mark is an unconstrained type because we need it to
390 -- have the semantics of an "others" aggregate.
392 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
393 and then not Is_Constrained
(Entity
(Subtype_Mark
(Parent
(N
))))
394 and then Is_Single_Aggregate
(Aggr
)
398 -- The other cases are not OK
404 -- In any case we do not support an iterated association
406 return Nkind
(First
(Assoc
)) /= N_Iterated_Component_Association
;
409 Bounds
: Range_Nodes
;
410 Csiz
: Uint
:= No_Uint
;
418 -- Start of processing for Aggr_Assignment_OK_For_Backend
421 -- Back end doesn't know about <>
423 if Has_Default_Init_Comps
(N
) then
427 -- Recurse as far as possible to find the innermost component type
431 while Is_Array_Type
(Ctyp
) loop
432 if Nkind
(Expr
) /= N_Aggregate
433 or else not Is_OK_Aggregate
(Expr
)
438 Index
:= First_Index
(Ctyp
);
439 while Present
(Index
) loop
440 Bounds
:= Get_Index_Bounds
(Index
);
442 if Is_Null_Range
(Bounds
.First
, Bounds
.Last
) then
449 Expr
:= Expression
(First
(Component_Associations
(Expr
)));
451 for J
in 1 .. Number_Dimensions
(Ctyp
) - 1 loop
452 if Nkind
(Expr
) /= N_Aggregate
453 or else not Is_OK_Aggregate
(Expr
)
458 Expr
:= Expression
(First
(Component_Associations
(Expr
)));
461 if Has_Atomic_Components
(Ctyp
) then
465 Csiz
:= Component_Size
(Ctyp
);
466 Ctyp
:= Component_Type
(Ctyp
);
468 if Is_Full_Access
(Ctyp
) then
473 -- Access types need to be dealt with specially
475 if Is_Access_Type
(Ctyp
) then
477 -- Component_Size is not set by Layout_Type if the component
478 -- type is an access type ???
480 Csiz
:= Esize
(Ctyp
);
482 -- Fat pointers are rejected as they are not really elementary
485 if No
(Csiz
) or else Csiz
/= System_Address_Size
then
489 -- The supported expressions are NULL and constants, others are
490 -- rejected upfront to avoid being analyzed below, which can be
491 -- problematic for some of them, for example allocators.
493 if Nkind
(Expr
) /= N_Null
and then not Is_Entity_Name
(Expr
) then
497 -- Scalar types are OK if their size is a multiple of Storage_Unit
499 elsif Is_Scalar_Type
(Ctyp
) and then Present
(Csiz
) then
501 if Csiz
mod System_Storage_Unit
/= 0 then
505 -- Composite types are rejected
511 -- If the expression has side effects (e.g. contains calls with
512 -- potential side effects) reject as well. We only preanalyze the
513 -- expression to prevent the removal of intended side effects.
515 Preanalyze_And_Resolve
(Expr
, Ctyp
);
517 if not Side_Effect_Free
(Expr
) then
521 -- The expression needs to be analyzed if True is returned
523 Analyze_And_Resolve
(Expr
, Ctyp
);
525 -- Strip away any conversions from the expression as they simply
526 -- qualify the real expression.
528 while Nkind
(Expr
) in N_Unchecked_Type_Conversion | N_Type_Conversion
530 Expr
:= Expression
(Expr
);
533 Nunits
:= UI_To_Int
(Csiz
) / System_Storage_Unit
;
539 if not Compile_Time_Known_Value
(Expr
) then
543 -- The only supported value for floating point is 0.0
545 if Is_Floating_Point_Type
(Ctyp
) then
546 return Expr_Value_R
(Expr
) = Ureal_0
;
549 -- For other types, we can look into the value as an integer, which
550 -- means the representation value for enumeration literals.
552 Value
:= Expr_Rep_Value
(Expr
);
554 if Has_Biased_Representation
(Ctyp
) then
555 Value
:= Value
- Expr_Value
(Type_Low_Bound
(Ctyp
));
558 -- Values 0 and -1 immediately satisfy the last check
560 if Value
= Uint_0
or else Value
= Uint_Minus_1
then
564 -- We need to work with an unsigned value
567 Value
:= Value
+ 2**(System_Storage_Unit
* Nunits
);
570 Remainder
:= Value
rem 2**System_Storage_Unit
;
572 for J
in 1 .. Nunits
- 1 loop
573 Value
:= Value
/ 2**System_Storage_Unit
;
575 if Value
rem 2**System_Storage_Unit
/= Remainder
then
581 end Aggr_Assignment_OK_For_Backend
;
587 function Aggr_Size_OK
(N
: Node_Id
) return Boolean is
588 Typ
: constant Entity_Id
:= Etype
(N
);
597 -- Determines the maximum size of an array aggregate produced by
598 -- converting named to positional notation (e.g. from others clauses).
599 -- This avoids running away with attempts to convert huge aggregates,
600 -- which hit memory limits in the backend.
602 function Component_Count
(T
: Entity_Id
) return Nat
;
603 -- The limit is applied to the total number of subcomponents that the
604 -- aggregate will have, which is the number of static expressions
605 -- that will appear in the flattened array. This requires a recursive
606 -- computation of the number of scalar components of the structure.
608 ---------------------
609 -- Component_Count --
610 ---------------------
612 function Component_Count
(T
: Entity_Id
) return Nat
is
617 if Is_Scalar_Type
(T
) then
620 elsif Is_Record_Type
(T
) then
621 Comp
:= First_Component
(T
);
622 while Present
(Comp
) loop
623 Res
:= Res
+ Component_Count
(Etype
(Comp
));
624 Next_Component
(Comp
);
629 elsif Is_Array_Type
(T
) then
631 Lo
: constant Node_Id
:=
632 Type_Low_Bound
(Etype
(First_Index
(T
)));
633 Hi
: constant Node_Id
:=
634 Type_High_Bound
(Etype
(First_Index
(T
)));
636 Siz
: constant Nat
:= Component_Count
(Component_Type
(T
));
639 -- Check for superflat arrays, i.e. arrays with such bounds
640 -- as 4 .. 2, to insure that this function never returns a
641 -- meaningless negative value.
643 if not Compile_Time_Known_Value
(Lo
)
644 or else not Compile_Time_Known_Value
(Hi
)
645 or else Expr_Value
(Hi
) < Expr_Value
(Lo
)
650 -- If the number of components is greater than Int'Last,
651 -- then return Int'Last, so caller will return False (Aggr
652 -- size is not OK). Otherwise, UI_To_Int will crash.
655 UI
: constant Uint
:=
656 (Expr_Value
(Hi
) - Expr_Value
(Lo
) + 1) * Siz
;
658 if UI_Is_In_Int_Range
(UI
) then
659 return UI_To_Int
(UI
);
668 -- Can only be a null for an access type
674 -- Start of processing for Aggr_Size_OK
677 -- We bump the maximum size unless the aggregate has a single component
678 -- association, which will be more efficient if implemented with a loop.
679 -- The -gnatd_g switch disables this bumping.
681 if (No
(Expressions
(N
))
682 and then No
(Next
(First
(Component_Associations
(N
)))))
683 or else Debug_Flag_Underscore_G
685 Max_Aggr_Size
:= Max_Aggregate_Size
(N
);
687 Max_Aggr_Size
:= Max_Aggregate_Size
(N
, 500_000
);
690 Size
:= UI_From_Int
(Component_Count
(Component_Type
(Typ
)));
692 Indx
:= First_Index
(Typ
);
693 while Present
(Indx
) loop
694 Lo
:= Type_Low_Bound
(Etype
(Indx
));
695 Hi
:= Type_High_Bound
(Etype
(Indx
));
697 -- Bounds need to be known at compile time
699 if not Compile_Time_Known_Value
(Lo
)
700 or else not Compile_Time_Known_Value
(Hi
)
705 Lov
:= Expr_Value
(Lo
);
706 Hiv
:= Expr_Value
(Hi
);
708 -- A flat array is always safe
714 -- One-component aggregates are suspicious, and if the context type
715 -- is an object declaration with nonstatic bounds it will trip gcc;
716 -- such an aggregate must be expanded into a single assignment.
718 if Hiv
= Lov
and then Nkind
(Parent
(N
)) = N_Object_Declaration
then
720 Index_Type
: constant Entity_Id
:=
722 (First_Index
(Etype
(Defining_Identifier
(Parent
(N
)))));
726 if not Compile_Time_Known_Value
(Type_Low_Bound
(Index_Type
))
727 or else not Compile_Time_Known_Value
728 (Type_High_Bound
(Index_Type
))
730 if Present
(Component_Associations
(N
)) then
733 (Choice_List
(First
(Component_Associations
(N
))));
735 if Is_Entity_Name
(Indx
)
736 and then not Is_Type
(Entity
(Indx
))
739 ("single component aggregate in "
740 & "non-static context??", Indx
);
741 Error_Msg_N
("\maybe subtype name was meant??", Indx
);
751 Rng
: constant Uint
:= Hiv
- Lov
+ 1;
754 -- Check if size is too large
756 if not UI_Is_In_Int_Range
(Rng
) then
760 -- Compute the size using universal arithmetic to avoid the
761 -- possibility of overflow on very large aggregates.
766 or else Size
> Max_Aggr_Size
772 -- Bounds must be in integer range, for later array construction
774 if not UI_Is_In_Int_Range
(Lov
)
776 not UI_Is_In_Int_Range
(Hiv
)
787 ---------------------------------
788 -- Backend_Processing_Possible --
789 ---------------------------------
791 -- Backend processing by Gigi/gcc is possible only if all the following
792 -- conditions are met:
794 -- 1. N is fully positional
796 -- 2. N is not a bit-packed array aggregate;
798 -- 3. The size of N's array type must be known at compile time. Note
799 -- that this implies that the component size is also known
801 -- 4. The array type of N does not follow the Fortran layout convention
802 -- or if it does it must be 1 dimensional.
804 -- 5. The array component type may not be tagged (which could necessitate
805 -- reassignment of proper tags).
807 -- 6. The array component type must not have unaligned bit components
809 -- 7. None of the components of the aggregate may be bit unaligned
812 -- 8. There cannot be delayed components, since we do not know enough
813 -- at this stage to know if back end processing is possible.
815 -- 9. There cannot be any discriminated record components, since the
816 -- back end cannot handle this complex case.
818 -- 10. No controlled actions need to be generated for components
820 -- 11. When generating C code, N must be part of a N_Object_Declaration
822 -- 12. When generating C code, N must not include function calls
824 function Backend_Processing_Possible
(N
: Node_Id
) return Boolean is
825 Typ
: constant Entity_Id
:= Etype
(N
);
826 -- Typ is the correct constrained array subtype of the aggregate
828 function Component_Check
(N
: Node_Id
; Index
: Node_Id
) return Boolean;
829 -- This routine checks components of aggregate N, enforcing checks
830 -- 1, 7, 8, 9, 11, and 12. In the multidimensional case, these checks
831 -- are performed on subaggregates. The Index value is the current index
832 -- being checked in the multidimensional case.
834 ---------------------
835 -- Component_Check --
836 ---------------------
838 function Component_Check
(N
: Node_Id
; Index
: Node_Id
) return Boolean is
839 function Ultimate_Original_Expression
(N
: Node_Id
) return Node_Id
;
840 -- Given a type conversion or an unchecked type conversion N, return
841 -- its innermost original expression.
843 ----------------------------------
844 -- Ultimate_Original_Expression --
845 ----------------------------------
847 function Ultimate_Original_Expression
(N
: Node_Id
) return Node_Id
is
848 Expr
: Node_Id
:= Original_Node
(N
);
851 while Nkind
(Expr
) in
852 N_Type_Conversion | N_Unchecked_Type_Conversion
854 Expr
:= Original_Node
(Expression
(Expr
));
858 end Ultimate_Original_Expression
;
864 -- Start of processing for Component_Check
867 -- Checks 1: (no component associations)
869 if Present
(Component_Associations
(N
)) then
873 -- Checks 11: The C code generator cannot handle aggregates that are
874 -- not part of an object declaration.
876 if Modify_Tree_For_C
and then not Is_CCG_Supported_Aggregate
(N
) then
880 -- Checks on components
882 -- Recurse to check subaggregates, which may appear in qualified
883 -- expressions. If delayed, the front-end will have to expand.
884 -- If the component is a discriminated record, treat as nonstatic,
885 -- as the back-end cannot handle this properly.
887 Expr
:= First
(Expressions
(N
));
888 while Present
(Expr
) loop
890 -- Checks 8: (no delayed components)
892 if Is_Delayed_Aggregate
(Expr
) then
896 -- Checks 9: (no discriminated records)
898 if Present
(Etype
(Expr
))
899 and then Is_Record_Type
(Etype
(Expr
))
900 and then Has_Discriminants
(Etype
(Expr
))
905 -- Checks 7. Component must not be bit aligned component
907 if Possible_Bit_Aligned_Component
(Expr
) then
911 -- Checks 12: (no function call)
915 Nkind
(Ultimate_Original_Expression
(Expr
)) = N_Function_Call
920 -- Recursion to following indexes for multiple dimension case
922 if Present
(Next_Index
(Index
))
923 and then not Component_Check
(Expr
, Next_Index
(Index
))
928 -- All checks for that component finished, on to next
936 -- Start of processing for Backend_Processing_Possible
939 -- Checks 2 (array not bit packed) and 10 (no controlled actions)
941 if Is_Bit_Packed_Array
(Typ
) or else Needs_Finalization
(Typ
) then
945 -- If component is limited, aggregate must be expanded because each
946 -- component assignment must be built in place.
948 if Is_Limited_View
(Component_Type
(Typ
)) then
952 -- Checks 4 (array must not be multidimensional Fortran case)
954 if Convention
(Typ
) = Convention_Fortran
955 and then Number_Dimensions
(Typ
) > 1
960 -- Checks 3 (size of array must be known at compile time)
962 if not Size_Known_At_Compile_Time
(Typ
) then
966 -- Checks on components
968 if not Component_Check
(N
, First_Index
(Typ
)) then
972 -- Checks 5 (if the component type is tagged, then we may need to do
973 -- tag adjustments. Perhaps this should be refined to check for any
974 -- component associations that actually need tag adjustment, similar
975 -- to the test in Component_OK_For_Backend for record aggregates with
976 -- tagged components, but not clear whether it's worthwhile ???; in the
977 -- case of virtual machines (no Tagged_Type_Expansion), object tags are
978 -- handled implicitly).
980 if Is_Tagged_Type
(Component_Type
(Typ
))
981 and then Tagged_Type_Expansion
986 -- Checks 6 (component type must not have bit aligned components)
988 if Type_May_Have_Bit_Aligned_Components
(Component_Type
(Typ
)) then
992 -- Backend processing is possible
995 end Backend_Processing_Possible
;
997 ---------------------------
998 -- Build_Array_Aggr_Code --
999 ---------------------------
1001 -- The code that we generate from a one dimensional aggregate is
1003 -- 1. If the subaggregate contains discrete choices we
1005 -- (a) Sort the discrete choices
1007 -- (b) Otherwise for each discrete choice that specifies a range we
1008 -- emit a loop. If a range specifies a maximum of three values, or
1009 -- we are dealing with an expression we emit a sequence of
1010 -- assignments instead of a loop.
1012 -- (c) Generate the remaining loops to cover the others choice if any
1014 -- 2. If the aggregate contains positional elements we
1016 -- (a) Translate the positional elements in a series of assignments
1018 -- (b) Generate a final loop to cover the others choice if any.
1019 -- Note that this final loop has to be a while loop since the case
1021 -- L : Integer := Integer'Last;
1022 -- H : Integer := Integer'Last;
1023 -- A : array (L .. H) := (1, others =>0);
1025 -- cannot be handled by a for loop. Thus for the following
1027 -- array (L .. H) := (.. positional elements.., others => E);
1029 -- we always generate something like:
1031 -- J : Index_Type := Index_Of_Last_Positional_Element;
1033 -- J := Index_Base'Succ (J)
1037 function Build_Array_Aggr_Code
1042 Scalar_Comp
: Boolean;
1043 Indexes
: List_Id
:= No_List
) return List_Id
1045 Loc
: constant Source_Ptr
:= Sloc
(N
);
1046 Typ
: constant Entity_Id
:= Etype
(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
1067 Expr
: Node_Id
) return List_Id
;
1068 -- Ind must be a side-effect-free expression. If the input aggregate N
1069 -- to Build_Loop contains no subaggregates, then this function returns
1070 -- the assignment statement:
1072 -- Into (Indexes, Ind) := Expr;
1074 -- Otherwise we call Build_Code recursively.
1076 -- Ada 2005 (AI-287): In case of default initialized component, Expr
1077 -- is empty and we generate a call to the corresponding IP subprogram.
1079 function Gen_Loop
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
;
1080 -- Nodes L and H must be side-effect-free expressions. If the input
1081 -- aggregate N to Build_Loop contains no subaggregates, this routine
1082 -- returns the for loop statement:
1084 -- for J in Index_Base'(L) .. Index_Base'(H) loop
1085 -- Into (Indexes, J) := Expr;
1088 -- Otherwise we call Build_Code recursively. As an optimization if the
1089 -- loop covers 3 or fewer scalar elements we generate a sequence of
1091 -- If the component association that generates the loop comes from an
1092 -- Iterated_Component_Association, the loop parameter has the name of
1093 -- the corresponding parameter in the original construct.
1095 function Gen_While
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
;
1096 -- Nodes L and H must be side-effect-free expressions. If the input
1097 -- aggregate N to Build_Loop contains no subaggregates, this routine
1098 -- returns the while loop statement:
1100 -- J : Index_Base := L;
1102 -- J := Index_Base'Succ (J);
1103 -- Into (Indexes, J) := Expr;
1106 -- Otherwise we call Build_Code recursively
1108 function Get_Assoc_Expr
(Assoc
: Node_Id
) return Node_Id
;
1109 -- For an association with a box, use value given by aspect
1110 -- Default_Component_Value of array type if specified, else use
1111 -- value given by aspect Default_Value for component type itself
1112 -- if specified, else return Empty.
1114 function Local_Compile_Time_Known_Value
(E
: Node_Id
) return Boolean;
1115 function Local_Expr_Value
(E
: Node_Id
) return Uint
;
1116 -- These two Local routines are used to replace the corresponding ones
1117 -- in sem_eval because while processing the bounds of an aggregate with
1118 -- discrete choices whose index type is an enumeration, we build static
1119 -- expressions not recognized by Compile_Time_Known_Value as such since
1120 -- they have not yet been analyzed and resolved. All the expressions in
1121 -- question are things like Index_Base_Name'Val (Const) which we can
1122 -- easily recognize as being constant.
1128 function Add
(Val
: Int
; To
: Node_Id
) return Node_Id
is
1133 U_Val
: constant Uint
:= UI_From_Int
(Val
);
1136 -- Note: do not try to optimize the case of Val = 0, because
1137 -- we need to build a new node with the proper Sloc value anyway.
1139 -- First test if we can do constant folding
1141 if Local_Compile_Time_Known_Value
(To
) then
1142 U_To
:= Local_Expr_Value
(To
) + Val
;
1144 -- Determine if our constant is outside the range of the index.
1145 -- If so return an Empty node. This empty node will be caught
1146 -- by Empty_Range below.
1148 if Compile_Time_Known_Value
(Index_Base_L
)
1149 and then U_To
< Expr_Value
(Index_Base_L
)
1153 elsif Compile_Time_Known_Value
(Index_Base_H
)
1154 and then U_To
> Expr_Value
(Index_Base_H
)
1159 Expr_Pos
:= Make_Integer_Literal
(Loc
, U_To
);
1160 Set_Is_Static_Expression
(Expr_Pos
);
1162 if not Is_Enumeration_Type
(Index_Base
) then
1165 -- If we are dealing with enumeration return
1166 -- Index_Base'Val (Expr_Pos)
1170 Make_Attribute_Reference
1172 Prefix
=> Index_Base_Name
,
1173 Attribute_Name
=> Name_Val
,
1174 Expressions
=> New_List
(Expr_Pos
));
1180 -- If we are here no constant folding possible
1182 if not Is_Enumeration_Type
(Index_Base
) then
1185 Left_Opnd
=> Duplicate_Subexpr
(To
),
1186 Right_Opnd
=> Make_Integer_Literal
(Loc
, U_Val
));
1188 -- If we are dealing with enumeration return
1189 -- Index_Base'Val (Index_Base'Pos (To) + Val)
1193 Make_Attribute_Reference
1195 Prefix
=> Index_Base_Name
,
1196 Attribute_Name
=> Name_Pos
,
1197 Expressions
=> New_List
(Duplicate_Subexpr
(To
)));
1201 Left_Opnd
=> To_Pos
,
1202 Right_Opnd
=> Make_Integer_Literal
(Loc
, U_Val
));
1205 Make_Attribute_Reference
1207 Prefix
=> Index_Base_Name
,
1208 Attribute_Name
=> Name_Val
,
1209 Expressions
=> New_List
(Expr_Pos
));
1219 function Empty_Range
(L
, H
: Node_Id
) return Boolean is
1220 Is_Empty
: Boolean := False;
1225 -- First check if L or H were already detected as overflowing the
1226 -- index base range type by function Add above. If this is so Add
1227 -- returns the empty node.
1229 if No
(L
) or else No
(H
) then
1233 for J
in 1 .. 3 loop
1236 -- L > H range is empty
1242 -- B_L > H range must be empty
1245 Low
:= Index_Base_L
;
1248 -- L > B_H range must be empty
1252 High
:= Index_Base_H
;
1255 if Local_Compile_Time_Known_Value
(Low
)
1257 Local_Compile_Time_Known_Value
(High
)
1260 UI_Gt
(Local_Expr_Value
(Low
), Local_Expr_Value
(High
));
1273 function Equal
(L
, H
: Node_Id
) return Boolean is
1278 elsif Local_Compile_Time_Known_Value
(L
)
1280 Local_Compile_Time_Known_Value
(H
)
1282 return UI_Eq
(Local_Expr_Value
(L
), Local_Expr_Value
(H
));
1294 Expr
: Node_Id
) return List_Id
1296 function Add_Loop_Actions
(Lis
: List_Id
) return List_Id
;
1297 -- Collect insert_actions generated in the construction of a loop,
1298 -- and prepend them to the sequence of assignments to complete the
1299 -- eventual body of the loop.
1301 ----------------------
1302 -- Add_Loop_Actions --
1303 ----------------------
1305 function Add_Loop_Actions
(Lis
: List_Id
) return List_Id
is
1309 -- Ada 2005 (AI-287): Do nothing else in case of default
1310 -- initialized component.
1315 elsif Nkind
(Parent
(Expr
)) = N_Component_Association
1316 and then Present
(Loop_Actions
(Parent
(Expr
)))
1318 Append_List
(Lis
, Loop_Actions
(Parent
(Expr
)));
1319 Res
:= Loop_Actions
(Parent
(Expr
));
1320 Set_Loop_Actions
(Parent
(Expr
), No_List
);
1326 end Add_Loop_Actions
;
1330 Stmts
: constant List_Id
:= New_List
;
1332 Comp_Typ
: Entity_Id
:= Empty
;
1334 Indexed_Comp
: Node_Id
;
1335 Init_Call
: Node_Id
;
1336 New_Indexes
: List_Id
;
1338 -- Start of processing for Gen_Assign
1341 if No
(Indexes
) then
1342 New_Indexes
:= New_List
;
1344 New_Indexes
:= New_Copy_List_Tree
(Indexes
);
1347 Append_To
(New_Indexes
, Ind
);
1349 if Present
(Next_Index
(Index
)) then
1352 Build_Array_Aggr_Code
1355 Index
=> Next_Index
(Index
),
1357 Scalar_Comp
=> Scalar_Comp
,
1358 Indexes
=> New_Indexes
));
1361 -- If we get here then we are at a bottom-level (sub-)aggregate
1365 (Make_Indexed_Component
(Loc
,
1366 Prefix
=> New_Copy_Tree
(Into
),
1367 Expressions
=> New_Indexes
));
1369 Set_Assignment_OK
(Indexed_Comp
);
1371 -- Ada 2005 (AI-287): In case of default initialized component, Expr
1372 -- is not present (and therefore we also initialize Expr_Q to empty).
1374 Expr_Q
:= Unqualify
(Expr
);
1376 if Present
(Etype
(N
)) and then Etype
(N
) /= Any_Composite
then
1377 Comp_Typ
:= Component_Type
(Etype
(N
));
1378 pragma Assert
(Comp_Typ
= Ctype
); -- AI-287
1380 elsif Present
(Next
(First
(New_Indexes
))) then
1382 -- Ada 2005 (AI-287): Do nothing in case of default initialized
1383 -- component because we have received the component type in
1384 -- the formal parameter Ctype.
1386 -- ??? Some assert pragmas have been added to check if this new
1387 -- formal can be used to replace this code in all cases.
1389 if Present
(Expr
) then
1391 -- This is a multidimensional array. Recover the component type
1392 -- from the outermost aggregate, because subaggregates do not
1393 -- have an assigned type.
1400 while Present
(P
) loop
1401 if Nkind
(P
) = N_Aggregate
1402 and then Present
(Etype
(P
))
1404 Comp_Typ
:= Component_Type
(Etype
(P
));
1412 pragma Assert
(Comp_Typ
= Ctype
); -- AI-287
1417 -- Ada 2005 (AI-287): We only analyze the expression in case of non-
1418 -- default initialized components (otherwise Expr_Q is not present).
1421 and then Nkind
(Expr_Q
) in N_Aggregate | N_Extension_Aggregate
1423 -- At this stage the Expression may not have been analyzed yet
1424 -- because the array aggregate code has not been updated to use
1425 -- the Expansion_Delayed flag and avoid analysis altogether to
1426 -- solve the same problem (see Resolve_Aggr_Expr). So let us do
1427 -- the analysis of non-array aggregates now in order to get the
1428 -- value of Expansion_Delayed flag for the inner aggregate ???
1430 -- In the case of an iterated component association, the analysis
1431 -- of the generated loop will analyze the expression in the
1432 -- proper context, in which the loop parameter is visible.
1434 if Present
(Comp_Typ
) and then not Is_Array_Type
(Comp_Typ
) then
1435 if Nkind
(Parent
(Expr_Q
)) = N_Iterated_Component_Association
1436 or else Nkind
(Parent
(Parent
((Expr_Q
)))) =
1437 N_Iterated_Component_Association
1441 Analyze_And_Resolve
(Expr_Q
, Comp_Typ
);
1445 if Is_Delayed_Aggregate
(Expr_Q
) then
1447 -- This is either a subaggregate of a multidimensional array,
1448 -- or a component of an array type whose component type is
1449 -- also an array. In the latter case, the expression may have
1450 -- component associations that provide different bounds from
1451 -- those of the component type, and sliding must occur. Instead
1452 -- of decomposing the current aggregate assignment, force the
1453 -- reanalysis of the assignment, so that a temporary will be
1454 -- generated in the usual fashion, and sliding will take place.
1456 if Nkind
(Parent
(N
)) = N_Assignment_Statement
1457 and then Is_Array_Type
(Comp_Typ
)
1458 and then Present
(Component_Associations
(Expr_Q
))
1459 and then Must_Slide
(N
, Comp_Typ
, Etype
(Expr_Q
))
1461 Set_Expansion_Delayed
(Expr_Q
, False);
1462 Set_Analyzed
(Expr_Q
, False);
1467 Late_Expansion
(Expr_Q
, Etype
(Expr_Q
), Indexed_Comp
));
1472 if Present
(Expr
) then
1473 Initialize_Component
1475 Comp
=> Indexed_Comp
,
1476 Comp_Typ
=> Comp_Typ
,
1480 -- Ada 2005 (AI-287): In case of default initialized component, call
1481 -- the initialization subprogram associated with the component type.
1482 -- If the component type is an access type, add an explicit null
1483 -- assignment, because for the back-end there is an initialization
1484 -- present for the whole aggregate, and no default initialization
1487 -- In addition, if the component type is controlled, we must call
1488 -- its Initialize procedure explicitly, because there is no explicit
1489 -- object creation that will invoke it otherwise.
1492 if Present
(Base_Init_Proc
(Base_Type
(Ctype
)))
1493 or else Has_Task
(Base_Type
(Ctype
))
1495 Append_List_To
(Stmts
,
1496 Build_Initialization_Call
(Loc
,
1497 Id_Ref
=> Indexed_Comp
,
1499 With_Default_Init
=> True));
1501 -- If the component type has invariants, add an invariant
1502 -- check after the component is default-initialized. It will
1503 -- be analyzed and resolved before the code for initialization
1504 -- of other components.
1506 if Has_Invariants
(Ctype
) then
1507 Set_Etype
(Indexed_Comp
, Ctype
);
1508 Append_To
(Stmts
, Make_Invariant_Call
(Indexed_Comp
));
1512 if Needs_Finalization
(Ctype
) then
1515 (Obj_Ref
=> New_Copy_Tree
(Indexed_Comp
),
1518 -- Guard against a missing [Deep_]Initialize when the component
1519 -- type was not properly frozen.
1521 if Present
(Init_Call
) then
1522 Append_To
(Stmts
, Init_Call
);
1526 -- If Default_Initial_Condition applies to the component type,
1527 -- add a DIC check after the component is default-initialized,
1528 -- as well as after an Initialize procedure is called, in the
1529 -- case of components of a controlled type. It will be analyzed
1530 -- and resolved before the code for initialization of other
1533 -- Theoretically this might also be needed for cases where Expr
1534 -- is not empty, but a default init still applies, such as for
1535 -- Default_Value cases, in which case we won't get here. ???
1537 if Has_DIC
(Ctype
) and then Present
(DIC_Procedure
(Ctype
)) then
1539 Build_DIC_Call
(Loc
, New_Copy_Tree
(Indexed_Comp
), Ctype
));
1543 return Add_Loop_Actions
(Stmts
);
1550 function Gen_Loop
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
is
1551 Is_Iterated_Component
: constant Boolean :=
1552 Parent_Kind
(Expr
) = N_Iterated_Component_Association
;
1565 -- Index_Base'(L) .. Index_Base'(H)
1567 L_Iteration_Scheme
: Node_Id
;
1568 -- L_J in Index_Base'(L) .. Index_Base'(H)
1571 -- The statements to execute in the loop
1573 S
: constant List_Id
:= New_List
;
1574 -- List of statements
1577 -- Copy of expression tree, used for checking purposes
1580 -- If loop bounds define an empty range return the null statement
1582 if Empty_Range
(L
, H
) then
1583 Append_To
(S
, Make_Null_Statement
(Loc
));
1585 -- Ada 2005 (AI-287): Nothing else need to be done in case of
1586 -- default initialized component.
1592 -- The expression must be type-checked even though no component
1593 -- of the aggregate will have this value. This is done only for
1594 -- actual components of the array, not for subaggregates. Do
1595 -- the check on a copy, because the expression may be shared
1596 -- among several choices, some of which might be non-null.
1598 if Present
(Etype
(N
))
1599 and then Is_Array_Type
(Etype
(N
))
1600 and then No
(Next_Index
(Index
))
1602 Expander_Mode_Save_And_Set
(False);
1603 Tcopy
:= New_Copy_Tree
(Expr
);
1604 Set_Parent
(Tcopy
, N
);
1606 -- For iterated_component_association analyze and resolve
1607 -- the expression with name of the index parameter visible.
1608 -- To manipulate scopes, we use entity of the implicit loop.
1610 if Is_Iterated_Component
then
1612 Index_Parameter
: constant Entity_Id
:=
1613 Defining_Identifier
(Parent
(Expr
));
1615 Push_Scope
(Scope
(Index_Parameter
));
1616 Enter_Name
(Index_Parameter
);
1618 (Tcopy
, Component_Type
(Etype
(N
)));
1622 -- For ordinary component association, just analyze and
1623 -- resolve the expression.
1626 Analyze_And_Resolve
(Tcopy
, Component_Type
(Etype
(N
)));
1629 Expander_Mode_Restore
;
1635 -- If loop bounds are the same then generate an assignment, unless
1636 -- the parent construct is an Iterated_Component_Association.
1638 elsif Equal
(L
, H
) and then not Is_Iterated_Component
then
1639 return Gen_Assign
(New_Copy_Tree
(L
), Expr
);
1641 -- If H - L <= 2 then generate a sequence of assignments when we are
1642 -- processing the bottom most aggregate and it contains scalar
1645 elsif No
(Next_Index
(Index
))
1646 and then Scalar_Comp
1647 and then Local_Compile_Time_Known_Value
(L
)
1648 and then Local_Compile_Time_Known_Value
(H
)
1649 and then Local_Expr_Value
(H
) - Local_Expr_Value
(L
) <= 2
1650 and then not Is_Iterated_Component
1652 Append_List_To
(S
, Gen_Assign
(New_Copy_Tree
(L
), Expr
));
1653 Append_List_To
(S
, Gen_Assign
(Add
(1, To
=> L
), Expr
));
1655 if Local_Expr_Value
(H
) - Local_Expr_Value
(L
) = 2 then
1656 Append_List_To
(S
, Gen_Assign
(Add
(2, To
=> L
), Expr
));
1662 -- Otherwise construct the loop, starting with the loop index L_J
1664 if Is_Iterated_Component
then
1666 -- Create a new scope for the loop variable so that the
1667 -- following Gen_Assign (that ends up calling
1668 -- Preanalyze_And_Resolve) can correctly find it.
1670 Ent
:= New_Internal_Entity
(E_Loop
,
1671 Current_Scope
, Loc
, 'L');
1672 Set_Etype
(Ent
, Standard_Void_Type
);
1673 Set_Parent
(Ent
, Parent
(Parent
(Expr
)));
1677 Make_Defining_Identifier
(Loc
,
1678 Chars
=> (Chars
(Defining_Identifier
(Parent
(Expr
)))));
1682 -- The Etype will be set by a later Analyze call.
1683 Set_Etype
(L_J
, Any_Type
);
1685 Mutate_Ekind
(L_J
, E_Variable
);
1686 Set_Is_Not_Self_Hidden
(L_J
);
1687 Set_Scope
(L_J
, Ent
);
1689 L_J
:= Make_Temporary
(Loc
, 'J', L
);
1692 -- Construct "L .. H" in Index_Base. We use a qualified expression
1693 -- for the bound to convert to the index base, but we don't need
1694 -- to do that if we already have the base type at hand.
1696 if Etype
(L
) = Index_Base
then
1697 L_L
:= New_Copy_Tree
(L
);
1700 Make_Qualified_Expression
(Loc
,
1701 Subtype_Mark
=> Index_Base_Name
,
1702 Expression
=> New_Copy_Tree
(L
));
1705 if Etype
(H
) = Index_Base
then
1706 L_H
:= New_Copy_Tree
(H
);
1709 Make_Qualified_Expression
(Loc
,
1710 Subtype_Mark
=> Index_Base_Name
,
1711 Expression
=> New_Copy_Tree
(H
));
1719 -- Construct "for L_J in Index_Base range L .. H"
1721 L_Iteration_Scheme
:=
1722 Make_Iteration_Scheme
(Loc
,
1723 Loop_Parameter_Specification
=>
1724 Make_Loop_Parameter_Specification
(Loc
,
1725 Defining_Identifier
=> L_J
,
1726 Discrete_Subtype_Definition
=> L_Range
));
1728 -- Construct the statements to execute in the loop body
1730 L_Body
:= Gen_Assign
(New_Occurrence_Of
(L_J
, Loc
), Expr
);
1732 -- Construct the final loop
1735 Make_Implicit_Loop_Statement
1737 Identifier
=> Empty
,
1738 Iteration_Scheme
=> L_Iteration_Scheme
,
1739 Statements
=> L_Body
));
1741 if Is_Iterated_Component
then
1745 -- A small optimization: if the aggregate is initialized with a box
1746 -- and the component type has no initialization procedure, remove the
1747 -- useless empty loop.
1749 if Nkind
(First
(S
)) = N_Loop_Statement
1750 and then Is_Empty_List
(Statements
(First
(S
)))
1752 return New_List
(Make_Null_Statement
(Loc
));
1762 -- The code built is
1764 -- W_J : Index_Base := L;
1765 -- while W_J < H loop
1766 -- W_J := Index_Base'Succ (W);
1770 function Gen_While
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
is
1774 -- W_J : Base_Type := L;
1776 W_Iteration_Scheme
: Node_Id
;
1779 W_Index_Succ
: Node_Id
;
1780 -- Index_Base'Succ (J)
1782 W_Increment
: Node_Id
;
1783 -- W_J := Index_Base'Succ (W)
1785 W_Body
: constant List_Id
:= New_List
;
1786 -- The statements to execute in the loop
1788 S
: constant List_Id
:= New_List
;
1789 -- list of statement
1792 -- If loop bounds define an empty range or are equal return null
1794 if Empty_Range
(L
, H
) or else Equal
(L
, H
) then
1795 Append_To
(S
, Make_Null_Statement
(Loc
));
1799 -- Build the decl of W_J
1801 W_J
:= Make_Temporary
(Loc
, 'J', L
);
1803 Make_Object_Declaration
1805 Defining_Identifier
=> W_J
,
1806 Object_Definition
=> Index_Base_Name
,
1809 -- Theoretically we should do a New_Copy_Tree (L) here, but we know
1810 -- that in this particular case L is a fresh Expr generated by
1811 -- Add which we are the only ones to use.
1813 Append_To
(S
, W_Decl
);
1815 -- Construct " while W_J < H"
1817 W_Iteration_Scheme
:=
1818 Make_Iteration_Scheme
1820 Condition
=> Make_Op_Lt
1822 Left_Opnd
=> New_Occurrence_Of
(W_J
, Loc
),
1823 Right_Opnd
=> New_Copy_Tree
(H
)));
1825 -- Construct the statements to execute in the loop body
1828 Make_Attribute_Reference
1830 Prefix
=> Index_Base_Name
,
1831 Attribute_Name
=> Name_Succ
,
1832 Expressions
=> New_List
(New_Occurrence_Of
(W_J
, Loc
)));
1835 Make_OK_Assignment_Statement
1837 Name
=> New_Occurrence_Of
(W_J
, Loc
),
1838 Expression
=> W_Index_Succ
);
1840 Append_To
(W_Body
, W_Increment
);
1842 Append_List_To
(W_Body
,
1843 Gen_Assign
(New_Occurrence_Of
(W_J
, Loc
), Expr
));
1845 -- Construct the final loop
1848 Make_Implicit_Loop_Statement
1850 Identifier
=> Empty
,
1851 Iteration_Scheme
=> W_Iteration_Scheme
,
1852 Statements
=> W_Body
));
1857 --------------------
1858 -- Get_Assoc_Expr --
1859 --------------------
1861 -- Duplicate the expression in case we will be generating several loops.
1862 -- As a result the expression is no longer shared between the loops and
1863 -- is reevaluated for each such loop.
1865 function Get_Assoc_Expr
(Assoc
: Node_Id
) return Node_Id
is
1866 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
1869 if Box_Present
(Assoc
) then
1870 if Present
(Default_Aspect_Component_Value
(Typ
)) then
1871 return New_Copy_Tree
(Default_Aspect_Component_Value
(Typ
));
1872 elsif Needs_Simple_Initialization
(Ctype
) then
1873 return New_Copy_Tree
(Get_Simple_Init_Val
(Ctype
, N
));
1879 -- The expression will be passed to Gen_Loop, which immediately
1880 -- calls Parent_Kind on it, so we set Parent when it matters.
1883 Expr
: constant Node_Id
:= New_Copy_Tree
(Expression
(Assoc
))
1885 Copy_Parent
(To
=> Expr
, From
=> Expression
(Assoc
));
1890 ---------------------
1891 -- Index_Base_Name --
1892 ---------------------
1894 function Index_Base_Name
return Node_Id
is
1896 return New_Occurrence_Of
(Index_Base
, Sloc
(N
));
1897 end Index_Base_Name
;
1899 ------------------------------------
1900 -- Local_Compile_Time_Known_Value --
1901 ------------------------------------
1903 function Local_Compile_Time_Known_Value
(E
: Node_Id
) return Boolean is
1905 return Compile_Time_Known_Value
(E
)
1907 (Nkind
(E
) = N_Attribute_Reference
1908 and then Attribute_Name
(E
) = Name_Val
1909 and then Compile_Time_Known_Value
(First
(Expressions
(E
))));
1910 end Local_Compile_Time_Known_Value
;
1912 ----------------------
1913 -- Local_Expr_Value --
1914 ----------------------
1916 function Local_Expr_Value
(E
: Node_Id
) return Uint
is
1918 if Compile_Time_Known_Value
(E
) then
1919 return Expr_Value
(E
);
1921 return Expr_Value
(First
(Expressions
(E
)));
1923 end Local_Expr_Value
;
1927 New_Code
: constant List_Id
:= New_List
;
1929 Aggr_Bounds
: constant Range_Nodes
:=
1930 Get_Index_Bounds
(Aggregate_Bounds
(N
));
1931 Aggr_L
: Node_Id
renames Aggr_Bounds
.First
;
1932 Aggr_H
: Node_Id
renames Aggr_Bounds
.Last
;
1933 -- The aggregate bounds of this specific subaggregate. Note that if the
1934 -- code generated by Build_Array_Aggr_Code is executed then these bounds
1935 -- are OK. Otherwise a Constraint_Error would have been raised.
1937 Aggr_Low
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Aggr_L
);
1938 Aggr_High
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Aggr_H
);
1939 -- After Duplicate_Subexpr these are side-effect free
1945 Bounds
: Range_Nodes
;
1946 Low
: Node_Id
renames Bounds
.First
;
1947 High
: Node_Id
renames Bounds
.Last
;
1949 Nb_Choices
: Nat
:= 0;
1950 Table
: Case_Table_Type
(1 .. Number_Of_Choices
(N
));
1951 -- Used to sort all the different choice values
1954 -- Number of elements in the positional aggregate
1956 Others_Assoc
: Node_Id
:= Empty
;
1958 -- Start of processing for Build_Array_Aggr_Code
1961 -- First before we start, a special case. If we have a bit packed
1962 -- array represented as a modular type, then clear the value to
1963 -- zero first, to ensure that unused bits are properly cleared.
1966 and then Is_Bit_Packed_Array
(Typ
)
1967 and then Is_Modular_Integer_Type
(Packed_Array_Impl_Type
(Typ
))
1970 Zero
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Uint_0
);
1972 Analyze_And_Resolve
(Zero
, Packed_Array_Impl_Type
(Typ
));
1973 Append_To
(New_Code
,
1974 Make_Assignment_Statement
(Loc
,
1975 Name
=> New_Copy_Tree
(Into
),
1976 Expression
=> Unchecked_Convert_To
(Typ
, Zero
)));
1980 -- If the component type contains tasks, we need to build a Master
1981 -- entity in the current scope, because it will be needed if build-
1982 -- in-place functions are called in the expanded code.
1984 if Nkind
(Parent
(N
)) = N_Object_Declaration
and then Has_Task
(Typ
) then
1985 Build_Master_Entity
(Defining_Identifier
(Parent
(N
)));
1988 -- STEP 1: Process component associations
1990 -- For those associations that may generate a loop, initialize
1991 -- Loop_Actions to collect inserted actions that may be crated.
1993 -- Skip this if no component associations
1995 if Is_Null_Aggregate
(N
) then
1998 elsif No
(Expressions
(N
)) then
2000 -- STEP 1 (a): Sort the discrete choices
2002 Assoc
:= First
(Component_Associations
(N
));
2003 while Present
(Assoc
) loop
2004 Choice
:= First
(Choice_List
(Assoc
));
2005 while Present
(Choice
) loop
2006 if Nkind
(Choice
) = N_Others_Choice
then
2007 Others_Assoc
:= Assoc
;
2011 Bounds
:= Get_Index_Bounds
(Choice
);
2014 Set_Loop_Actions
(Assoc
, New_List
);
2017 Nb_Choices
:= Nb_Choices
+ 1;
2019 Table
(Nb_Choices
) :=
2022 Choice_Node
=> Get_Assoc_Expr
(Assoc
));
2030 -- If there is more than one set of choices these must be static
2031 -- and we can therefore sort them. Remember that Nb_Choices does not
2032 -- account for an others choice.
2034 if Nb_Choices
> 1 then
2035 Sort_Case_Table
(Table
);
2038 -- STEP 1 (b): take care of the whole set of discrete choices
2040 for J
in 1 .. Nb_Choices
loop
2041 Low
:= Table
(J
).Choice_Lo
;
2042 High
:= Table
(J
).Choice_Hi
;
2043 Expr
:= Table
(J
).Choice_Node
;
2044 Append_List
(Gen_Loop
(Low
, High
, Expr
), To
=> New_Code
);
2047 -- STEP 1 (c): generate the remaining loops to cover others choice
2048 -- We don't need to generate loops over empty gaps, but if there is
2049 -- a single empty range we must analyze the expression for semantics
2051 if Present
(Others_Assoc
) then
2053 First
: Boolean := True;
2056 for J
in 0 .. Nb_Choices
loop
2060 Low
:= Add
(1, To
=> Table
(J
).Choice_Hi
);
2063 if J
= Nb_Choices
then
2066 High
:= Add
(-1, To
=> Table
(J
+ 1).Choice_Lo
);
2069 -- If this is an expansion within an init proc, make
2070 -- sure that discriminant references are replaced by
2071 -- the corresponding discriminal.
2073 if Inside_Init_Proc
then
2074 if Is_Entity_Name
(Low
)
2075 and then Ekind
(Entity
(Low
)) = E_Discriminant
2077 Set_Entity
(Low
, Discriminal
(Entity
(Low
)));
2080 if Is_Entity_Name
(High
)
2081 and then Ekind
(Entity
(High
)) = E_Discriminant
2083 Set_Entity
(High
, Discriminal
(Entity
(High
)));
2087 if First
or else not Empty_Range
(Low
, High
) then
2089 Set_Loop_Actions
(Others_Assoc
, New_List
);
2090 Expr
:= Get_Assoc_Expr
(Others_Assoc
);
2091 Append_List
(Gen_Loop
(Low
, High
, Expr
), To
=> New_Code
);
2097 -- STEP 2: Process positional components
2100 -- STEP 2 (a): Generate the assignments for each positional element
2101 -- Note that here we have to use Aggr_L rather than Aggr_Low because
2102 -- Aggr_L is analyzed and Add wants an analyzed expression.
2104 Expr
:= First
(Expressions
(N
));
2106 while Present
(Expr
) loop
2107 Nb_Elements
:= Nb_Elements
+ 1;
2108 Append_List
(Gen_Assign
(Add
(Nb_Elements
, To
=> Aggr_L
), Expr
),
2113 -- STEP 2 (b): Generate final loop if an others choice is present.
2114 -- Here Nb_Elements gives the offset of the last positional element.
2116 if Present
(Component_Associations
(N
)) then
2117 Assoc
:= Last
(Component_Associations
(N
));
2119 if Nkind
(Assoc
) = N_Iterated_Component_Association
then
2120 -- Ada 2022: generate a loop to have a proper scope for
2121 -- the identifier that typically appears in the expression.
2122 -- The lower bound of the loop is the position after all
2123 -- previous positional components.
2125 Append_List
(Gen_Loop
(Add
(Nb_Elements
+ 1, To
=> Aggr_L
),
2127 Expression
(Assoc
)),
2130 -- Ada 2005 (AI-287)
2132 Append_List
(Gen_While
(Add
(Nb_Elements
, To
=> Aggr_L
),
2134 Get_Assoc_Expr
(Assoc
)),
2141 end Build_Array_Aggr_Code
;
2143 -------------------------------------
2144 -- Build_Assignment_With_Temporary --
2145 -------------------------------------
2147 function Build_Assignment_With_Temporary
2150 Source
: Node_Id
) return List_Id
2152 Loc
: constant Source_Ptr
:= Sloc
(Source
);
2154 Aggr_Code
: List_Id
;
2158 Aggr_Code
:= New_List
;
2160 Tmp
:= Build_Temporary_On_Secondary_Stack
(Loc
, Typ
, Aggr_Code
);
2162 Append_To
(Aggr_Code
,
2163 Make_OK_Assignment_Statement
(Loc
,
2165 Make_Explicit_Dereference
(Loc
,
2166 Prefix
=> New_Occurrence_Of
(Tmp
, Loc
)),
2167 Expression
=> Source
));
2169 Append_To
(Aggr_Code
,
2170 Make_OK_Assignment_Statement
(Loc
,
2173 Make_Explicit_Dereference
(Loc
,
2174 Prefix
=> New_Occurrence_Of
(Tmp
, Loc
))));
2177 end Build_Assignment_With_Temporary
;
2179 ----------------------------
2180 -- Build_Record_Aggr_Code --
2181 ----------------------------
2183 function Build_Record_Aggr_Code
2186 Lhs
: Node_Id
) return List_Id
2188 Loc
: constant Source_Ptr
:= Sloc
(N
);
2189 L
: constant List_Id
:= New_List
;
2190 N_Typ
: constant Entity_Id
:= Etype
(N
);
2196 Comp_Type
: Entity_Id
;
2197 Selector
: Entity_Id
;
2198 Comp_Expr
: Node_Id
;
2201 Ancestor_Is_Subtype_Mark
: Boolean := False;
2203 Init_Typ
: Entity_Id
:= Empty
;
2205 Finalization_Done
: Boolean := False;
2206 -- True if Generate_Finalization_Actions has already been called; calls
2207 -- after the first do nothing.
2209 function Ancestor_Discriminant_Value
(Disc
: Entity_Id
) return Node_Id
;
2210 -- Returns the value that the given discriminant of an ancestor type
2211 -- should receive (in the absence of a conflict with the value provided
2212 -- by an ancestor part of an extension aggregate).
2214 procedure Check_Ancestor_Discriminants
(Anc_Typ
: Entity_Id
);
2215 -- Check that each of the discriminant values defined by the ancestor
2216 -- part of an extension aggregate match the corresponding values
2217 -- provided by either an association of the aggregate or by the
2218 -- constraint imposed by a parent type (RM95-4.3.2(8)).
2220 function Compatible_Int_Bounds
2221 (Agg_Bounds
: Node_Id
;
2222 Typ_Bounds
: Node_Id
) return Boolean;
2223 -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is
2224 -- assumed that both bounds are integer ranges.
2226 procedure Generate_Finalization_Actions
;
2227 -- Deal with the various controlled type data structure initializations
2228 -- (but only if it hasn't been done already).
2230 function Get_Constraint_Association
(T
: Entity_Id
) return Node_Id
;
2231 -- Returns the first discriminant association in the constraint
2232 -- associated with T, if any, otherwise returns Empty.
2234 function Get_Explicit_Discriminant_Value
(D
: Entity_Id
) return Node_Id
;
2235 -- If the ancestor part is an unconstrained type and further ancestors
2236 -- do not provide discriminants for it, check aggregate components for
2237 -- values of the discriminants.
2239 procedure Init_Hidden_Discriminants
(Typ
: Entity_Id
; List
: List_Id
);
2240 -- If Typ is derived, and constrains discriminants of the parent type,
2241 -- these discriminants are not components of the aggregate, and must be
2242 -- initialized. The assignments are appended to List. The same is done
2243 -- if Typ derives from an already constrained subtype of a discriminated
2246 procedure Init_Stored_Discriminants
;
2247 -- If the type is derived and has inherited discriminants, generate
2248 -- explicit assignments for each, using the store constraint of the
2249 -- type. Note that both visible and stored discriminants must be
2250 -- initialized in case the derived type has some renamed and some
2251 -- constrained discriminants.
2253 procedure Init_Visible_Discriminants
;
2254 -- If type has discriminants, retrieve their values from aggregate,
2255 -- and generate explicit assignments for each. This does not include
2256 -- discriminants inherited from ancestor, which are handled above.
2257 -- The type of the aggregate is a subtype created ealier using the
2258 -- given values of the discriminant components of the aggregate.
2260 function Is_Int_Range_Bounds
(Bounds
: Node_Id
) return Boolean;
2261 -- Check whether Bounds is a range node and its lower and higher bounds
2262 -- are integers literals.
2264 function Replace_Type
(Expr
: Node_Id
) return Traverse_Result
;
2265 -- If the aggregate contains a self-reference, traverse each expression
2266 -- to replace a possible self-reference with a reference to the proper
2267 -- component of the target of the assignment.
2269 function Rewrite_Discriminant
(Expr
: Node_Id
) return Traverse_Result
;
2270 -- If default expression of a component mentions a discriminant of the
2271 -- type, it must be rewritten as the discriminant of the target object.
2273 ---------------------------------
2274 -- Ancestor_Discriminant_Value --
2275 ---------------------------------
2277 function Ancestor_Discriminant_Value
(Disc
: Entity_Id
) return Node_Id
is
2279 Assoc_Elmt
: Elmt_Id
;
2280 Aggr_Comp
: Entity_Id
;
2281 Corresp_Disc
: Entity_Id
;
2282 Current_Typ
: Entity_Id
:= Base_Type
(Typ
);
2283 Parent_Typ
: Entity_Id
;
2284 Parent_Disc
: Entity_Id
;
2285 Save_Assoc
: Node_Id
:= Empty
;
2288 -- First check any discriminant associations to see if any of them
2289 -- provide a value for the discriminant.
2291 if Present
(Discriminant_Specifications
(Parent
(Current_Typ
))) then
2292 Assoc
:= First
(Component_Associations
(N
));
2293 while Present
(Assoc
) loop
2294 Aggr_Comp
:= Entity
(First
(Choices
(Assoc
)));
2296 if Ekind
(Aggr_Comp
) = E_Discriminant
then
2297 Save_Assoc
:= Expression
(Assoc
);
2299 Corresp_Disc
:= Corresponding_Discriminant
(Aggr_Comp
);
2300 while Present
(Corresp_Disc
) loop
2302 -- If found a corresponding discriminant then return the
2303 -- value given in the aggregate. (Note: this is not
2304 -- correct in the presence of side effects. ???)
2306 if Disc
= Corresp_Disc
then
2307 return Duplicate_Subexpr
(Expression
(Assoc
));
2310 Corresp_Disc
:= Corresponding_Discriminant
(Corresp_Disc
);
2318 -- No match found in aggregate, so chain up parent types to find
2319 -- a constraint that defines the value of the discriminant.
2321 Parent_Typ
:= Etype
(Current_Typ
);
2322 while Current_Typ
/= Parent_Typ
loop
2323 if Has_Discriminants
(Parent_Typ
)
2324 and then not Has_Unknown_Discriminants
(Parent_Typ
)
2326 Parent_Disc
:= First_Discriminant
(Parent_Typ
);
2328 -- We either get the association from the subtype indication
2329 -- of the type definition itself, or from the discriminant
2330 -- constraint associated with the type entity (which is
2331 -- preferable, but it's not always present ???)
2333 if Is_Empty_Elmt_List
(Discriminant_Constraint
(Current_Typ
))
2335 Assoc
:= Get_Constraint_Association
(Current_Typ
);
2336 Assoc_Elmt
:= No_Elmt
;
2339 First_Elmt
(Discriminant_Constraint
(Current_Typ
));
2340 Assoc
:= Node
(Assoc_Elmt
);
2343 -- Traverse the discriminants of the parent type looking
2344 -- for one that corresponds.
2346 while Present
(Parent_Disc
) and then Present
(Assoc
) loop
2347 Corresp_Disc
:= Parent_Disc
;
2348 while Present
(Corresp_Disc
)
2349 and then Disc
/= Corresp_Disc
2351 Corresp_Disc
:= Corresponding_Discriminant
(Corresp_Disc
);
2354 if Disc
= Corresp_Disc
then
2355 if Nkind
(Assoc
) = N_Discriminant_Association
then
2356 Assoc
:= Expression
(Assoc
);
2359 -- If the located association directly denotes
2360 -- a discriminant, then use the value of a saved
2361 -- association of the aggregate. This is an approach
2362 -- used to handle certain cases involving multiple
2363 -- discriminants mapped to a single discriminant of
2364 -- a descendant. It's not clear how to locate the
2365 -- appropriate discriminant value for such cases. ???
2367 if Is_Entity_Name
(Assoc
)
2368 and then Ekind
(Entity
(Assoc
)) = E_Discriminant
2370 Assoc
:= Save_Assoc
;
2373 return Duplicate_Subexpr
(Assoc
);
2376 Next_Discriminant
(Parent_Disc
);
2378 if No
(Assoc_Elmt
) then
2382 Next_Elmt
(Assoc_Elmt
);
2384 if Present
(Assoc_Elmt
) then
2385 Assoc
:= Node
(Assoc_Elmt
);
2393 Current_Typ
:= Parent_Typ
;
2394 Parent_Typ
:= Etype
(Current_Typ
);
2397 -- In some cases there's no ancestor value to locate (such as
2398 -- when an ancestor part given by an expression defines the
2399 -- discriminant value).
2402 end Ancestor_Discriminant_Value
;
2404 ----------------------------------
2405 -- Check_Ancestor_Discriminants --
2406 ----------------------------------
2408 procedure Check_Ancestor_Discriminants
(Anc_Typ
: Entity_Id
) is
2410 Disc_Value
: Node_Id
;
2414 Discr
:= First_Discriminant
(Base_Type
(Anc_Typ
));
2415 while Present
(Discr
) loop
2416 Disc_Value
:= Ancestor_Discriminant_Value
(Discr
);
2418 if Present
(Disc_Value
) then
2419 Cond
:= Make_Op_Ne
(Loc
,
2421 Make_Selected_Component
(Loc
,
2422 Prefix
=> New_Copy_Tree
(Target
),
2423 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)),
2424 Right_Opnd
=> Disc_Value
);
2427 Make_Raise_Constraint_Error
(Loc
,
2429 Reason
=> CE_Discriminant_Check_Failed
));
2432 Next_Discriminant
(Discr
);
2434 end Check_Ancestor_Discriminants
;
2436 ---------------------------
2437 -- Compatible_Int_Bounds --
2438 ---------------------------
2440 function Compatible_Int_Bounds
2441 (Agg_Bounds
: Node_Id
;
2442 Typ_Bounds
: Node_Id
) return Boolean
2444 Agg_Lo
: constant Uint
:= Intval
(Low_Bound
(Agg_Bounds
));
2445 Agg_Hi
: constant Uint
:= Intval
(High_Bound
(Agg_Bounds
));
2446 Typ_Lo
: constant Uint
:= Intval
(Low_Bound
(Typ_Bounds
));
2447 Typ_Hi
: constant Uint
:= Intval
(High_Bound
(Typ_Bounds
));
2449 return Typ_Lo
<= Agg_Lo
and then Agg_Hi
<= Typ_Hi
;
2450 end Compatible_Int_Bounds
;
2452 -----------------------------------
2453 -- Generate_Finalization_Actions --
2454 -----------------------------------
2456 procedure Generate_Finalization_Actions
is
2458 -- Do the work only the first time this is called
2460 if Finalization_Done
then
2464 Finalization_Done
:= True;
2466 -- Determine the external finalization list. It is either the
2467 -- finalization list of the outer scope or the one coming from an
2468 -- outer aggregate. When the target is not a temporary, the proper
2469 -- scope is the scope of the target rather than the potentially
2470 -- transient current scope.
2472 if Is_Controlled
(Typ
) and then Ancestor_Is_Subtype_Mark
then
2473 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2474 Set_Assignment_OK
(Ref
);
2477 Make_Procedure_Call_Statement
(Loc
,
2480 (Find_Prim_Op
(Init_Typ
, Name_Initialize
), Loc
),
2481 Parameter_Associations
=> New_List
(New_Copy_Tree
(Ref
))));
2483 end Generate_Finalization_Actions
;
2485 --------------------------------
2486 -- Get_Constraint_Association --
2487 --------------------------------
2489 function Get_Constraint_Association
(T
: Entity_Id
) return Node_Id
is
2496 -- If type is private, get constraint from full view. This was
2497 -- previously done in an instance context, but is needed whenever
2498 -- the ancestor part has a discriminant, possibly inherited through
2499 -- multiple derivations.
2501 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
2502 Typ
:= Full_View
(Typ
);
2505 Indic
:= Subtype_Indication
(Type_Definition
(Parent
(Typ
)));
2507 -- Verify that the subtype indication carries a constraint
2509 if Nkind
(Indic
) = N_Subtype_Indication
2510 and then Present
(Constraint
(Indic
))
2512 return First
(Constraints
(Constraint
(Indic
)));
2516 end Get_Constraint_Association
;
2518 -------------------------------------
2519 -- Get_Explicit_Discriminant_Value --
2520 -------------------------------------
2522 function Get_Explicit_Discriminant_Value
2523 (D
: Entity_Id
) return Node_Id
2530 -- The aggregate has been normalized and all associations have a
2533 Assoc
:= First
(Component_Associations
(N
));
2534 while Present
(Assoc
) loop
2535 Choice
:= First
(Choices
(Assoc
));
2537 if Chars
(Choice
) = Chars
(D
) then
2538 Val
:= Expression
(Assoc
);
2547 end Get_Explicit_Discriminant_Value
;
2549 -------------------------------
2550 -- Init_Hidden_Discriminants --
2551 -------------------------------
2553 procedure Init_Hidden_Discriminants
(Typ
: Entity_Id
; List
: List_Id
) is
2554 function Is_Completely_Hidden_Discriminant
2555 (Discr
: Entity_Id
) return Boolean;
2556 -- Determine whether Discr is a completely hidden discriminant of
2559 ---------------------------------------
2560 -- Is_Completely_Hidden_Discriminant --
2561 ---------------------------------------
2563 function Is_Completely_Hidden_Discriminant
2564 (Discr
: Entity_Id
) return Boolean
2569 -- Use First/Next_Entity as First/Next_Discriminant do not yield
2570 -- completely hidden discriminants.
2572 Item
:= First_Entity
(Typ
);
2573 while Present
(Item
) loop
2574 if Ekind
(Item
) = E_Discriminant
2575 and then Is_Completely_Hidden
(Item
)
2576 and then Chars
(Original_Record_Component
(Item
)) =
2586 end Is_Completely_Hidden_Discriminant
;
2590 Base_Typ
: Entity_Id
;
2592 Discr_Constr
: Elmt_Id
;
2593 Discr_Init
: Node_Id
;
2594 Discr_Val
: Node_Id
;
2595 In_Aggr_Type
: Boolean;
2596 Par_Typ
: Entity_Id
;
2598 -- Start of processing for Init_Hidden_Discriminants
2601 -- The constraints on the hidden discriminants, if present, are kept
2602 -- in the Stored_Constraint list of the type itself, or in that of
2603 -- the base type. If not in the constraints of the aggregate itself,
2604 -- we examine ancestors to find discriminants that are not renamed
2605 -- by other discriminants but constrained explicitly.
2607 In_Aggr_Type
:= True;
2609 Base_Typ
:= Base_Type
(Typ
);
2610 while Is_Derived_Type
(Base_Typ
)
2612 (Present
(Stored_Constraint
(Base_Typ
))
2614 (In_Aggr_Type
and then Present
(Stored_Constraint
(Typ
))))
2616 Par_Typ
:= Etype
(Base_Typ
);
2618 if not Has_Discriminants
(Par_Typ
) then
2622 Discr
:= First_Discriminant
(Par_Typ
);
2624 -- We know that one of the stored-constraint lists is present
2626 if Present
(Stored_Constraint
(Base_Typ
)) then
2627 Discr_Constr
:= First_Elmt
(Stored_Constraint
(Base_Typ
));
2629 -- For private extension, stored constraint may be on full view
2631 elsif Is_Private_Type
(Base_Typ
)
2632 and then Present
(Full_View
(Base_Typ
))
2633 and then Present
(Stored_Constraint
(Full_View
(Base_Typ
)))
2636 First_Elmt
(Stored_Constraint
(Full_View
(Base_Typ
)));
2638 -- Otherwise, no discriminant to process
2641 Discr_Constr
:= No_Elmt
;
2644 while Present
(Discr
) and then Present
(Discr_Constr
) loop
2645 Discr_Val
:= Node
(Discr_Constr
);
2647 -- The parent discriminant is renamed in the derived type,
2648 -- nothing to initialize.
2650 -- type Deriv_Typ (Discr : ...)
2651 -- is new Parent_Typ (Discr => Discr);
2653 if Is_Entity_Name
(Discr_Val
)
2654 and then Ekind
(Entity
(Discr_Val
)) = E_Discriminant
2658 -- When the parent discriminant is constrained at the type
2659 -- extension level, it does not appear in the derived type.
2661 -- type Deriv_Typ (Discr : ...)
2662 -- is new Parent_Typ (Discr => Discr,
2663 -- Hidden_Discr => Expression);
2665 elsif Is_Completely_Hidden_Discriminant
(Discr
) then
2668 -- Otherwise initialize the discriminant
2672 Make_OK_Assignment_Statement
(Loc
,
2674 Make_Selected_Component
(Loc
,
2675 Prefix
=> New_Copy_Tree
(Target
),
2676 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)),
2677 Expression
=> New_Copy_Tree
(Discr_Val
));
2679 Append_To
(List
, Discr_Init
);
2682 Next_Elmt
(Discr_Constr
);
2683 Next_Discriminant
(Discr
);
2686 In_Aggr_Type
:= False;
2687 Base_Typ
:= Base_Type
(Par_Typ
);
2689 end Init_Hidden_Discriminants
;
2691 --------------------------------
2692 -- Init_Visible_Discriminants --
2693 --------------------------------
2695 procedure Init_Visible_Discriminants
is
2696 Discriminant
: Entity_Id
;
2697 Discriminant_Value
: Node_Id
;
2700 Discriminant
:= First_Discriminant
(Typ
);
2701 while Present
(Discriminant
) loop
2703 Make_Selected_Component
(Loc
,
2704 Prefix
=> New_Copy_Tree
(Target
),
2705 Selector_Name
=> New_Occurrence_Of
(Discriminant
, Loc
));
2707 Discriminant_Value
:=
2708 Get_Discriminant_Value
2709 (Discriminant
, Typ
, Discriminant_Constraint
(N_Typ
));
2712 Make_OK_Assignment_Statement
(Loc
,
2714 Expression
=> New_Copy_Tree
(Discriminant_Value
));
2716 Append_To
(L
, Instr
);
2718 Next_Discriminant
(Discriminant
);
2720 end Init_Visible_Discriminants
;
2722 -------------------------------
2723 -- Init_Stored_Discriminants --
2724 -------------------------------
2726 procedure Init_Stored_Discriminants
is
2727 Discriminant
: Entity_Id
;
2728 Discriminant_Value
: Node_Id
;
2731 Discriminant
:= First_Stored_Discriminant
(Typ
);
2732 while Present
(Discriminant
) loop
2734 Make_Selected_Component
(Loc
,
2735 Prefix
=> New_Copy_Tree
(Target
),
2736 Selector_Name
=> New_Occurrence_Of
(Discriminant
, Loc
));
2738 Discriminant_Value
:=
2739 Get_Discriminant_Value
2740 (Discriminant
, N_Typ
, Discriminant_Constraint
(N_Typ
));
2743 Make_OK_Assignment_Statement
(Loc
,
2745 Expression
=> New_Copy_Tree
(Discriminant_Value
));
2747 Append_To
(L
, Instr
);
2749 Next_Stored_Discriminant
(Discriminant
);
2751 end Init_Stored_Discriminants
;
2753 -------------------------
2754 -- Is_Int_Range_Bounds --
2755 -------------------------
2757 function Is_Int_Range_Bounds
(Bounds
: Node_Id
) return Boolean is
2759 return Nkind
(Bounds
) = N_Range
2760 and then Nkind
(Low_Bound
(Bounds
)) = N_Integer_Literal
2761 and then Nkind
(High_Bound
(Bounds
)) = N_Integer_Literal
;
2762 end Is_Int_Range_Bounds
;
2768 function Replace_Type
(Expr
: Node_Id
) return Traverse_Result
is
2770 -- Note about the Is_Ancestor test below: aggregate components for
2771 -- self-referential types include attribute references to the current
2772 -- instance, of the form: Typ'access, etc. These references are
2773 -- rewritten as references to the target of the aggregate: the
2774 -- left-hand side of an assignment, the entity in a declaration,
2775 -- or a temporary. Without this test, we would improperly extend
2776 -- this rewriting to attribute references whose prefix is not the
2777 -- type of the aggregate.
2779 if Nkind
(Expr
) = N_Attribute_Reference
2780 and then Is_Entity_Name
(Prefix
(Expr
))
2781 and then Is_Type
(Entity
(Prefix
(Expr
)))
2784 (Entity
(Prefix
(Expr
)), Etype
(N
), Use_Full_View
=> True)
2786 if Is_Entity_Name
(Lhs
) then
2787 Rewrite
(Prefix
(Expr
), New_Occurrence_Of
(Entity
(Lhs
), Loc
));
2791 Make_Attribute_Reference
(Loc
,
2792 Attribute_Name
=> Name_Unrestricted_Access
,
2793 Prefix
=> New_Copy_Tree
(Lhs
)));
2794 Set_Analyzed
(Parent
(Expr
), False);
2801 --------------------------
2802 -- Rewrite_Discriminant --
2803 --------------------------
2805 function Rewrite_Discriminant
(Expr
: Node_Id
) return Traverse_Result
is
2807 if Is_Entity_Name
(Expr
)
2808 and then Present
(Entity
(Expr
))
2809 and then Ekind
(Entity
(Expr
)) = E_In_Parameter
2810 and then Present
(Discriminal_Link
(Entity
(Expr
)))
2811 and then Scope
(Discriminal_Link
(Entity
(Expr
))) =
2812 Base_Type
(Etype
(N
))
2815 Make_Selected_Component
(Loc
,
2816 Prefix
=> New_Copy_Tree
(Lhs
),
2817 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Expr
))));
2819 -- The generated code will be reanalyzed, but if the reference
2820 -- to the discriminant appears within an already analyzed
2821 -- expression (e.g. a conditional) we must set its proper entity
2822 -- now. Context is an initialization procedure.
2828 end Rewrite_Discriminant
;
2830 procedure Replace_Discriminants
is
2831 new Traverse_Proc
(Rewrite_Discriminant
);
2833 procedure Replace_Self_Reference
is
2834 new Traverse_Proc
(Replace_Type
);
2836 -- Start of processing for Build_Record_Aggr_Code
2839 if Has_Self_Reference
(N
) then
2840 Replace_Self_Reference
(N
);
2843 -- If the target of the aggregate is class-wide, we must convert it
2844 -- to the actual type of the aggregate, so that the proper components
2845 -- are visible. We know already that the types are compatible.
2847 if Present
(Etype
(Lhs
)) and then Is_Class_Wide_Type
(Etype
(Lhs
)) then
2848 Target
:= Unchecked_Convert_To
(Typ
, Lhs
);
2853 -- Deal with the ancestor part of extension aggregates or with the
2854 -- discriminants of the root type.
2856 if Nkind
(N
) = N_Extension_Aggregate
then
2858 Ancestor
: constant Node_Id
:= Ancestor_Part
(N
);
2859 Ancestor_Q
: constant Node_Id
:= Unqualify
(Ancestor
);
2864 -- If the ancestor part is a subtype mark T, we generate
2866 -- init-proc (T (tmp)); if T is constrained and
2867 -- init-proc (S (tmp)); where S applies an appropriate
2868 -- constraint if T is unconstrained
2870 if Is_Entity_Name
(Ancestor
)
2871 and then Is_Type
(Entity
(Ancestor
))
2873 Ancestor_Is_Subtype_Mark
:= True;
2875 if Is_Constrained
(Entity
(Ancestor
)) then
2876 Init_Typ
:= Entity
(Ancestor
);
2878 -- For an ancestor part given by an unconstrained type mark,
2879 -- create a subtype constrained by appropriate corresponding
2880 -- discriminant values coming from either associations of the
2881 -- aggregate or a constraint on a parent type. The subtype will
2882 -- be used to generate the correct default value for the
2885 elsif Has_Discriminants
(Entity
(Ancestor
)) then
2887 Anc_Typ
: constant Entity_Id
:= Entity
(Ancestor
);
2888 Anc_Constr
: constant List_Id
:= New_List
;
2889 Discrim
: Entity_Id
;
2890 Disc_Value
: Node_Id
;
2891 New_Indic
: Node_Id
;
2892 Subt_Decl
: Node_Id
;
2895 Discrim
:= First_Discriminant
(Anc_Typ
);
2896 while Present
(Discrim
) loop
2897 Disc_Value
:= Ancestor_Discriminant_Value
(Discrim
);
2899 -- If no usable discriminant in ancestors, check
2900 -- whether aggregate has an explicit value for it.
2902 if No
(Disc_Value
) then
2904 Get_Explicit_Discriminant_Value
(Discrim
);
2907 Append_To
(Anc_Constr
, Disc_Value
);
2908 Next_Discriminant
(Discrim
);
2912 Make_Subtype_Indication
(Loc
,
2913 Subtype_Mark
=> New_Occurrence_Of
(Anc_Typ
, Loc
),
2915 Make_Index_Or_Discriminant_Constraint
(Loc
,
2916 Constraints
=> Anc_Constr
));
2918 Init_Typ
:= Create_Itype
(Ekind
(Anc_Typ
), N
);
2921 Make_Subtype_Declaration
(Loc
,
2922 Defining_Identifier
=> Init_Typ
,
2923 Subtype_Indication
=> New_Indic
);
2925 -- Itypes must be analyzed with checks off Declaration
2926 -- must have a parent for proper handling of subsidiary
2929 Set_Parent
(Subt_Decl
, N
);
2930 Analyze
(Subt_Decl
, Suppress
=> All_Checks
);
2934 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2935 Set_Assignment_OK
(Ref
);
2937 if not Is_Interface
(Init_Typ
) then
2939 Build_Initialization_Call
(Loc
,
2942 In_Init_Proc
=> Within_Init_Proc
,
2943 With_Default_Init
=> Has_Default_Init_Comps
(N
)
2945 Has_Task
(Base_Type
(Init_Typ
))));
2947 if Is_Constrained
(Entity
(Ancestor
))
2948 and then Has_Discriminants
(Entity
(Ancestor
))
2950 Check_Ancestor_Discriminants
(Entity
(Ancestor
));
2953 -- If ancestor type has Default_Initialization_Condition,
2954 -- add a DIC check after the ancestor object is initialized
2957 if Has_DIC
(Entity
(Ancestor
))
2958 and then Present
(DIC_Procedure
(Entity
(Ancestor
)))
2962 (Loc
, New_Copy_Tree
(Ref
), Entity
(Ancestor
)));
2966 -- Handle calls to C++ constructors
2968 elsif Is_CPP_Constructor_Call
(Ancestor
) then
2969 Init_Typ
:= Etype
(Ancestor
);
2970 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2971 Set_Assignment_OK
(Ref
);
2974 Build_Initialization_Call
(Loc
,
2977 In_Init_Proc
=> Within_Init_Proc
,
2978 With_Default_Init
=> Has_Default_Init_Comps
(N
),
2979 Constructor_Ref
=> Ancestor
));
2981 -- Ada 2005 (AI-287): If the ancestor part is an aggregate of
2982 -- limited type, a recursive call expands the ancestor. Note that
2983 -- in the limited case, the ancestor part must be either a
2984 -- function call (possibly qualified) or aggregate (definitely
2987 elsif Is_Limited_Type
(Etype
(Ancestor
))
2988 and then Nkind
(Ancestor_Q
) in N_Aggregate
2989 | N_Extension_Aggregate
2992 Build_Record_Aggr_Code
2994 Typ
=> Etype
(Ancestor_Q
),
2997 -- If the ancestor part is an expression E of type T, we generate
3001 -- In Ada 2005, this includes the case of a (possibly qualified)
3002 -- limited function call. The assignment will later be turned into
3003 -- a build-in-place function call (for further details, see
3004 -- Make_Build_In_Place_Call_In_Assignment).
3007 Init_Typ
:= Etype
(Ancestor
);
3009 -- If the ancestor part is an aggregate, force its full
3010 -- expansion, which was delayed.
3012 if Nkind
(Ancestor_Q
) in N_Aggregate | N_Extension_Aggregate
3014 Set_Analyzed
(Ancestor
, False);
3015 Set_Analyzed
(Expression
(Ancestor
), False);
3018 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
3020 Assign
:= New_List
(
3021 Make_OK_Assignment_Statement
(Loc
,
3023 Expression
=> Ancestor
));
3025 -- Arrange for the component to be adjusted if need be (the
3026 -- call will be generated by Make_Tag_Ctrl_Assignment).
3028 if Needs_Finalization
(Init_Typ
)
3029 and then not Is_Limited_View
(Init_Typ
)
3031 Set_No_Finalize_Actions
(First
(Assign
));
3033 Set_No_Ctrl_Actions
(First
(Assign
));
3037 Make_Suppress_Block
(Loc
, Name_Discriminant_Check
, Assign
));
3039 if Has_Discriminants
(Init_Typ
) then
3040 Check_Ancestor_Discriminants
(Init_Typ
);
3045 -- Generate assignments of hidden discriminants. If the base type is
3046 -- an unchecked union, the discriminants are unknown to the back-end
3047 -- and absent from a value of the type, so assignments for them are
3050 if Has_Discriminants
(Typ
)
3051 and then not Is_Unchecked_Union
(Base_Type
(Typ
))
3053 Init_Hidden_Discriminants
(Typ
, L
);
3056 -- Normal case (not an extension aggregate)
3059 -- Generate the discriminant expressions, component by component.
3060 -- If the base type is an unchecked union, the discriminants are
3061 -- unknown to the back-end and absent from a value of the type, so
3062 -- assignments for them are not emitted.
3064 if Has_Discriminants
(Typ
)
3065 and then not Is_Unchecked_Union
(Base_Type
(Typ
))
3067 Init_Hidden_Discriminants
(Typ
, L
);
3069 -- Generate discriminant init values for the visible discriminants
3071 Init_Visible_Discriminants
;
3073 if Is_Derived_Type
(N_Typ
) then
3074 Init_Stored_Discriminants
;
3079 -- For CPP types we generate an implicit call to the C++ default
3080 -- constructor to ensure the proper initialization of the _Tag
3083 if Is_CPP_Class
(Root_Type
(Typ
)) and then CPP_Num_Prims
(Typ
) > 0 then
3084 Invoke_Constructor
: declare
3085 CPP_Parent
: constant Entity_Id
:= Enclosing_CPP_Parent
(Typ
);
3087 procedure Invoke_IC_Proc
(T
: Entity_Id
);
3088 -- Recursive routine used to climb to parents. Required because
3089 -- parents must be initialized before descendants to ensure
3090 -- propagation of inherited C++ slots.
3092 --------------------
3093 -- Invoke_IC_Proc --
3094 --------------------
3096 procedure Invoke_IC_Proc
(T
: Entity_Id
) is
3098 -- Avoid generating extra calls. Initialization required
3099 -- only for types defined from the level of derivation of
3100 -- type of the constructor and the type of the aggregate.
3102 if T
= CPP_Parent
then
3106 Invoke_IC_Proc
(Etype
(T
));
3108 -- Generate call to the IC routine
3110 if Present
(CPP_Init_Proc
(T
)) then
3112 Make_Procedure_Call_Statement
(Loc
,
3113 Name
=> New_Occurrence_Of
(CPP_Init_Proc
(T
), Loc
)));
3117 -- Start of processing for Invoke_Constructor
3120 -- Implicit invocation of the C++ constructor
3122 if Nkind
(N
) = N_Aggregate
then
3124 Make_Procedure_Call_Statement
(Loc
,
3126 New_Occurrence_Of
(Base_Init_Proc
(CPP_Parent
), Loc
),
3127 Parameter_Associations
=> New_List
(
3128 Unchecked_Convert_To
(CPP_Parent
,
3129 New_Copy_Tree
(Lhs
)))));
3132 Invoke_IC_Proc
(Typ
);
3133 end Invoke_Constructor
;
3136 -- Generate the assignments, component by component
3138 -- tmp.comp1 := Expr1_From_Aggr;
3139 -- tmp.comp2 := Expr2_From_Aggr;
3142 Comp
:= First
(Component_Associations
(N
));
3143 while Present
(Comp
) loop
3144 Selector
:= Entity
(First
(Choices
(Comp
)));
3145 pragma Assert
(Present
(Selector
));
3149 if Is_CPP_Constructor_Call
(Expression
(Comp
)) then
3151 Build_Initialization_Call
(Loc
,
3153 Make_Selected_Component
(Loc
,
3154 Prefix
=> New_Copy_Tree
(Target
),
3155 Selector_Name
=> New_Occurrence_Of
(Selector
, Loc
)),
3156 Typ
=> Etype
(Selector
),
3158 With_Default_Init
=> True,
3159 Constructor_Ref
=> Expression
(Comp
)));
3161 elsif Box_Present
(Comp
)
3162 and then Needs_Simple_Initialization
(Etype
(Selector
))
3165 Make_Selected_Component
(Loc
,
3166 Prefix
=> New_Copy_Tree
(Target
),
3167 Selector_Name
=> New_Occurrence_Of
(Selector
, Loc
));
3169 Initialize_Component
3172 Comp_Typ
=> Etype
(Selector
),
3173 Init_Expr
=> Get_Simple_Init_Val
3174 (Typ
=> Etype
(Selector
),
3177 (if Known_Esize
(Selector
)
3178 then Esize
(Selector
)
3182 -- Ada 2005 (AI-287): For each default-initialized component generate
3183 -- a call to the corresponding IP subprogram if available.
3185 elsif Box_Present
(Comp
)
3186 and then Has_Non_Null_Base_Init_Proc
(Etype
(Selector
))
3188 if Ekind
(Selector
) /= E_Discriminant
then
3189 Generate_Finalization_Actions
;
3192 -- Ada 2005 (AI-287): If the component type has tasks then
3193 -- generate the activation chain and master entities (except
3194 -- in case of an allocator because in that case these entities
3195 -- are generated by Build_Task_Allocate_Block_With_Init_Stmts).
3198 Ctype
: constant Entity_Id
:= Etype
(Selector
);
3199 Inside_Allocator
: Boolean := False;
3200 P
: Node_Id
:= Parent
(N
);
3203 if Is_Task_Type
(Ctype
) or else Has_Task
(Ctype
) then
3204 while Present
(P
) loop
3205 if Nkind
(P
) = N_Allocator
then
3206 Inside_Allocator
:= True;
3213 if not Inside_Init_Proc
and not Inside_Allocator
then
3214 Build_Activation_Chain_Entity
(N
);
3220 Build_Initialization_Call
(Loc
,
3221 Id_Ref
=> Make_Selected_Component
(Loc
,
3222 Prefix
=> New_Copy_Tree
(Target
),
3224 New_Occurrence_Of
(Selector
, Loc
)),
3225 Typ
=> Etype
(Selector
),
3227 With_Default_Init
=> True));
3229 -- Prepare for component assignment
3231 elsif Ekind
(Selector
) /= E_Discriminant
3232 or else Nkind
(N
) = N_Extension_Aggregate
3234 -- All the discriminants have now been assigned
3236 -- This is now a good moment to initialize and attach all the
3237 -- controllers. Their position may depend on the discriminants.
3239 if Ekind
(Selector
) /= E_Discriminant
then
3240 Generate_Finalization_Actions
;
3243 Comp_Type
:= Underlying_Type
(Etype
(Selector
));
3245 Make_Selected_Component
(Loc
,
3246 Prefix
=> New_Copy_Tree
(Target
),
3247 Selector_Name
=> New_Occurrence_Of
(Selector
, Loc
));
3249 Expr_Q
:= Unqualify
(Expression
(Comp
));
3251 -- Now either create the assignment or generate the code for the
3252 -- inner aggregate top-down.
3254 if Is_Delayed_Aggregate
(Expr_Q
) then
3256 -- We have the following case of aggregate nesting inside
3257 -- an object declaration:
3259 -- type Arr_Typ is array (Integer range <>) of ...;
3261 -- type Rec_Typ (...) is record
3262 -- Obj_Arr_Typ : Arr_Typ (A .. B);
3265 -- Obj_Rec_Typ : Rec_Typ := (...,
3266 -- Obj_Arr_Typ => (X => (...), Y => (...)));
3268 -- The length of the ranges of the aggregate and Obj_Add_Typ
3269 -- are equal (B - A = Y - X), but they do not coincide (X /=
3270 -- A and B /= Y). This case requires array sliding which is
3271 -- performed in the following manner:
3273 -- subtype Arr_Sub is Arr_Typ (X .. Y);
3275 -- Temp (X) := (...);
3277 -- Temp (Y) := (...);
3278 -- Obj_Rec_Typ.Obj_Arr_Typ := Temp;
3280 if Ekind
(Comp_Type
) = E_Array_Subtype
3281 and then Is_Int_Range_Bounds
(Aggregate_Bounds
(Expr_Q
))
3282 and then Is_Int_Range_Bounds
(First_Index
(Comp_Type
))
3284 Compatible_Int_Bounds
3285 (Agg_Bounds
=> Aggregate_Bounds
(Expr_Q
),
3286 Typ_Bounds
=> First_Index
(Comp_Type
))
3288 -- Create the array subtype with bounds equal to those of
3289 -- the corresponding aggregate.
3292 SubE
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
3294 SubD
: constant Node_Id
:=
3295 Make_Subtype_Declaration
(Loc
,
3296 Defining_Identifier
=> SubE
,
3297 Subtype_Indication
=>
3298 Make_Subtype_Indication
(Loc
,
3300 New_Occurrence_Of
(Etype
(Comp_Type
), Loc
),
3302 Make_Index_Or_Discriminant_Constraint
3304 Constraints
=> New_List
(
3306 (Aggregate_Bounds
(Expr_Q
))))));
3308 -- Create a temporary array of the above subtype which
3309 -- will be used to capture the aggregate assignments.
3311 TmpE
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A', N
);
3313 TmpD
: constant Node_Id
:=
3314 Make_Object_Declaration
(Loc
,
3315 Defining_Identifier
=> TmpE
,
3316 Object_Definition
=> New_Occurrence_Of
(SubE
, Loc
));
3319 Set_No_Initialization
(TmpD
);
3320 Append_To
(L
, SubD
);
3321 Append_To
(L
, TmpD
);
3323 -- Expand aggregate into assignments to the temp array
3326 Late_Expansion
(Expr_Q
, Comp_Type
,
3327 New_Occurrence_Of
(TmpE
, Loc
)));
3332 Make_Assignment_Statement
(Loc
,
3333 Name
=> New_Copy_Tree
(Comp_Expr
),
3334 Expression
=> New_Occurrence_Of
(TmpE
, Loc
)));
3337 -- Normal case (sliding not required)
3341 Late_Expansion
(Expr_Q
, Comp_Type
, Comp_Expr
));
3344 -- Expr_Q is not delayed aggregate
3347 if Has_Discriminants
(Typ
) then
3348 Replace_Discriminants
(Expr_Q
);
3350 -- If the component is an array type that depends on
3351 -- discriminants, and the expression is a single Others
3352 -- clause, create an explicit subtype for it because the
3353 -- backend has troubles recovering the actual bounds.
3355 if Nkind
(Expr_Q
) = N_Aggregate
3356 and then Is_Array_Type
(Comp_Type
)
3357 and then Present
(Component_Associations
(Expr_Q
))
3360 Assoc
: constant Node_Id
:=
3361 First
(Component_Associations
(Expr_Q
));
3367 Nkind
(First
(Choices
(Assoc
))) = N_Others_Choice
3370 Build_Actual_Subtype_Of_Component
3371 (Comp_Type
, Comp_Expr
);
3373 -- If the component type does not in fact depend on
3374 -- discriminants, the subtype declaration is empty.
3376 if Present
(Decl
) then
3377 Append_To
(L
, Decl
);
3378 Set_Etype
(Comp_Expr
, Defining_Entity
(Decl
));
3385 if Modify_Tree_For_C
3386 and then Nkind
(Expr_Q
) = N_Aggregate
3387 and then Is_Array_Type
(Etype
(Expr_Q
))
3388 and then Present
(First_Index
(Etype
(Expr_Q
)))
3391 Expr_Q_Type
: constant Entity_Id
:= Etype
(Expr_Q
);
3394 Build_Array_Aggr_Code
3396 Ctype
=> Component_Type
(Expr_Q_Type
),
3397 Index
=> First_Index
(Expr_Q_Type
),
3400 Is_Scalar_Type
(Component_Type
(Expr_Q_Type
))));
3404 Initialize_Component
3407 Comp_Typ
=> Etype
(Selector
),
3408 Init_Expr
=> Expr_Q
,
3413 -- comment would be good here ???
3415 elsif Ekind
(Selector
) = E_Discriminant
3416 and then Nkind
(N
) /= N_Extension_Aggregate
3417 and then Nkind
(Parent
(N
)) = N_Component_Association
3418 and then Is_Constrained
(Typ
)
3420 -- We must check that the discriminant value imposed by the
3421 -- context is the same as the value given in the subaggregate,
3422 -- because after the expansion into assignments there is no
3423 -- record on which to perform a regular discriminant check.
3430 D_Val
:= First_Elmt
(Discriminant_Constraint
(Typ
));
3431 Disc
:= First_Discriminant
(Typ
);
3432 while Chars
(Disc
) /= Chars
(Selector
) loop
3433 Next_Discriminant
(Disc
);
3437 pragma Assert
(Present
(D_Val
));
3439 -- This check cannot performed for components that are
3440 -- constrained by a current instance, because this is not a
3441 -- value that can be compared with the actual constraint.
3443 if Nkind
(Node
(D_Val
)) /= N_Attribute_Reference
3444 or else not Is_Entity_Name
(Prefix
(Node
(D_Val
)))
3445 or else not Is_Type
(Entity
(Prefix
(Node
(D_Val
))))
3448 Make_Raise_Constraint_Error
(Loc
,
3451 Left_Opnd
=> New_Copy_Tree
(Node
(D_Val
)),
3452 Right_Opnd
=> Expression
(Comp
)),
3453 Reason
=> CE_Discriminant_Check_Failed
));
3456 -- Find self-reference in previous discriminant assignment,
3457 -- and replace with proper expression.
3464 while Present
(Ass
) loop
3465 if Nkind
(Ass
) = N_Assignment_Statement
3466 and then Nkind
(Name
(Ass
)) = N_Selected_Component
3467 and then Chars
(Selector_Name
(Name
(Ass
))) =
3471 (Ass
, New_Copy_Tree
(Expression
(Comp
)));
3481 -- If the component association was specified with a box and the
3482 -- component type has a Default_Initial_Condition, then generate
3483 -- a call to the DIC procedure.
3485 if Has_DIC
(Etype
(Selector
))
3486 and then Was_Default_Init_Box_Association
(Comp
)
3487 and then Present
(DIC_Procedure
(Etype
(Selector
)))
3490 Build_DIC_Call
(Loc
,
3491 Make_Selected_Component
(Loc
,
3492 Prefix
=> New_Copy_Tree
(Target
),
3493 Selector_Name
=> New_Occurrence_Of
(Selector
, Loc
)),
3500 -- For CPP types we generated a call to the C++ default constructor
3501 -- before the components have been initialized to ensure the proper
3502 -- initialization of the _Tag component (see above).
3504 if Is_CPP_Class
(Typ
) then
3507 -- If the type is tagged, the tag needs to be initialized (unless we
3508 -- are in VM-mode where tags are implicit). It is done late in the
3509 -- initialization process because in some cases, we call the init
3510 -- proc of an ancestor which will not leave out the right tag.
3512 elsif Is_Tagged_Type
(Typ
) and then Tagged_Type_Expansion
then
3514 Make_Tag_Assignment_From_Type
3515 (Loc
, New_Copy_Tree
(Target
), Base_Type
(Typ
));
3517 Append_To
(L
, Instr
);
3519 -- Ada 2005 (AI-251): If the tagged type has been derived from an
3520 -- abstract interfaces we must also initialize the tags of the
3521 -- secondary dispatch tables.
3523 if Has_Interfaces
(Base_Type
(Typ
)) then
3525 (Typ
=> Base_Type
(Typ
),
3528 Init_Tags_List
=> L
);
3532 -- If the controllers have not been initialized yet (by lack of non-
3533 -- discriminant components), let's do it now.
3535 Generate_Finalization_Actions
;
3538 end Build_Record_Aggr_Code
;
3540 -------------------------------
3541 -- Convert_Aggr_In_Allocator --
3542 -------------------------------
3544 procedure Convert_Aggr_In_Allocator
3549 Loc
: constant Source_Ptr
:= Sloc
(Aggr
);
3550 Typ
: constant Entity_Id
:= Etype
(Aggr
);
3551 Temp
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3553 Occ
: constant Node_Id
:=
3554 Unchecked_Convert_To
(Typ
,
3555 Make_Explicit_Dereference
(Loc
, New_Occurrence_Of
(Temp
, Loc
)));
3558 if Is_Array_Type
(Typ
) then
3559 Convert_Array_Aggr_In_Allocator
(Decl
, Aggr
, Occ
);
3561 elsif Has_Default_Init_Comps
(Aggr
) then
3563 L
: constant List_Id
:= New_List
;
3564 Init_Stmts
: List_Id
;
3567 Init_Stmts
:= Late_Expansion
(Aggr
, Typ
, Occ
);
3569 if Has_Task
(Typ
) then
3570 Build_Task_Allocate_Block_With_Init_Stmts
(L
, Aggr
, Init_Stmts
);
3571 Insert_Actions
(Alloc
, L
);
3573 Insert_Actions
(Alloc
, Init_Stmts
);
3578 Insert_Actions
(Alloc
, Late_Expansion
(Aggr
, Typ
, Occ
));
3580 end Convert_Aggr_In_Allocator
;
3582 --------------------------------
3583 -- Convert_Aggr_In_Assignment --
3584 --------------------------------
3586 procedure Convert_Aggr_In_Assignment
(N
: Node_Id
) is
3587 Aggr
: constant Node_Id
:= Unqualify
(Expression
(N
));
3588 Typ
: constant Entity_Id
:= Etype
(Aggr
);
3589 Occ
: constant Node_Id
:= New_Copy_Tree
(Name
(N
));
3592 Insert_Actions_After
(N
, Late_Expansion
(Aggr
, Typ
, Occ
));
3593 end Convert_Aggr_In_Assignment
;
3595 ---------------------------------
3596 -- Convert_Aggr_In_Object_Decl --
3597 ---------------------------------
3599 procedure Convert_Aggr_In_Object_Decl
(N
: Node_Id
) is
3600 Obj
: constant Entity_Id
:= Defining_Identifier
(N
);
3601 Aggr
: constant Node_Id
:= Unqualify
(Expression
(N
));
3602 Loc
: constant Source_Ptr
:= Sloc
(Aggr
);
3603 Typ
: constant Entity_Id
:= Etype
(Aggr
);
3604 Occ
: constant Node_Id
:= New_Occurrence_Of
(Obj
, Loc
);
3606 Has_Transient_Scope
: Boolean := False;
3608 function Discriminants_Ok
return Boolean;
3609 -- If the object type is constrained, the discriminants in the
3610 -- aggregate must be checked against the discriminants of the subtype.
3611 -- This cannot be done using Apply_Discriminant_Checks because after
3612 -- expansion there is no aggregate left to check.
3614 ----------------------
3615 -- Discriminants_Ok --
3616 ----------------------
3618 function Discriminants_Ok
return Boolean is
3619 Cond
: Node_Id
:= Empty
;
3628 D
:= First_Discriminant
(Typ
);
3629 Disc1
:= First_Elmt
(Discriminant_Constraint
(Typ
));
3630 Disc2
:= First_Elmt
(Discriminant_Constraint
(Etype
(Obj
)));
3631 while Present
(Disc1
) and then Present
(Disc2
) loop
3632 Val1
:= Node
(Disc1
);
3633 Val2
:= Node
(Disc2
);
3635 if not Is_OK_Static_Expression
(Val1
)
3636 or else not Is_OK_Static_Expression
(Val2
)
3638 Check
:= Make_Op_Ne
(Loc
,
3639 Left_Opnd
=> Duplicate_Subexpr
(Val1
),
3640 Right_Opnd
=> Duplicate_Subexpr
(Val2
));
3646 Cond
:= Make_Or_Else
(Loc
,
3648 Right_Opnd
=> Check
);
3651 elsif Expr_Value
(Val1
) /= Expr_Value
(Val2
) then
3652 Apply_Compile_Time_Constraint_Error
(Aggr
,
3653 Msg
=> "incorrect value for discriminant&??",
3654 Reason
=> CE_Discriminant_Check_Failed
,
3659 Next_Discriminant
(D
);
3664 -- If any discriminant constraint is nonstatic, emit a check
3666 if Present
(Cond
) then
3668 Make_Raise_Constraint_Error
(Loc
,
3670 Reason
=> CE_Discriminant_Check_Failed
));
3674 end Discriminants_Ok
;
3676 -- Start of processing for Convert_Aggr_In_Object_Decl
3679 Set_Assignment_OK
(Occ
);
3681 if Has_Discriminants
(Typ
)
3682 and then Typ
/= Etype
(Obj
)
3683 and then Is_Constrained
(Etype
(Obj
))
3684 and then not Discriminants_Ok
3689 -- If the context is an extended return statement, it has its own
3690 -- finalization machinery (i.e. works like a transient scope) and
3691 -- we do not want to create an additional one, because objects on
3692 -- the finalization list of the return must be moved to the caller's
3693 -- finalization list to complete the return.
3695 -- Similarly if the aggregate is limited, it is built in place, and the
3696 -- controlled components are not assigned to intermediate temporaries
3697 -- so there is no need for a transient scope in this case either.
3699 if Requires_Transient_Scope
(Typ
)
3700 and then Ekind
(Current_Scope
) /= E_Return_Statement
3701 and then not Is_Limited_Type
(Typ
)
3703 Establish_Transient_Scope
(Aggr
, Manage_Sec_Stack
=> False);
3704 Has_Transient_Scope
:= True;
3708 Stmts
: constant List_Id
:= Late_Expansion
(Aggr
, Typ
, Occ
);
3713 -- If Obj is already frozen or if N is wrapped in a transient scope,
3714 -- Stmts do not need to be saved in Initialization_Statements since
3715 -- there is no freezing issue.
3717 if Is_Frozen
(Obj
) or else Has_Transient_Scope
then
3718 Insert_Actions_After
(N
, Stmts
);
3720 Stmt
:= Make_Compound_Statement
(Sloc
(N
), Actions
=> Stmts
);
3721 Insert_Action_After
(N
, Stmt
);
3723 -- Insert_Action_After may freeze Obj in which case we should
3724 -- remove the compound statement just created and simply insert
3727 if Is_Frozen
(Obj
) then
3729 Insert_Actions_After
(N
, Stmts
);
3731 Set_Initialization_Statements
(Obj
, Stmt
);
3735 -- If Typ has controlled components and a call to a Slice_Assign
3736 -- procedure is part of the initialization statements, then we
3737 -- need to initialize the array component since Slice_Assign will
3738 -- need to adjust it.
3740 if Has_Controlled_Component
(Typ
) then
3741 Stmt
:= First
(Stmts
);
3743 while Present
(Stmt
) loop
3744 if Nkind
(Stmt
) = N_Procedure_Call_Statement
3745 and then Is_TSS
(Entity
(Name
(Stmt
)), TSS_Slice_Assign
)
3747 Param
:= First
(Parameter_Associations
(Stmt
));
3750 Build_Initialization_Call
3751 (Sloc
(N
), New_Copy_Tree
(Param
), Etype
(Param
)));
3759 Set_No_Initialization
(N
);
3761 -- After expansion the expression can be removed from the declaration
3762 -- except if the object is class-wide, in which case the aggregate
3763 -- provides the actual type.
3765 if not Is_Class_Wide_Type
(Etype
(Obj
)) then
3766 Set_Expression
(N
, Empty
);
3769 Initialize_Discriminants
(N
, Typ
);
3770 end Convert_Aggr_In_Object_Decl
;
3772 -------------------------------------
3773 -- Convert_Array_Aggr_In_Allocator --
3774 -------------------------------------
3776 procedure Convert_Array_Aggr_In_Allocator
3781 Typ
: constant Entity_Id
:= Etype
(Aggr
);
3782 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
3783 Aggr_Code
: List_Id
;
3787 -- The target is an explicit dereference of the allocated object
3789 -- If the assignment can be done directly by the back end, then
3790 -- reset Set_Expansion_Delayed and do not expand further.
3792 if not CodePeer_Mode
3793 and then not Modify_Tree_For_C
3794 and then Aggr_Assignment_OK_For_Backend
(Aggr
)
3796 New_Aggr
:= New_Copy_Tree
(Aggr
);
3797 Set_Expansion_Delayed
(New_Aggr
, False);
3799 -- In the case of Target's type using the Designated_Storage_Model
3800 -- aspect with a Copy_To procedure, insert a temporary and have the
3801 -- back end handle the assignment to it. Copy the result to the
3804 if Has_Designated_Storage_Model_Aspect
3805 (Etype
(Prefix
(Expression
(Target
))))
3806 and then Present
(Storage_Model_Copy_To
3807 (Storage_Model_Object
3808 (Etype
(Prefix
(Expression
(Target
))))))
3811 Build_Assignment_With_Temporary
(Target
, Typ
, New_Aggr
);
3816 Make_OK_Assignment_Statement
(Sloc
(New_Aggr
),
3818 Expression
=> New_Aggr
));
3821 -- Or else, generate component assignments to it, as for an aggregate
3822 -- that appears on the right-hand side of an assignment statement.
3825 Build_Array_Aggr_Code
(Aggr
,
3827 Index
=> First_Index
(Typ
),
3829 Scalar_Comp
=> Is_Scalar_Type
(Ctyp
));
3832 Insert_Actions_After
(Decl
, Aggr_Code
);
3833 end Convert_Array_Aggr_In_Allocator
;
3835 ------------------------
3836 -- In_Place_Assign_OK --
3837 ------------------------
3839 function In_Place_Assign_OK
3841 Target_Object
: Entity_Id
:= Empty
) return Boolean
3843 Is_Array
: constant Boolean := Is_Array_Type
(Etype
(N
));
3846 Aggr_Bounds
: Range_Nodes
;
3848 Obj_Bounds
: Range_Nodes
;
3849 Parent_Kind
: Node_Kind
;
3850 Parent_Node
: Node_Id
;
3852 function Safe_Aggregate
(Aggr
: Node_Id
) return Boolean;
3853 -- Check recursively that each component of a (sub)aggregate does not
3854 -- depend on the variable being assigned to.
3856 function Safe_Component
(Expr
: Node_Id
) return Boolean;
3857 -- Verify that an expression cannot depend on the target being assigned
3858 -- to. Return true for compile-time known values, stand-alone objects,
3859 -- parameters passed by copy, calls to functions that return by copy,
3860 -- selected components thereof only if the aggregate's type is an array,
3861 -- indexed components and slices thereof only if the aggregate's type is
3862 -- a record, and simple expressions involving only these as operands.
3863 -- This is OK whatever the target because, for a component to overlap
3864 -- with the target, it must be either a direct reference to a component
3865 -- of the target, in which case there must be a matching selection or
3866 -- indexation or slicing, or an indirect reference to such a component,
3867 -- which is excluded by the above condition. Additionally, if the target
3868 -- is statically known, return true for arbitrarily nested selections,
3869 -- indexations or slicings, provided that their ultimate prefix is not
3870 -- the target itself.
3872 --------------------
3873 -- Safe_Aggregate --
3874 --------------------
3876 function Safe_Aggregate
(Aggr
: Node_Id
) return Boolean is
3880 if Nkind
(Parent
(Aggr
)) = N_Iterated_Component_Association
then
3884 if Present
(Expressions
(Aggr
)) then
3885 Expr
:= First
(Expressions
(Aggr
));
3886 while Present
(Expr
) loop
3887 if Nkind
(Expr
) = N_Aggregate
then
3888 if not Safe_Aggregate
(Expr
) then
3892 elsif not Safe_Component
(Expr
) then
3900 if Present
(Component_Associations
(Aggr
)) then
3901 Expr
:= First
(Component_Associations
(Aggr
));
3902 while Present
(Expr
) loop
3903 if Nkind
(Expression
(Expr
)) = N_Aggregate
then
3904 if not Safe_Aggregate
(Expression
(Expr
)) then
3908 -- If association has a box, no way to determine yet whether
3909 -- default can be assigned in place.
3911 elsif Box_Present
(Expr
) then
3914 elsif not Safe_Component
(Expression
(Expr
)) then
3925 --------------------
3926 -- Safe_Component --
3927 --------------------
3929 function Safe_Component
(Expr
: Node_Id
) return Boolean is
3930 Comp
: Node_Id
:= Expr
;
3932 function Check_Component
(C
: Node_Id
; T_OK
: Boolean) return Boolean;
3933 -- Do the recursive traversal, after copy. If T_OK is True, return
3934 -- True for a stand-alone object only if the target is statically
3935 -- known and distinct from the object. At the top level, we start
3936 -- with T_OK set to False and set it to True at a deeper level only
3937 -- if we cannot disambiguate the component here without statically
3938 -- knowing the target. Note that this is not optimal, we should do
3939 -- something along the lines of Denotes_Same_Prefix for that.
3941 ---------------------
3942 -- Check_Component --
3943 ---------------------
3945 function Check_Component
(C
: Node_Id
; T_OK
: Boolean) return Boolean
3948 function SDO
(E
: Entity_Id
) return Uint
;
3949 -- Return the Scope Depth Of the enclosing dynamic scope of E
3955 function SDO
(E
: Entity_Id
) return Uint
is
3957 return Scope_Depth
(Enclosing_Dynamic_Scope
(E
));
3960 -- Start of processing for Check_Component
3963 if Is_Overloaded
(C
) then
3966 elsif Compile_Time_Known_Value
(C
) then
3971 when N_Attribute_Reference
=>
3972 return Check_Component
(Prefix
(C
), T_OK
);
3974 when N_Function_Call
=>
3975 if Nkind
(Name
(C
)) = N_Explicit_Dereference
then
3976 return not Returns_By_Ref
(Etype
(Name
(C
)));
3978 return not Returns_By_Ref
(Entity
(Name
(C
)));
3981 when N_Indexed_Component | N_Slice
=>
3982 -- In a target record, these operations cannot determine
3983 -- alone a component so we can recurse whatever the target.
3984 return Check_Component
(Prefix
(C
), T_OK
or else Is_Array
);
3986 when N_Selected_Component
=>
3987 -- In a target array, this operation cannot determine alone
3988 -- a component so we can recurse whatever the target.
3990 Check_Component
(Prefix
(C
), T_OK
or else not Is_Array
);
3992 when N_Type_Conversion | N_Unchecked_Type_Conversion
=>
3993 return Check_Component
(Expression
(C
), T_OK
);
3996 return Check_Component
(Left_Opnd
(C
), T_OK
)
3997 and then Check_Component
(Right_Opnd
(C
), T_OK
);
4000 return Check_Component
(Right_Opnd
(C
), T_OK
);
4003 if Is_Entity_Name
(C
) and then Is_Object
(Entity
(C
)) then
4004 -- Case of a formal parameter component. It's either
4005 -- trivial if passed by copy or very annoying if not,
4006 -- because in the latter case it's almost equivalent
4007 -- to a dereference, so the path-based disambiguation
4008 -- logic is totally off and we always need the target.
4010 if Is_Formal
(Entity
(C
)) then
4012 -- If it is passed by copy, then this is safe
4014 if Mechanism
(Entity
(C
)) = By_Copy
then
4017 -- Otherwise, this is safe if the target is present
4018 -- and is at least as deeply nested as the component.
4021 return Present
(Target_Object
)
4022 and then not Is_Formal
(Target_Object
)
4023 and then SDO
(Target_Object
) >= SDO
(Entity
(C
));
4026 -- For a renamed object, recurse
4028 elsif Present
(Renamed_Object
(Entity
(C
))) then
4030 Check_Component
(Renamed_Object
(Entity
(C
)), T_OK
);
4032 -- If this is safe whatever the target, we are done
4037 -- If there is no target or the component is the target,
4038 -- this is not safe.
4040 elsif No
(Target_Object
)
4041 or else Entity
(C
) = Target_Object
4045 -- Case of a formal parameter target. This is safe if it
4046 -- is at most as deeply nested as the component.
4048 elsif Is_Formal
(Target_Object
) then
4049 return SDO
(Target_Object
) <= SDO
(Entity
(C
));
4051 -- For distinct stand-alone objects, this is safe
4057 -- For anything else than an object, this is not safe
4063 end Check_Component
;
4065 -- Start of processing for Safe_Component
4068 -- If the component appears in an association that may correspond
4069 -- to more than one element, it is not analyzed before expansion
4070 -- into assignments, to avoid side effects. We analyze, but do not
4071 -- resolve the copy, to obtain sufficient entity information for
4072 -- the checks that follow. If component is overloaded we assume
4073 -- an unsafe function call.
4075 if not Analyzed
(Comp
) then
4076 if Is_Overloaded
(Expr
) then
4079 elsif Nkind
(Expr
) = N_Allocator
then
4081 -- For now, too complex to analyze
4085 elsif Nkind
(Parent
(Expr
)) = N_Iterated_Component_Association
then
4087 -- Ditto for iterated component associations, which in general
4088 -- require an enclosing loop and involve nonstatic expressions.
4093 Comp
:= New_Copy_Tree
(Expr
);
4094 Set_Parent
(Comp
, Parent
(Expr
));
4098 if Nkind
(Comp
) = N_Aggregate
then
4099 return Safe_Aggregate
(Comp
);
4101 return Check_Component
(Comp
, False);
4105 -- Start of processing for In_Place_Assign_OK
4108 -- By-copy semantic cannot be guaranteed for controlled objects
4110 if Needs_Finalization
(Etype
(N
)) then
4114 Parent_Node
:= Parent
(N
);
4115 Parent_Kind
:= Nkind
(Parent_Node
);
4117 if Parent_Kind
= N_Qualified_Expression
then
4118 Parent_Node
:= Parent
(Parent_Node
);
4119 Parent_Kind
:= Nkind
(Parent_Node
);
4122 -- On assignment, sliding can take place, so we cannot do the
4123 -- assignment in place unless the bounds of the aggregate are
4124 -- statically equal to those of the target.
4126 -- If the aggregate is given by an others choice, the bounds are
4127 -- derived from the left-hand side, and the assignment is safe if
4128 -- the expression is.
4131 and then Present
(Component_Associations
(N
))
4132 and then not Is_Others_Aggregate
(N
)
4134 Aggr_In
:= First_Index
(Etype
(N
));
4136 -- Context is an assignment
4138 if Parent_Kind
= N_Assignment_Statement
then
4139 Obj_In
:= First_Index
(Etype
(Name
(Parent_Node
)));
4141 -- Context is an allocator. Check the bounds of the aggregate against
4142 -- those of the designated type, except in the case where the type is
4143 -- unconstrained (and then we can directly return true, see below).
4145 else pragma Assert
(Parent_Kind
= N_Allocator
);
4147 Desig_Typ
: constant Entity_Id
:=
4148 Designated_Type
(Etype
(Parent_Node
));
4150 if not Is_Constrained
(Desig_Typ
) then
4154 Obj_In
:= First_Index
(Desig_Typ
);
4158 while Present
(Aggr_In
) loop
4159 Aggr_Bounds
:= Get_Index_Bounds
(Aggr_In
);
4160 Obj_Bounds
:= Get_Index_Bounds
(Obj_In
);
4162 -- We require static bounds for the target and a static matching
4163 -- of low bound for the aggregate.
4165 if not Compile_Time_Known_Value
(Obj_Bounds
.First
)
4166 or else not Compile_Time_Known_Value
(Obj_Bounds
.Last
)
4167 or else not Compile_Time_Known_Value
(Aggr_Bounds
.First
)
4168 or else Expr_Value
(Aggr_Bounds
.First
) /=
4169 Expr_Value
(Obj_Bounds
.First
)
4173 -- For an assignment statement we require static matching of
4174 -- bounds. Ditto for an allocator whose qualified expression
4175 -- is a constrained type. If the expression in the allocator
4176 -- is an unconstrained array, we accept an upper bound that
4177 -- is not static, to allow for nonstatic expressions of the
4178 -- base type. Clearly there are further possibilities (with
4179 -- diminishing returns) for safely building arrays in place
4182 elsif Parent_Kind
= N_Assignment_Statement
4183 or else Is_Constrained
(Etype
(Parent_Node
))
4185 if not Compile_Time_Known_Value
(Aggr_Bounds
.Last
)
4186 or else Expr_Value
(Aggr_Bounds
.Last
) /=
4187 Expr_Value
(Obj_Bounds
.Last
)
4193 Next_Index
(Aggr_In
);
4194 Next_Index
(Obj_In
);
4198 -- Now check the component values themselves, except for an allocator
4199 -- for which the target is newly allocated memory.
4201 if Parent_Kind
= N_Allocator
then
4204 return Safe_Aggregate
(N
);
4206 end In_Place_Assign_OK
;
4208 ----------------------------
4209 -- Convert_To_Assignments --
4210 ----------------------------
4212 procedure Convert_To_Assignments
(N
: Node_Id
; Typ
: Entity_Id
) is
4213 Loc
: constant Source_Ptr
:= Sloc
(N
);
4217 Aggr_Code
: List_Id
;
4219 Target_Expr
: Node_Id
;
4220 Parent_Kind
: Node_Kind
;
4221 Unc_Decl
: Boolean := False;
4222 Parent_Node
: Node_Id
;
4225 pragma Assert
(Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
);
4226 pragma Assert
(not Is_Static_Dispatch_Table_Aggregate
(N
));
4227 pragma Assert
(Is_Record_Type
(Typ
));
4229 Parent_Node
:= Parent
(N
);
4230 Parent_Kind
:= Nkind
(Parent_Node
);
4232 if Parent_Kind
= N_Qualified_Expression
then
4233 -- Check if we are in an unconstrained declaration because in this
4234 -- case the current delayed expansion mechanism doesn't work when
4235 -- the declared object size depends on the initializing expr.
4237 Parent_Node
:= Parent
(Parent_Node
);
4238 Parent_Kind
:= Nkind
(Parent_Node
);
4240 if Parent_Kind
= N_Object_Declaration
then
4242 not Is_Entity_Name
(Object_Definition
(Parent_Node
))
4243 or else (Nkind
(N
) = N_Aggregate
4246 (Entity
(Object_Definition
(Parent_Node
))))
4247 or else Is_Class_Wide_Type
4248 (Entity
(Object_Definition
(Parent_Node
)));
4252 -- Just set the Delay flag in the cases where the transformation will be
4253 -- done top down from above.
4256 -- Internal aggregates (transformed when expanding the parent),
4257 -- excluding container aggregates as these are transformed into
4258 -- subprogram calls later.
4260 (Parent_Kind
= N_Component_Association
4261 and then not Is_Container_Aggregate
(Parent
(Parent_Node
)))
4263 or else (Parent_Kind
in N_Aggregate | N_Extension_Aggregate
4264 and then not Is_Container_Aggregate
(Parent_Node
))
4266 -- Allocator (see Convert_Aggr_In_Allocator)
4268 or else Parent_Kind
= N_Allocator
4270 -- Object declaration (see Convert_Aggr_In_Object_Decl)
4272 or else (Parent_Kind
= N_Object_Declaration
and then not Unc_Decl
)
4274 -- Safe assignment (see Convert_Aggr_Assignments). So far only the
4275 -- assignments in init procs are taken into account.
4277 or else (Parent_Kind
= N_Assignment_Statement
4278 and then Inside_Init_Proc
)
4280 -- (Ada 2005) An inherently limited type in a return statement, which
4281 -- will be handled in a build-in-place fashion, and may be rewritten
4282 -- as an extended return and have its own finalization machinery.
4283 -- In the case of a simple return, the aggregate needs to be delayed
4284 -- until the scope for the return statement has been created, so
4285 -- that any finalization chain will be associated with that scope.
4286 -- For extended returns, we delay expansion to avoid the creation
4287 -- of an unwanted transient scope that could result in premature
4288 -- finalization of the return object (which is built in place
4289 -- within the caller's scope).
4291 or else Is_Build_In_Place_Aggregate_Return
(N
)
4293 Set_Expansion_Delayed
(N
);
4297 -- Otherwise, if a transient scope is required, create it now. If we
4298 -- are within an initialization procedure do not create such, because
4299 -- the target of the assignment must not be declared within a local
4300 -- block, and because cleanup will take place on return from the
4301 -- initialization procedure.
4303 -- Should the condition be more restrictive ???
4305 if Requires_Transient_Scope
(Typ
) and then not Inside_Init_Proc
then
4306 Establish_Transient_Scope
(N
, Manage_Sec_Stack
=> False);
4309 -- If the aggregate is nonlimited, create a temporary, since aggregates
4310 -- have "by copy" semantics. If it is limited and context is an
4311 -- assignment, this is a subaggregate for an enclosing aggregate being
4312 -- expanded. It must be built in place, so use target of the current
4315 if Is_Limited_Type
(Typ
)
4316 and then Parent_Kind
= N_Assignment_Statement
4318 Target_Expr
:= New_Copy_Tree
(Name
(Parent_Node
));
4319 Insert_Actions
(Parent_Node
,
4320 Build_Record_Aggr_Code
(N
, Typ
, Target_Expr
));
4321 Rewrite
(Parent_Node
, Make_Null_Statement
(Loc
));
4323 -- Do not declare a temporary to initialize an aggregate assigned to
4324 -- a target when in-place assignment is possible, i.e. preserving the
4325 -- by-copy semantic of aggregates. This avoids large stack usage and
4326 -- generates more efficient code.
4328 elsif Parent_Kind
= N_Assignment_Statement
4329 and then In_Place_Assign_OK
(N
, Get_Base_Object
(Name
(Parent_Node
)))
4332 Lhs
: constant Node_Id
:= Name
(Parent_Node
);
4334 -- Apply discriminant check if required
4336 if Has_Discriminants
(Etype
(N
)) then
4337 Apply_Discriminant_Check
(N
, Etype
(Lhs
), Lhs
);
4340 -- The check just above may have replaced the aggregate with a CE
4342 if Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
then
4343 Target_Expr
:= New_Copy_Tree
(Lhs
);
4344 Insert_Actions
(Parent_Node
,
4345 Build_Record_Aggr_Code
(N
, Typ
, Target_Expr
));
4346 Rewrite
(Parent_Node
, Make_Null_Statement
(Loc
));
4351 Temp
:= Make_Temporary
(Loc
, 'A', N
);
4353 -- If the type inherits unknown discriminants, use the view with
4354 -- known discriminants if available.
4356 if Has_Unknown_Discriminants
(Typ
)
4357 and then Present
(Underlying_Record_View
(Typ
))
4359 T
:= Underlying_Record_View
(Typ
);
4365 Make_Object_Declaration
(Loc
,
4366 Defining_Identifier
=> Temp
,
4367 Object_Definition
=> New_Occurrence_Of
(T
, Loc
));
4369 Set_No_Initialization
(Instr
);
4370 Insert_Action
(N
, Instr
);
4371 Initialize_Discriminants
(Instr
, T
);
4373 Target_Expr
:= New_Occurrence_Of
(Temp
, Loc
);
4374 Aggr_Code
:= Build_Record_Aggr_Code
(N
, T
, Target_Expr
);
4376 -- Save the last assignment statement associated with the aggregate
4377 -- when building a controlled object. This reference is utilized by
4378 -- the finalization machinery when marking an object as successfully
4381 if Needs_Finalization
(T
) then
4382 Set_Last_Aggregate_Assignment
(Temp
, Last
(Aggr_Code
));
4385 Insert_Actions
(N
, Aggr_Code
);
4386 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4387 Analyze_And_Resolve
(N
, T
);
4389 end Convert_To_Assignments
;
4391 ---------------------------
4392 -- Convert_To_Positional --
4393 ---------------------------
4395 procedure Convert_To_Positional
4397 Handle_Bit_Packed
: Boolean := False)
4399 Typ
: constant Entity_Id
:= Etype
(N
);
4400 Dims
: constant Nat
:= Number_Dimensions
(Typ
);
4401 Max_Others_Replicate
: constant Nat
:= Max_Aggregate_Size
(N
);
4403 Static_Components
: Boolean := True;
4405 procedure Check_Static_Components
;
4406 -- Check whether all components of the aggregate are compile-time known
4407 -- values, and can be passed as is to the back-end without further
4414 Ixb
: Node_Id
) return Boolean;
4415 -- Convert the aggregate into a purely positional form if possible after
4416 -- checking that the bounds of all dimensions are known to be static.
4418 function Is_Flat
(N
: Node_Id
; Dims
: Nat
) return Boolean;
4419 -- Return True if the aggregate N is flat (which is not trivial in the
4420 -- case of multidimensional aggregates).
4422 function Is_Static_Element
(N
: Node_Id
; Dims
: Nat
) return Boolean;
4423 -- Return True if N, an element of a component association list, i.e.
4424 -- N_Component_Association or N_Iterated_Component_Association, has a
4425 -- compile-time known value and can be passed as is to the back-end
4426 -- without further expansion.
4427 -- An Iterated_Component_Association is treated as nonstatic in most
4428 -- cases for now, so there are possibilities for optimization.
4430 -----------------------------
4431 -- Check_Static_Components --
4432 -----------------------------
4434 -- Could use some comments in this body ???
4436 procedure Check_Static_Components
is
4441 Static_Components
:= True;
4443 if Nkind
(N
) = N_String_Literal
then
4446 elsif Present
(Expressions
(N
)) then
4447 Expr
:= First
(Expressions
(N
));
4448 while Present
(Expr
) loop
4449 if Nkind
(Expr
) /= N_Aggregate
4450 or else not Compile_Time_Known_Aggregate
(Expr
)
4451 or else Expansion_Delayed
(Expr
)
4453 Static_Components
:= False;
4461 if Nkind
(N
) = N_Aggregate
4462 and then Present
(Component_Associations
(N
))
4464 Assoc
:= First
(Component_Associations
(N
));
4465 while Present
(Assoc
) loop
4466 if not Is_Static_Element
(Assoc
, Dims
) then
4467 Static_Components
:= False;
4474 end Check_Static_Components
;
4484 Ixb
: Node_Id
) return Boolean
4486 Loc
: constant Source_Ptr
:= Sloc
(N
);
4487 Blo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Ixb
));
4488 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Ix
));
4489 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Ix
));
4491 function Cannot_Flatten_Next_Aggr
(Expr
: Node_Id
) return Boolean;
4492 -- Return true if Expr is an aggregate for the next dimension that
4493 -- cannot be recursively flattened.
4495 ------------------------------
4496 -- Cannot_Flatten_Next_Aggr --
4497 ------------------------------
4499 function Cannot_Flatten_Next_Aggr
(Expr
: Node_Id
) return Boolean is
4501 return Nkind
(Expr
) = N_Aggregate
4502 and then Present
(Next_Index
(Ix
))
4504 Flatten
(Expr
, Dims
- 1, Next_Index
(Ix
), Next_Index
(Ixb
));
4505 end Cannot_Flatten_Next_Aggr
;
4511 Others_Present
: Boolean;
4513 -- Start of processing for Flatten
4516 if Nkind
(Original_Node
(N
)) = N_String_Literal
then
4520 if not Compile_Time_Known_Value
(Lo
)
4521 or else not Compile_Time_Known_Value
(Hi
)
4526 Lov
:= Expr_Value
(Lo
);
4527 Hiv
:= Expr_Value
(Hi
);
4529 -- Check if there is an others choice
4531 Others_Present
:= False;
4533 if Present
(Component_Associations
(N
)) then
4534 if Is_Empty_List
(Component_Associations
(N
)) then
4535 -- an expanded null array aggregate
4544 Assoc
:= First
(Component_Associations
(N
));
4545 while Present
(Assoc
) loop
4547 -- If this is a box association, flattening is in general
4548 -- not possible because at this point we cannot tell if the
4549 -- default is static or even exists.
4551 if Box_Present
(Assoc
) then
4554 elsif Nkind
(Assoc
) = N_Iterated_Component_Association
then
4558 Choice
:= First
(Choice_List
(Assoc
));
4560 while Present
(Choice
) loop
4561 if Nkind
(Choice
) = N_Others_Choice
then
4562 Others_Present
:= True;
4573 -- If the low bound is not known at compile time and others is not
4574 -- present we can proceed since the bounds can be obtained from the
4578 or else (not Compile_Time_Known_Value
(Blo
) and then Others_Present
)
4583 -- Determine if set of alternatives is suitable for conversion and
4584 -- build an array containing the values in sequence.
4587 Vals
: array (UI_To_Int
(Lov
) .. UI_To_Int
(Hiv
))
4588 of Node_Id
:= (others => Empty
);
4589 -- The values in the aggregate sorted appropriately
4592 -- Same data as Vals in list form
4595 -- Used to validate Max_Others_Replicate limit
4599 Num
: Int
:= UI_To_Int
(Lov
);
4605 if Present
(Expressions
(N
)) then
4606 Elmt
:= First
(Expressions
(N
));
4607 while Present
(Elmt
) loop
4608 -- In the case of a multidimensional array, check that the
4609 -- aggregate can be recursively flattened.
4611 if Cannot_Flatten_Next_Aggr
(Elmt
) then
4615 -- Duplicate expression for each index it covers
4617 Vals
(Num
) := New_Copy_Tree
(Elmt
);
4624 if No
(Component_Associations
(N
)) then
4628 Elmt
:= First
(Component_Associations
(N
));
4630 Component_Loop
: while Present
(Elmt
) loop
4631 Expr
:= Expression
(Elmt
);
4633 -- In the case of a multidimensional array, check that the
4634 -- aggregate can be recursively flattened.
4636 if Cannot_Flatten_Next_Aggr
(Expr
) then
4640 Choice
:= First
(Choice_List
(Elmt
));
4641 Choice_Loop
: while Present
(Choice
) loop
4643 -- If we have an others choice, fill in the missing elements
4644 -- subject to the limit established by Max_Others_Replicate.
4646 if Nkind
(Choice
) = N_Others_Choice
then
4649 -- If the expression involves a construct that generates
4650 -- a loop, we must generate individual assignments and
4651 -- no flattening is possible.
4653 if Nkind
(Expr
) = N_Quantified_Expression
then
4657 for J
in Vals
'Range loop
4658 if No
(Vals
(J
)) then
4659 Vals
(J
) := New_Copy_Tree
(Expr
);
4660 Rep_Count
:= Rep_Count
+ 1;
4662 -- Check for maximum others replication. Note that
4663 -- we skip this test if either of the restrictions
4664 -- No_Implicit_Loops or No_Elaboration_Code is
4665 -- active, if this is a preelaborable unit or
4666 -- a predefined unit, or if the unit must be
4667 -- placed in data memory. This also ensures that
4668 -- predefined units get the same level of constant
4669 -- folding in Ada 95 and Ada 2005, where their
4670 -- categorization has changed.
4673 P
: constant Entity_Id
:=
4674 Cunit_Entity
(Current_Sem_Unit
);
4677 -- Check if duplication is always OK and, if so,
4678 -- continue processing.
4680 if Restriction_Active
(No_Implicit_Loops
) then
4683 -- If duplication is not always OK, continue
4684 -- only if either the element is static or is
4685 -- an aggregate (we already know it is OK).
4687 elsif not Is_Static_Element
(Elmt
, Dims
)
4688 and then Nkind
(Expr
) /= N_Aggregate
4692 -- Check if duplication is OK for elaboration
4693 -- purposes and, if so, continue processing.
4695 elsif Restriction_Active
(No_Elaboration_Code
)
4697 (Ekind
(Current_Scope
) = E_Package
4699 Static_Elaboration_Desired
(Current_Scope
))
4700 or else Is_Preelaborated
(P
)
4701 or else (Ekind
(P
) = E_Package_Body
4703 Is_Preelaborated
(Spec_Entity
(P
)))
4705 Is_Predefined_Unit
(Get_Source_Unit
(P
))
4709 -- Otherwise, check that the replication count
4712 elsif Rep_Count
> Max_Others_Replicate
then
4720 and then Warn_On_Redundant_Constructs
4722 Error_Msg_N
("there are no others?r?", Elmt
);
4725 exit Component_Loop
;
4727 -- Case of a subtype mark, identifier or expanded name
4729 elsif Is_Entity_Name
(Choice
)
4730 and then Is_Type
(Entity
(Choice
))
4732 Lo
:= Type_Low_Bound
(Etype
(Choice
));
4733 Hi
:= Type_High_Bound
(Etype
(Choice
));
4735 -- Case of subtype indication
4737 elsif Nkind
(Choice
) = N_Subtype_Indication
then
4738 Lo
:= Low_Bound
(Range_Expression
(Constraint
(Choice
)));
4739 Hi
:= High_Bound
(Range_Expression
(Constraint
(Choice
)));
4743 elsif Nkind
(Choice
) = N_Range
then
4744 Lo
:= Low_Bound
(Choice
);
4745 Hi
:= High_Bound
(Choice
);
4747 -- Normal subexpression case
4749 else pragma Assert
(Nkind
(Choice
) in N_Subexpr
);
4750 if not Compile_Time_Known_Value
(Choice
) then
4754 Choice_Index
:= UI_To_Int
(Expr_Value
(Choice
));
4756 if Choice_Index
in Vals
'Range then
4757 Vals
(Choice_Index
) := New_Copy_Tree
(Expr
);
4760 -- Choice is statically out-of-range, will be
4761 -- rewritten to raise Constraint_Error.
4769 -- Range cases merge with Lo,Hi set
4771 if not Compile_Time_Known_Value
(Lo
)
4773 not Compile_Time_Known_Value
(Hi
)
4778 for J
in UI_To_Int
(Expr_Value
(Lo
)) ..
4779 UI_To_Int
(Expr_Value
(Hi
))
4781 Vals
(J
) := New_Copy_Tree
(Expr
);
4787 end loop Choice_Loop
;
4790 end loop Component_Loop
;
4792 -- If we get here the conversion is possible
4795 for J
in Vals
'Range loop
4796 Append
(Vals
(J
), Vlist
);
4799 Rewrite
(N
, Make_Aggregate
(Loc
, Expressions
=> Vlist
));
4800 Set_Aggregate_Bounds
(N
, Aggregate_Bounds
(Original_Node
(N
)));
4809 function Is_Flat
(N
: Node_Id
; Dims
: Nat
) return Boolean is
4816 elsif Nkind
(N
) = N_Aggregate
then
4817 if Present
(Component_Associations
(N
)) then
4821 Elmt
:= First
(Expressions
(N
));
4822 while Present
(Elmt
) loop
4823 if not Is_Flat
(Elmt
, Dims
- 1) then
4837 -------------------------
4838 -- Is_Static_Element --
4839 -------------------------
4841 function Is_Static_Element
(N
: Node_Id
; Dims
: Nat
) return Boolean is
4842 Expr
: constant Node_Id
:= Expression
(N
);
4845 -- In most cases the interesting expressions are unambiguously static
4847 if Compile_Time_Known_Value
(Expr
) then
4850 elsif Nkind
(N
) = N_Iterated_Component_Association
then
4853 elsif Nkind
(Expr
) = N_Aggregate
4854 and then Compile_Time_Known_Aggregate
(Expr
)
4855 and then not Expansion_Delayed
(Expr
)
4859 -- However, one may write static expressions that are syntactically
4860 -- ambiguous, so preanalyze the expression before checking it again,
4861 -- but only at the innermost level for a multidimensional array.
4864 Preanalyze_And_Resolve
(Expr
, Component_Type
(Typ
));
4865 return Compile_Time_Known_Value
(Expr
);
4870 end Is_Static_Element
;
4872 -- Start of processing for Convert_To_Positional
4875 -- Only convert to positional when generating C in case of an
4876 -- object declaration, this is the only case where aggregates are
4879 if Modify_Tree_For_C
and then not Is_CCG_Supported_Aggregate
(N
) then
4883 -- Ada 2005 (AI-287): Do not convert in case of default initialized
4884 -- components because in this case will need to call the corresponding
4887 if Has_Default_Init_Comps
(N
) then
4891 -- A subaggregate may have been flattened but is not known to be
4892 -- Compile_Time_Known. Set that flag in cases that cannot require
4893 -- elaboration code, so that the aggregate can be used as the
4894 -- initial value of a thread-local variable.
4896 if Is_Flat
(N
, Dims
) then
4897 if Static_Array_Aggregate
(N
) then
4898 Set_Compile_Time_Known_Aggregate
(N
);
4904 if Is_Bit_Packed_Array
(Typ
) and then not Handle_Bit_Packed
then
4908 -- Do not convert to positional if controlled components are involved
4909 -- since these require special processing
4911 if Has_Controlled_Component
(Typ
) then
4915 Check_Static_Components
;
4917 -- If the size is known, or all the components are static, try to
4918 -- build a fully positional aggregate.
4920 -- The size of the type may not be known for an aggregate with
4921 -- discriminated array components, but if the components are static
4922 -- it is still possible to verify statically that the length is
4923 -- compatible with the upper bound of the type, and therefore it is
4924 -- worth flattening such aggregates as well.
4928 Flatten
(N
, Dims
, First_Index
(Typ
), First_Index
(Base_Type
(Typ
)))
4930 if Static_Components
then
4931 Set_Compile_Time_Known_Aggregate
(N
);
4932 Set_Expansion_Delayed
(N
, False);
4935 Analyze_And_Resolve
(N
, Typ
);
4938 -- If Static_Elaboration_Desired has been specified, diagnose aggregates
4939 -- that will still require initialization code.
4941 if (Ekind
(Current_Scope
) = E_Package
4942 and then Static_Elaboration_Desired
(Current_Scope
))
4943 and then Nkind
(Parent
(N
)) = N_Object_Declaration
4949 if Nkind
(N
) = N_Aggregate
and then Present
(Expressions
(N
)) then
4950 Expr
:= First
(Expressions
(N
));
4951 while Present
(Expr
) loop
4952 if not Compile_Time_Known_Value
(Expr
) then
4954 ("non-static object requires elaboration code??", N
);
4961 if Present
(Component_Associations
(N
)) then
4962 Error_Msg_N
("object requires elaboration code??", N
);
4967 end Convert_To_Positional
;
4969 ----------------------------
4970 -- Expand_Array_Aggregate --
4971 ----------------------------
4973 -- Array aggregate expansion proceeds as follows:
4975 -- 1. If requested we generate code to perform all the array aggregate
4976 -- bound checks, specifically
4978 -- (a) Check that the index range defined by aggregate bounds is
4979 -- compatible with corresponding index subtype.
4981 -- (b) If an others choice is present check that no aggregate
4982 -- index is outside the bounds of the index constraint.
4984 -- (c) For multidimensional arrays make sure that all subaggregates
4985 -- corresponding to the same dimension have the same bounds.
4987 -- 2. Check for packed array aggregate which can be converted to a
4988 -- constant so that the aggregate disappears completely.
4990 -- 3. Check case of nested aggregate. Generally nested aggregates are
4991 -- handled during the processing of the parent aggregate.
4993 -- 4. Check if the aggregate can be statically processed. If this is the
4994 -- case pass it as is to Gigi. Note that a necessary condition for
4995 -- static processing is that the aggregate be fully positional.
4997 -- 5. If in-place aggregate expansion is possible (i.e. no need to create
4998 -- a temporary) then mark the aggregate as such and return. Otherwise
4999 -- create a new temporary and generate the appropriate initialization
5002 procedure Expand_Array_Aggregate
(N
: Node_Id
) is
5003 Loc
: constant Source_Ptr
:= Sloc
(N
);
5005 Typ
: constant Entity_Id
:= Etype
(N
);
5006 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
5007 -- Typ is the correct constrained array subtype of the aggregate
5008 -- Ctyp is the corresponding component type.
5010 Aggr_Dimension
: constant Pos
:= Number_Dimensions
(Typ
);
5011 -- Number of aggregate index dimensions
5013 Aggr_Low
: array (1 .. Aggr_Dimension
) of Node_Id
;
5014 Aggr_High
: array (1 .. Aggr_Dimension
) of Node_Id
;
5015 -- Low and High bounds of the constraint for each aggregate index
5017 Aggr_Index_Typ
: array (1 .. Aggr_Dimension
) of Entity_Id
;
5018 -- The type of each index
5020 In_Place_Assign_OK_For_Declaration
: Boolean := False;
5021 -- True if we are to generate an in-place assignment for a declaration
5023 Maybe_In_Place_OK
: Boolean;
5024 -- If the type is neither controlled nor packed and the aggregate
5025 -- is the expression in an assignment, assignment in place may be
5026 -- possible, provided other conditions are met on the LHS.
5028 Others_Present
: array (1 .. Aggr_Dimension
) of Boolean :=
5030 -- If Others_Present (J) is True, then there is an others choice in one
5031 -- of the subaggregates of N at dimension J.
5033 procedure Build_Constrained_Type
(Positional
: Boolean);
5034 -- If the subtype is not static or unconstrained, build a constrained
5035 -- type using the computable sizes of the aggregate and its sub-
5038 procedure Check_Bounds
(Aggr_Bounds_Node
, Index_Bounds_Node
: Node_Id
);
5039 -- Checks that the bounds of Aggr_Bounds are within the bounds defined
5040 -- by Index_Bounds. For null array aggregate (Ada 2022) check that the
5041 -- aggregate bounds define a null range.
5043 procedure Check_Same_Aggr_Bounds
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
5044 -- Checks that in a multidimensional array aggregate all subaggregates
5045 -- corresponding to the same dimension have the same bounds. Sub_Aggr is
5046 -- an array subaggregate. Dim is the dimension corresponding to the
5049 procedure Compute_Others_Present
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
5050 -- Computes the values of array Others_Present. Sub_Aggr is the array
5051 -- subaggregate we start the computation from. Dim is the dimension
5052 -- corresponding to the subaggregate.
5054 procedure Others_Check
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
5055 -- Checks that if an others choice is present in any subaggregate, no
5056 -- aggregate index is outside the bounds of the index constraint.
5057 -- Sub_Aggr is an array subaggregate. Dim is the dimension corresponding
5058 -- to the subaggregate.
5060 function Safe_Left_Hand_Side
(N
: Node_Id
) return Boolean;
5061 -- In addition to Maybe_In_Place_OK, in order for an aggregate to be
5062 -- built directly into the target of the assignment it must be free
5063 -- of side effects. N is the LHS of an assignment.
5065 procedure Two_Pass_Aggregate_Expansion
(N
: Node_Id
);
5066 -- If the aggregate consists only of iterated associations then the
5067 -- aggregate is constructed in two steps:
5068 -- a) Build an expression to compute the number of elements
5069 -- generated by each iterator, and use the expression to allocate
5070 -- the destination aggregate.
5071 -- b) Generate the loops corresponding to each iterator to insert
5072 -- the elements in their proper positions.
5074 ----------------------------
5075 -- Build_Constrained_Type --
5076 ----------------------------
5078 procedure Build_Constrained_Type
(Positional
: Boolean) is
5079 Agg_Type
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5081 Indexes
: constant List_Id
:= New_List
;
5086 -- If the aggregate is purely positional, all its subaggregates
5087 -- have the same size. We collect the dimensions from the first
5088 -- subaggregate at each level.
5093 for D
in 1 .. Aggr_Dimension
loop
5094 Num
:= List_Length
(Expressions
(Sub_Agg
));
5098 Low_Bound
=> Make_Integer_Literal
(Loc
, Uint_1
),
5099 High_Bound
=> Make_Integer_Literal
(Loc
, Num
)));
5101 Sub_Agg
:= First
(Expressions
(Sub_Agg
));
5105 -- We know the aggregate type is unconstrained and the aggregate
5106 -- is not processable by the back end, therefore not necessarily
5107 -- positional. Retrieve each dimension bounds (computed earlier).
5109 for D
in 1 .. Aggr_Dimension
loop
5112 Low_Bound
=> Aggr_Low
(D
),
5113 High_Bound
=> Aggr_High
(D
)));
5118 Make_Full_Type_Declaration
(Loc
,
5119 Defining_Identifier
=> Agg_Type
,
5121 Make_Constrained_Array_Definition
(Loc
,
5122 Discrete_Subtype_Definitions
=> Indexes
,
5123 Component_Definition
=>
5124 Make_Component_Definition
(Loc
,
5125 Subtype_Indication
=>
5126 New_Occurrence_Of
(Component_Type
(Typ
), Loc
))));
5128 Insert_Action
(N
, Decl
);
5130 Set_Etype
(N
, Agg_Type
);
5131 Set_Is_Itype
(Agg_Type
);
5132 Freeze_Itype
(Agg_Type
, N
);
5133 end Build_Constrained_Type
;
5139 procedure Check_Bounds
(Aggr_Bounds_Node
, Index_Bounds_Node
: Node_Id
) is
5140 Aggr_Bounds
: constant Range_Nodes
:=
5141 Get_Index_Bounds
(Aggr_Bounds_Node
);
5142 Ind_Bounds
: constant Range_Nodes
:=
5143 Get_Index_Bounds
(Index_Bounds_Node
);
5148 -- For a null array aggregate check that high bound (i.e., low
5149 -- bound predecessor) exists. Fail if low bound is low bound of
5150 -- base subtype (in all cases, including modular).
5152 if Is_Null_Aggregate
(N
) then
5154 Make_Raise_Constraint_Error
(Loc
,
5157 New_Copy_Tree
(Aggr_Bounds
.First
),
5159 (Type_Low_Bound
(Base_Type
(Etype
(Ind_Bounds
.First
))))),
5160 Reason
=> CE_Range_Check_Failed
));
5164 -- Generate the following test:
5166 -- [constraint_error when
5167 -- Aggr_Bounds.First <= Aggr_Bounds.Last and then
5168 -- (Aggr_Bounds.First < Ind_Bounds.First
5169 -- or else Aggr_Bounds.Last > Ind_Bounds.Last)]
5171 -- As an optimization try to see if some tests are trivially vacuous
5172 -- because we are comparing an expression against itself.
5174 if Aggr_Bounds
.First
= Ind_Bounds
.First
5175 and then Aggr_Bounds
.Last
= Ind_Bounds
.Last
5179 elsif Aggr_Bounds
.Last
= Ind_Bounds
.Last
then
5183 Duplicate_Subexpr_Move_Checks
(Aggr_Bounds
.First
),
5185 Duplicate_Subexpr_Move_Checks
(Ind_Bounds
.First
));
5187 elsif Aggr_Bounds
.First
= Ind_Bounds
.First
then
5190 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Bounds
.Last
),
5191 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Bounds
.Last
));
5199 Duplicate_Subexpr_Move_Checks
(Aggr_Bounds
.First
),
5201 Duplicate_Subexpr_Move_Checks
(Ind_Bounds
.First
)),
5205 Left_Opnd
=> Duplicate_Subexpr
(Aggr_Bounds
.Last
),
5206 Right_Opnd
=> Duplicate_Subexpr
(Ind_Bounds
.Last
)));
5209 if Present
(Cond
) then
5215 Duplicate_Subexpr_Move_Checks
(Aggr_Bounds
.First
),
5217 Duplicate_Subexpr_Move_Checks
(Aggr_Bounds
.Last
)),
5219 Right_Opnd
=> Cond
);
5221 Set_Analyzed
(Left_Opnd
(Left_Opnd
(Cond
)), False);
5222 Set_Analyzed
(Right_Opnd
(Left_Opnd
(Cond
)), False);
5224 Make_Raise_Constraint_Error
(Loc
,
5226 Reason
=> CE_Range_Check_Failed
));
5230 ----------------------------
5231 -- Check_Same_Aggr_Bounds --
5232 ----------------------------
5234 procedure Check_Same_Aggr_Bounds
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
5235 Sub_Bounds
: constant Range_Nodes
:=
5236 Get_Index_Bounds
(Aggregate_Bounds
(Sub_Aggr
));
5237 Sub_Lo
: Node_Id
renames Sub_Bounds
.First
;
5238 Sub_Hi
: Node_Id
renames Sub_Bounds
.Last
;
5239 -- The bounds of this specific subaggregate
5241 Aggr_Lo
: constant Node_Id
:= Aggr_Low
(Dim
);
5242 Aggr_Hi
: constant Node_Id
:= Aggr_High
(Dim
);
5243 -- The bounds of the aggregate for this dimension
5245 Ind_Typ
: constant Entity_Id
:= Aggr_Index_Typ
(Dim
);
5246 -- The index type for this dimension.xxx
5253 -- If index checks are on generate the test
5255 -- [constraint_error when
5256 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
5258 -- As an optimization try to see if some tests are trivially vacuos
5259 -- because we are comparing an expression against itself. Also for
5260 -- the first dimension the test is trivially vacuous because there
5261 -- is just one aggregate for dimension 1.
5263 if Index_Checks_Suppressed
(Ind_Typ
) then
5266 elsif Dim
= 1 or else (Aggr_Lo
= Sub_Lo
and then Aggr_Hi
= Sub_Hi
)
5270 elsif Aggr_Hi
= Sub_Hi
then
5273 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
5274 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Lo
));
5276 elsif Aggr_Lo
= Sub_Lo
then
5279 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
),
5280 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Hi
));
5287 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
5288 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Lo
)),
5292 Left_Opnd
=> Duplicate_Subexpr
(Aggr_Hi
),
5293 Right_Opnd
=> Duplicate_Subexpr
(Sub_Hi
)));
5296 if Present
(Cond
) then
5298 Make_Raise_Constraint_Error
(Loc
,
5300 Reason
=> CE_Length_Check_Failed
));
5303 -- Now look inside the subaggregate to see if there is more work
5305 if Dim
< Aggr_Dimension
then
5307 -- Process positional components
5309 if Present
(Expressions
(Sub_Aggr
)) then
5310 Expr
:= First
(Expressions
(Sub_Aggr
));
5311 while Present
(Expr
) loop
5312 Check_Same_Aggr_Bounds
(Expr
, Dim
+ 1);
5317 -- Process component associations
5319 if Present
(Component_Associations
(Sub_Aggr
)) then
5320 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
5321 while Present
(Assoc
) loop
5322 Expr
:= Expression
(Assoc
);
5323 Check_Same_Aggr_Bounds
(Expr
, Dim
+ 1);
5328 end Check_Same_Aggr_Bounds
;
5330 ----------------------------
5331 -- Compute_Others_Present --
5332 ----------------------------
5334 procedure Compute_Others_Present
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
5339 if Present
(Component_Associations
(Sub_Aggr
)) then
5340 Assoc
:= Last
(Component_Associations
(Sub_Aggr
));
5343 and then Nkind
(First
(Choice_List
(Assoc
))) = N_Others_Choice
5345 Others_Present
(Dim
) := True;
5347 -- An others_clause may be superfluous if previous components
5348 -- cover the full given range of a constrained array. In such
5349 -- a case an others_clause does not contribute any additional
5350 -- components and has not been analyzed. We analyze it now to
5351 -- detect type errors in the expression, even though no code
5352 -- will be generated for it.
5354 if Dim
= Aggr_Dimension
5355 and then Nkind
(Assoc
) /= N_Iterated_Component_Association
5356 and then not Analyzed
(Expression
(Assoc
))
5357 and then not Box_Present
(Assoc
)
5359 Preanalyze_And_Resolve
(Expression
(Assoc
), Ctyp
);
5364 -- Now look inside the subaggregate to see if there is more work
5366 if Dim
< Aggr_Dimension
then
5368 -- Process positional components
5370 if Present
(Expressions
(Sub_Aggr
)) then
5371 Expr
:= First
(Expressions
(Sub_Aggr
));
5372 while Present
(Expr
) loop
5373 Compute_Others_Present
(Expr
, Dim
+ 1);
5378 -- Process component associations
5380 if Present
(Component_Associations
(Sub_Aggr
)) then
5381 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
5382 while Present
(Assoc
) loop
5383 Expr
:= Expression
(Assoc
);
5384 Compute_Others_Present
(Expr
, Dim
+ 1);
5389 end Compute_Others_Present
;
5395 procedure Others_Check
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
5396 Aggr_Lo
: constant Node_Id
:= Aggr_Low
(Dim
);
5397 Aggr_Hi
: constant Node_Id
:= Aggr_High
(Dim
);
5398 -- The bounds of the aggregate for this dimension
5400 Ind_Typ
: constant Entity_Id
:= Aggr_Index_Typ
(Dim
);
5401 -- The index type for this dimension
5403 Need_To_Check
: Boolean := False;
5405 Choices_Lo
: Node_Id
:= Empty
;
5406 Choices_Hi
: Node_Id
:= Empty
;
5407 -- The lowest and highest discrete choices for a named subaggregate
5409 Nb_Choices
: Int
:= -1;
5410 -- The number of discrete non-others choices in this subaggregate
5412 Nb_Elements
: Uint
:= Uint_0
;
5413 -- The number of elements in a positional aggregate
5415 Cond
: Node_Id
:= Empty
;
5422 -- Check if we have an others choice. If we do make sure that this
5423 -- subaggregate contains at least one element in addition to the
5426 if Range_Checks_Suppressed
(Ind_Typ
) then
5427 Need_To_Check
:= False;
5429 elsif Present
(Expressions
(Sub_Aggr
))
5430 and then Present
(Component_Associations
(Sub_Aggr
))
5433 not (Is_Empty_List
(Expressions
(Sub_Aggr
))
5434 and then Is_Empty_List
5435 (Component_Associations
(Sub_Aggr
)));
5437 elsif Present
(Component_Associations
(Sub_Aggr
)) then
5438 Assoc
:= Last
(Component_Associations
(Sub_Aggr
));
5440 if Nkind
(First
(Choice_List
(Assoc
))) /= N_Others_Choice
then
5441 Need_To_Check
:= False;
5444 -- Count the number of discrete choices. Start with -1 because
5445 -- the others choice does not count.
5447 -- Is there some reason we do not use List_Length here ???
5450 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
5451 while Present
(Assoc
) loop
5452 Choice
:= First
(Choice_List
(Assoc
));
5453 while Present
(Choice
) loop
5454 Nb_Choices
:= Nb_Choices
+ 1;
5461 -- If there is only an others choice nothing to do
5463 Need_To_Check
:= (Nb_Choices
> 0);
5467 Need_To_Check
:= False;
5470 -- If we are dealing with a positional subaggregate with an others
5471 -- choice then compute the number or positional elements.
5473 if Need_To_Check
and then Present
(Expressions
(Sub_Aggr
)) then
5474 Expr
:= First
(Expressions
(Sub_Aggr
));
5475 Nb_Elements
:= Uint_0
;
5476 while Present
(Expr
) loop
5477 Nb_Elements
:= Nb_Elements
+ 1;
5481 -- If the aggregate contains discrete choices and an others choice
5482 -- compute the smallest and largest discrete choice values.
5484 elsif Need_To_Check
then
5485 Compute_Choices_Lo_And_Choices_Hi
: declare
5487 Table
: Case_Table_Type
(1 .. Nb_Choices
);
5488 -- Used to sort all the different choice values
5493 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
5494 while Present
(Assoc
) loop
5495 Choice
:= First
(Choice_List
(Assoc
));
5496 while Present
(Choice
) loop
5497 if Nkind
(Choice
) = N_Others_Choice
then
5502 Bounds
: constant Range_Nodes
:=
5503 Get_Index_Bounds
(Choice
);
5505 Table
(J
).Choice_Lo
:= Bounds
.First
;
5506 Table
(J
).Choice_Hi
:= Bounds
.Last
;
5516 -- Sort the discrete choices
5518 Sort_Case_Table
(Table
);
5520 Choices_Lo
:= Table
(1).Choice_Lo
;
5521 Choices_Hi
:= Table
(Nb_Choices
).Choice_Hi
;
5522 end Compute_Choices_Lo_And_Choices_Hi
;
5525 -- If no others choice in this subaggregate, or the aggregate
5526 -- comprises only an others choice, nothing to do.
5528 if not Need_To_Check
then
5531 -- If we are dealing with an aggregate containing an others choice
5532 -- and positional components, we generate the following test:
5534 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
5535 -- Ind_Typ'Pos (Aggr_Hi)
5537 -- raise Constraint_Error;
5540 -- in the general case, but the following simpler test:
5542 -- [constraint_error when
5543 -- Aggr_Lo + (Nb_Elements - 1) > Aggr_Hi];
5545 -- instead if the index type is a signed integer.
5547 elsif Nb_Elements
> Uint_0
then
5548 if Nb_Elements
= Uint_1
then
5551 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
5552 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
));
5554 elsif Is_Signed_Integer_Type
(Ind_Typ
) then
5559 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
5561 Make_Integer_Literal
(Loc
, Nb_Elements
- 1)),
5562 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
));
5570 Make_Attribute_Reference
(Loc
,
5571 Prefix
=> New_Occurrence_Of
(Ind_Typ
, Loc
),
5572 Attribute_Name
=> Name_Pos
,
5575 (Duplicate_Subexpr_Move_Checks
(Aggr_Lo
))),
5576 Right_Opnd
=> Make_Integer_Literal
(Loc
, Nb_Elements
- 1)),
5579 Make_Attribute_Reference
(Loc
,
5580 Prefix
=> New_Occurrence_Of
(Ind_Typ
, Loc
),
5581 Attribute_Name
=> Name_Pos
,
5582 Expressions
=> New_List
(
5583 Duplicate_Subexpr_Move_Checks
(Aggr_Hi
))));
5586 -- If we are dealing with an aggregate containing an others choice
5587 -- and discrete choices we generate the following test:
5589 -- [constraint_error when
5590 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
5597 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Choices_Lo
),
5598 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
)),
5602 Left_Opnd
=> Duplicate_Subexpr
(Choices_Hi
),
5603 Right_Opnd
=> Duplicate_Subexpr
(Aggr_Hi
)));
5606 if Present
(Cond
) then
5608 Make_Raise_Constraint_Error
(Loc
,
5610 Reason
=> CE_Length_Check_Failed
));
5611 -- Questionable reason code, shouldn't that be a
5612 -- CE_Range_Check_Failed ???
5615 -- Now look inside the subaggregate to see if there is more work
5617 if Dim
< Aggr_Dimension
then
5619 -- Process positional components
5621 if Present
(Expressions
(Sub_Aggr
)) then
5622 Expr
:= First
(Expressions
(Sub_Aggr
));
5623 while Present
(Expr
) loop
5624 Others_Check
(Expr
, Dim
+ 1);
5629 -- Process component associations
5631 if Present
(Component_Associations
(Sub_Aggr
)) then
5632 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
5633 while Present
(Assoc
) loop
5634 Expr
:= Expression
(Assoc
);
5635 Others_Check
(Expr
, Dim
+ 1);
5642 -------------------------
5643 -- Safe_Left_Hand_Side --
5644 -------------------------
5646 function Safe_Left_Hand_Side
(N
: Node_Id
) return Boolean is
5647 function Is_Safe_Index
(Indx
: Node_Id
) return Boolean;
5648 -- If the left-hand side includes an indexed component, check that
5649 -- the indexes are free of side effects.
5655 function Is_Safe_Index
(Indx
: Node_Id
) return Boolean is
5657 if Is_Entity_Name
(Indx
) then
5660 elsif Nkind
(Indx
) = N_Integer_Literal
then
5663 elsif Nkind
(Indx
) = N_Function_Call
5664 and then Is_Entity_Name
(Name
(Indx
))
5665 and then Has_Pragma_Pure_Function
(Entity
(Name
(Indx
)))
5669 elsif Nkind
(Indx
) = N_Type_Conversion
5670 and then Is_Safe_Index
(Expression
(Indx
))
5679 -- Start of processing for Safe_Left_Hand_Side
5682 if Is_Entity_Name
(N
) then
5685 elsif Nkind
(N
) in N_Explicit_Dereference | N_Selected_Component
5686 and then Safe_Left_Hand_Side
(Prefix
(N
))
5690 elsif Nkind
(N
) = N_Indexed_Component
5691 and then Safe_Left_Hand_Side
(Prefix
(N
))
5692 and then Is_Safe_Index
(First
(Expressions
(N
)))
5696 elsif Nkind
(N
) = N_Unchecked_Type_Conversion
then
5697 return Safe_Left_Hand_Side
(Expression
(N
));
5702 end Safe_Left_Hand_Side
;
5704 ----------------------------------
5705 -- Two_Pass_Aggregate_Expansion --
5706 ----------------------------------
5708 procedure Two_Pass_Aggregate_Expansion
(N
: Node_Id
) is
5709 Loc
: constant Source_Ptr
:= Sloc
(N
);
5710 Comp_Type
: constant Entity_Id
:= Etype
(N
);
5711 Index_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'I', N
);
5712 Index_Type
: constant Entity_Id
:= Etype
(First_Index
(Etype
(N
)));
5713 Size_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'I', N
);
5714 TmpE
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A', N
);
5716 Assoc
: Node_Id
:= First
(Component_Associations
(N
));
5722 Size_Expr_Code
: List_Id
;
5723 Insertion_Code
: List_Id
:= New_List
;
5726 Size_Expr_Code
:= New_List
(
5727 Make_Object_Declaration
(Loc
,
5728 Defining_Identifier
=> Size_Id
,
5729 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
5730 Expression
=> Make_Integer_Literal
(Loc
, 0)));
5732 -- First pass: execute the iterators to count the number of elements
5733 -- that will be generated.
5735 while Present
(Assoc
) loop
5736 Iter
:= Iterator_Specification
(Assoc
);
5737 Incr
:= Make_Assignment_Statement
(Loc
,
5738 Name
=> New_Occurrence_Of
(Size_Id
, Loc
),
5741 Left_Opnd
=> New_Occurrence_Of
(Size_Id
, Loc
),
5742 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
5744 One_Loop
:= Make_Implicit_Loop_Statement
(N
,
5746 Make_Iteration_Scheme
(Loc
,
5747 Iterator_Specification
=> New_Copy_Tree
(Iter
)),
5748 Statements
=> New_List
(Incr
));
5750 Append
(One_Loop
, Size_Expr_Code
);
5754 Insert_Actions
(N
, Size_Expr_Code
);
5756 -- Build a constrained subtype with the calculated length
5757 -- and declare the proper bounded aggregate object.
5758 -- The index type is some discrete type, so the bounds of the
5759 -- constructed array are computed as T'Val (T'Pos (ineger bound));
5762 Pos_Lo
: constant Node_Id
:=
5763 Make_Attribute_Reference
(Loc
,
5764 Prefix
=> New_Occurrence_Of
(Index_Type
, Loc
),
5765 Attribute_Name
=> Name_Pos
,
5766 Expressions
=> New_List
(
5767 Make_Attribute_Reference
(Loc
,
5768 Prefix
=> New_Occurrence_Of
(Index_Type
, Loc
),
5769 Attribute_Name
=> Name_First
)));
5771 Aggr_Lo
: constant Node_Id
:=
5772 Make_Attribute_Reference
(Loc
,
5773 Prefix
=> New_Occurrence_Of
(Index_Type
, Loc
),
5774 Attribute_Name
=> Name_Val
,
5775 Expressions
=> New_List
(New_Copy_Tree
(Pos_Lo
)));
5777 -- Hi = Index_type'Pos (Lo + Size -1).
5779 Pos_Hi
: constant Node_Id
:=
5781 Left_Opnd
=> New_Copy_Tree
(Pos_Lo
),
5783 Make_Op_Subtract
(Loc
,
5784 Left_Opnd
=> New_Occurrence_Of
(Size_Id
, Loc
),
5785 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
5787 -- Corresponding index value
5789 Aggr_Hi
: constant Node_Id
:=
5790 Make_Attribute_Reference
(Loc
,
5791 Prefix
=> New_Occurrence_Of
(Index_Type
, Loc
),
5792 Attribute_Name
=> Name_Val
,
5793 Expressions
=> New_List
(New_Copy_Tree
(Pos_Hi
)));
5795 SubE
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5796 SubD
: constant Node_Id
:=
5797 Make_Subtype_Declaration
(Loc
,
5798 Defining_Identifier
=> SubE
,
5799 Subtype_Indication
=>
5800 Make_Subtype_Indication
(Loc
,
5802 New_Occurrence_Of
(Etype
(Comp_Type
), Loc
),
5804 Make_Index_Or_Discriminant_Constraint
5807 New_List
(Make_Range
(Loc
, Aggr_Lo
, Aggr_Hi
)))));
5809 -- Create a temporary array of the above subtype which
5810 -- will be used to capture the aggregate assignments.
5812 TmpD
: constant Node_Id
:=
5813 Make_Object_Declaration
(Loc
,
5814 Defining_Identifier
=> TmpE
,
5815 Object_Definition
=> New_Occurrence_Of
(SubE
, Loc
));
5817 Insert_Actions
(N
, New_List
(SubD
, TmpD
));
5820 -- Second pass: use the iterators to generate the elements of the
5821 -- aggregate. Insertion index starts at Index_Type'First. We
5822 -- assume that the second evaluation of each iterator generates
5823 -- the same number of elements as the first pass, and consider
5824 -- that the execution is erroneous (even if the RM does not state
5825 -- this explicitly) if the number of elements generated differs
5826 -- between first and second pass.
5828 Assoc
:= First
(Component_Associations
(N
));
5830 -- Initialize insertion position to first array component.
5832 Insertion_Code
:= New_List
(
5833 Make_Object_Declaration
(Loc
,
5834 Defining_Identifier
=> Index_Id
,
5835 Object_Definition
=>
5836 New_Occurrence_Of
(Index_Type
, Loc
),
5838 Make_Attribute_Reference
(Loc
,
5839 Prefix
=> New_Occurrence_Of
(Index_Type
, Loc
),
5840 Attribute_Name
=> Name_First
)));
5842 while Present
(Assoc
) loop
5843 Iter
:= Iterator_Specification
(Assoc
);
5844 New_Comp
:= Make_Assignment_Statement
(Loc
,
5846 Make_Indexed_Component
(Loc
,
5847 Prefix
=> New_Occurrence_Of
(TmpE
, Loc
),
5849 New_List
(New_Occurrence_Of
(Index_Id
, Loc
))),
5850 Expression
=> Copy_Separate_Tree
(Expression
(Assoc
)));
5852 -- Advance index position for insertion.
5854 Incr
:= Make_Assignment_Statement
(Loc
,
5855 Name
=> New_Occurrence_Of
(Index_Id
, Loc
),
5857 Make_Attribute_Reference
(Loc
,
5859 New_Occurrence_Of
(Index_Type
, Loc
),
5860 Attribute_Name
=> Name_Succ
,
5862 New_List
(New_Occurrence_Of
(Index_Id
, Loc
))));
5864 -- Add guard to skip last increment when upper bound is reached.
5866 Incr
:= Make_If_Statement
(Loc
,
5869 Left_Opnd
=> New_Occurrence_Of
(Index_Id
, Loc
),
5871 Make_Attribute_Reference
(Loc
,
5872 Prefix
=> New_Occurrence_Of
(Index_Type
, Loc
),
5873 Attribute_Name
=> Name_Last
)),
5874 Then_Statements
=> New_List
(Incr
));
5876 One_Loop
:= Make_Implicit_Loop_Statement
(N
,
5878 Make_Iteration_Scheme
(Loc
,
5879 Iterator_Specification
=> Copy_Separate_Tree
(Iter
)),
5880 Statements
=> New_List
(New_Comp
, Incr
));
5882 Append
(One_Loop
, Insertion_Code
);
5886 Insert_Actions
(N
, Insertion_Code
);
5888 -- Depending on context this may not work for build-in-place
5891 Rewrite
(N
, New_Occurrence_Of
(TmpE
, Loc
));
5893 end Two_Pass_Aggregate_Expansion
;
5898 -- Holds the temporary aggregate value
5901 -- Holds the declaration of Tmp
5903 Aggr_Code
: List_Id
;
5904 Parent_Node
: Node_Id
;
5905 Parent_Kind
: Node_Kind
;
5907 -- Start of processing for Expand_Array_Aggregate
5910 -- Do not touch the special aggregates of attributes used for Asm calls
5912 if Is_RTE
(Ctyp
, RE_Asm_Input_Operand
)
5913 or else Is_RTE
(Ctyp
, RE_Asm_Output_Operand
)
5917 elsif Present
(Component_Associations
(N
))
5918 and then Nkind
(First
(Component_Associations
(N
))) =
5919 N_Iterated_Component_Association
5921 Present
(Iterator_Specification
(First
(Component_Associations
(N
))))
5923 Two_Pass_Aggregate_Expansion
(N
);
5926 -- Do not attempt expansion if error already detected. We may reach this
5927 -- point in spite of previous errors when compiling with -gnatq, to
5928 -- force all possible errors (this is the usual ACATS mode).
5930 elsif Error_Posted
(N
) then
5934 -- If the semantic analyzer has determined that aggregate N will raise
5935 -- Constraint_Error at run time, then the aggregate node has been
5936 -- replaced with an N_Raise_Constraint_Error node and we should
5939 pragma Assert
(not Raises_Constraint_Error
(N
));
5943 -- Check that the index range defined by aggregate bounds is
5944 -- compatible with corresponding index subtype.
5946 Index_Compatibility_Check
: declare
5947 Aggr_Index_Range
: Node_Id
:= First_Index
(Typ
);
5948 -- The current aggregate index range
5950 Index_Constraint
: Node_Id
:= First_Index
(Etype
(Typ
));
5951 -- The corresponding index constraint against which we have to
5952 -- check the above aggregate index range.
5955 Compute_Others_Present
(N
, 1);
5957 for J
in 1 .. Aggr_Dimension
loop
5958 -- There is no need to emit a check if an others choice is present
5959 -- for this array aggregate dimension since in this case one of
5960 -- N's subaggregates has taken its bounds from the context and
5961 -- these bounds must have been checked already. In addition all
5962 -- subaggregates corresponding to the same dimension must all have
5963 -- the same bounds (checked in (c) below).
5965 if not Range_Checks_Suppressed
(Etype
(Index_Constraint
))
5966 and then not Others_Present
(J
)
5968 -- We don't use Checks.Apply_Range_Check here because it emits
5969 -- a spurious check. Namely it checks that the range defined by
5970 -- the aggregate bounds is nonempty. But we know this already
5973 Check_Bounds
(Aggr_Index_Range
, Index_Constraint
);
5976 -- Save the low and high bounds of the aggregate index as well as
5977 -- the index type for later use in checks (b) and (c) below.
5980 (Aggr_Index_Range
, L
=> Aggr_Low
(J
), H
=> Aggr_High
(J
));
5982 Aggr_Index_Typ
(J
) := Etype
(Index_Constraint
);
5984 Next_Index
(Aggr_Index_Range
);
5985 Next_Index
(Index_Constraint
);
5987 end Index_Compatibility_Check
;
5991 -- If an others choice is present check that no aggregate index is
5992 -- outside the bounds of the index constraint.
5994 Others_Check
(N
, 1);
5998 -- For multidimensional arrays make sure that all subaggregates
5999 -- corresponding to the same dimension have the same bounds.
6001 if Aggr_Dimension
> 1 then
6002 Check_Same_Aggr_Bounds
(N
, 1);
6007 -- If we have a default component value, or simple initialization is
6008 -- required for the component type, then we replace <> in component
6009 -- associations by the required default value.
6012 Default_Val
: Node_Id
;
6016 if (Present
(Default_Aspect_Component_Value
(Typ
))
6017 or else Needs_Simple_Initialization
(Ctyp
))
6018 and then Present
(Component_Associations
(N
))
6020 Assoc
:= First
(Component_Associations
(N
));
6021 while Present
(Assoc
) loop
6022 if Nkind
(Assoc
) = N_Component_Association
6023 and then Box_Present
(Assoc
)
6025 Set_Box_Present
(Assoc
, False);
6027 if Present
(Default_Aspect_Component_Value
(Typ
)) then
6028 Default_Val
:= Default_Aspect_Component_Value
(Typ
);
6030 Default_Val
:= Get_Simple_Init_Val
(Ctyp
, N
);
6033 Set_Expression
(Assoc
, New_Copy_Tree
(Default_Val
));
6034 Analyze_And_Resolve
(Expression
(Assoc
), Ctyp
);
6044 -- Here we test for is packed array aggregate that we can handle at
6045 -- compile time. If so, return with transformation done. Note that we do
6046 -- this even if the aggregate is nested, because once we have done this
6047 -- processing, there is no more nested aggregate.
6049 if Packed_Array_Aggregate_Handled
(N
) then
6053 -- At this point we try to convert to positional form
6055 Convert_To_Positional
(N
);
6057 -- If the result is no longer an aggregate (e.g. it may be a string
6058 -- literal, or a temporary which has the needed value), then we are
6059 -- done, since there is no longer a nested aggregate.
6061 if Nkind
(N
) /= N_Aggregate
then
6064 -- We are also done if the result is an analyzed aggregate, indicating
6065 -- that Convert_To_Positional succeeded and reanalyzed the rewritten
6068 elsif Analyzed
(N
) and then Is_Rewrite_Substitution
(N
) then
6072 -- If all aggregate components are compile-time known and the aggregate
6073 -- has been flattened, nothing left to do. The same occurs if the
6074 -- aggregate is used to initialize the components of a statically
6075 -- allocated dispatch table.
6077 if Compile_Time_Known_Aggregate
(N
)
6078 or else Is_Static_Dispatch_Table_Aggregate
(N
)
6080 Set_Expansion_Delayed
(N
, False);
6084 -- Now see if back end processing is possible
6086 if Backend_Processing_Possible
(N
) then
6088 -- If the aggregate is static but the constraints are not, build
6089 -- a static subtype for the aggregate, so that Gigi can place it
6090 -- in static memory. Perform an unchecked_conversion to the non-
6091 -- static type imposed by the context.
6094 Itype
: constant Entity_Id
:= Etype
(N
);
6096 Needs_Type
: Boolean := False;
6099 Index
:= First_Index
(Itype
);
6100 while Present
(Index
) loop
6101 if not Is_OK_Static_Subtype
(Etype
(Index
)) then
6110 Build_Constrained_Type
(Positional
=> True);
6111 Rewrite
(N
, Unchecked_Convert_To
(Itype
, N
));
6121 -- Delay expansion for nested aggregates: it will be taken care of when
6122 -- the parent aggregate is expanded, excluding container aggregates as
6123 -- these are transformed into subprogram calls later.
6125 Parent_Node
:= Parent
(N
);
6126 Parent_Kind
:= Nkind
(Parent_Node
);
6128 if Parent_Kind
= N_Qualified_Expression
then
6129 Parent_Node
:= Parent
(Parent_Node
);
6130 Parent_Kind
:= Nkind
(Parent_Node
);
6133 if (Parent_Kind
= N_Component_Association
6134 and then not Is_Container_Aggregate
(Parent
(Parent_Node
)))
6135 or else (Parent_Kind
in N_Aggregate | N_Extension_Aggregate
6136 and then not Is_Container_Aggregate
(Parent_Node
))
6137 or else (Parent_Kind
= N_Object_Declaration
6138 and then (Needs_Finalization
(Typ
)
6139 or else Is_Special_Return_Object
6140 (Defining_Identifier
(Parent_Node
))))
6141 or else (Parent_Kind
= N_Assignment_Statement
6142 and then Inside_Init_Proc
)
6144 Set_Expansion_Delayed
(N
, not Static_Array_Aggregate
(N
));
6150 -- Check whether in-place aggregate expansion is possible
6152 -- For object declarations we build the aggregate in place, unless
6153 -- the array is bit-packed.
6155 -- For assignments we do the assignment in place if all the component
6156 -- associations have compile-time known values, or are default-
6157 -- initialized limited components, e.g. tasks. For other cases we
6158 -- create a temporary. A full analysis for safety of in-place assignment
6161 -- For allocators we assign to the designated object in place if the
6162 -- aggregate meets the same conditions as other in-place assignments.
6163 -- In this case the aggregate may not come from source but was created
6164 -- for default initialization, e.g. with Initialize_Scalars.
6166 if Requires_Transient_Scope
(Typ
) then
6167 Establish_Transient_Scope
(N
, Manage_Sec_Stack
=> False);
6170 -- An array of limited components is built in place
6172 if Is_Limited_Type
(Typ
) then
6173 Maybe_In_Place_OK
:= True;
6175 elsif Has_Default_Init_Comps
(N
) then
6176 Maybe_In_Place_OK
:= False;
6178 elsif Is_Bit_Packed_Array
(Typ
)
6179 or else Has_Controlled_Component
(Typ
)
6181 Maybe_In_Place_OK
:= False;
6183 elsif Parent_Kind
= N_Assignment_Statement
then
6184 Maybe_In_Place_OK
:=
6185 In_Place_Assign_OK
(N
, Get_Base_Object
(Name
(Parent_Node
)));
6187 elsif Parent_Kind
= N_Allocator
then
6188 Maybe_In_Place_OK
:= In_Place_Assign_OK
(N
);
6191 Maybe_In_Place_OK
:= False;
6194 -- If this is an array of tasks, it will be expanded into build-in-place
6195 -- assignments. Build an activation chain for the tasks now.
6197 if Has_Task
(Typ
) then
6198 Build_Activation_Chain_Entity
(N
);
6201 -- Perform in-place expansion of aggregate in an object declaration.
6202 -- Note: actions generated for the aggregate will be captured in an
6203 -- expression-with-actions statement so that they can be transferred
6204 -- to freeze actions later if there is an address clause for the
6205 -- object. (Note: we don't use a block statement because this would
6206 -- cause generated freeze nodes to be elaborated in the wrong scope).
6208 -- Arrays of limited components must be built in place. The code
6209 -- previously excluded controlled components but this is an old
6210 -- oversight: the rules in 7.6 (17) are clear.
6212 if Comes_From_Source
(Parent_Node
)
6213 and then Parent_Kind
= N_Object_Declaration
6214 and then Present
(Expression
(Parent_Node
))
6216 Must_Slide
(N
, Etype
(Defining_Identifier
(Parent_Node
)), Typ
)
6217 and then not Is_Bit_Packed_Array
(Typ
)
6219 In_Place_Assign_OK_For_Declaration
:= True;
6220 Tmp
:= Defining_Identifier
(Parent_Node
);
6221 Set_No_Initialization
(Parent_Node
);
6222 Set_Expression
(Parent_Node
, Empty
);
6224 -- Set kind and type of the entity, for use in the analysis
6225 -- of the subsequent assignments. If the nominal type is not
6226 -- constrained, build a subtype from the known bounds of the
6227 -- aggregate. If the declaration has a subtype mark, use it,
6228 -- otherwise use the itype of the aggregate.
6230 Mutate_Ekind
(Tmp
, E_Variable
);
6232 if not Is_Constrained
(Typ
) then
6233 Build_Constrained_Type
(Positional
=> False);
6235 elsif Is_Entity_Name
(Object_Definition
(Parent_Node
))
6236 and then Is_Constrained
(Entity
(Object_Definition
(Parent_Node
)))
6238 Set_Etype
(Tmp
, Entity
(Object_Definition
(Parent_Node
)));
6241 Set_Size_Known_At_Compile_Time
(Typ
, False);
6242 Set_Etype
(Tmp
, Typ
);
6245 elsif Maybe_In_Place_OK
and then Parent_Kind
= N_Allocator
then
6246 Set_Expansion_Delayed
(N
);
6249 -- Limited arrays in return statements are expanded when
6250 -- enclosing construct is expanded.
6252 elsif Maybe_In_Place_OK
6253 and then Parent_Kind
= N_Simple_Return_Statement
6255 Set_Expansion_Delayed
(N
);
6258 -- In the remaining cases the aggregate appears in the RHS of an
6259 -- assignment, which may be part of the expansion of an object
6260 -- declaration. If the aggregate is an actual in a call, itself
6261 -- possibly in a RHS, building it in the target is not possible.
6263 elsif Maybe_In_Place_OK
6264 and then Nkind
(Parent_Node
) not in N_Subprogram_Call
6265 and then Safe_Left_Hand_Side
(Name
(Parent_Node
))
6267 Tmp
:= Name
(Parent_Node
);
6269 if Etype
(Tmp
) /= Etype
(N
) then
6270 Apply_Length_Check
(N
, Etype
(Tmp
));
6272 if Nkind
(N
) = N_Raise_Constraint_Error
then
6274 -- Static error, nothing further to expand
6280 -- If a slice assignment has an aggregate with a single others_choice,
6281 -- the assignment can be done in place even if bounds are not static,
6282 -- by converting it into a loop over the discrete range of the slice.
6284 elsif Maybe_In_Place_OK
6285 and then Nkind
(Name
(Parent_Node
)) = N_Slice
6286 and then Is_Others_Aggregate
(N
)
6288 Tmp
:= Name
(Parent_Node
);
6290 -- Set type of aggregate to be type of lhs in assignment, in order
6291 -- to suppress redundant length checks.
6293 Set_Etype
(N
, Etype
(Tmp
));
6297 -- In-place aggregate expansion is not possible
6300 Maybe_In_Place_OK
:= False;
6301 Tmp
:= Make_Temporary
(Loc
, 'A', N
);
6303 Make_Object_Declaration
(Loc
,
6304 Defining_Identifier
=> Tmp
,
6305 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6306 Set_No_Initialization
(Tmp_Decl
, True);
6308 -- If we are within a loop, the temporary will be pushed on the
6309 -- stack at each iteration. If the aggregate is the expression
6310 -- for an allocator, it will be immediately copied to the heap
6311 -- and can be reclaimed at once. We create a transient scope
6312 -- around the aggregate for this purpose.
6314 if Ekind
(Current_Scope
) = E_Loop
6315 and then Parent_Kind
= N_Allocator
6317 Establish_Transient_Scope
(N
, Manage_Sec_Stack
=> False);
6319 -- If the parent is an assignment for which no controlled actions
6320 -- should take place, prevent the temporary from being finalized.
6322 elsif Parent_Kind
= N_Assignment_Statement
6323 and then No_Ctrl_Actions
(Parent_Node
)
6325 Mutate_Ekind
(Tmp
, E_Variable
);
6326 Set_Is_Ignored_Transient
(Tmp
);
6329 Insert_Action
(N
, Tmp_Decl
);
6332 -- Construct and insert the aggregate code. We can safely suppress index
6333 -- checks because this code is guaranteed not to raise CE on index
6334 -- checks. However we should *not* suppress all checks.
6340 if Nkind
(Tmp
) = N_Defining_Identifier
then
6341 Target
:= New_Occurrence_Of
(Tmp
, Loc
);
6344 if Has_Default_Init_Comps
(N
)
6345 and then not Maybe_In_Place_OK
6347 -- Ada 2005 (AI-287): This case has not been analyzed???
6349 raise Program_Error
;
6352 -- Name in assignment is explicit dereference
6354 Target
:= New_Copy
(Tmp
);
6357 -- If we are to generate an in-place assignment for a declaration or
6358 -- an assignment statement, and the assignment can be done directly
6359 -- by the back end, then do not expand further.
6361 -- ??? We can also do that if in-place expansion is not possible but
6362 -- then we could go into an infinite recursion.
6364 if (In_Place_Assign_OK_For_Declaration
or else Maybe_In_Place_OK
)
6365 and then not CodePeer_Mode
6366 and then not Modify_Tree_For_C
6367 and then not Possible_Bit_Aligned_Component
(Target
)
6368 and then not Is_Possibly_Unaligned_Slice
(Target
)
6369 and then Aggr_Assignment_OK_For_Backend
(N
)
6372 -- In the case of an assignment using an access with the
6373 -- Designated_Storage_Model aspect with a Copy_To procedure,
6374 -- insert a temporary and have the back end handle the assignment
6375 -- to it. Copy the result to the original target.
6377 if Parent_Kind
= N_Assignment_Statement
6378 and then Nkind
(Name
(Parent_Node
)) = N_Explicit_Dereference
6379 and then Has_Designated_Storage_Model_Aspect
6380 (Etype
(Prefix
(Name
(Parent_Node
))))
6381 and then Present
(Storage_Model_Copy_To
6382 (Storage_Model_Object
6383 (Etype
(Prefix
(Name
(Parent_Node
))))))
6385 Aggr_Code
:= Build_Assignment_With_Temporary
6386 (Target
, Typ
, New_Copy_Tree
(N
));
6389 if Maybe_In_Place_OK
then
6393 Aggr_Code
:= New_List
(
6394 Make_Assignment_Statement
(Loc
,
6396 Expression
=> New_Copy_Tree
(N
)));
6401 Build_Array_Aggr_Code
(N
,
6403 Index
=> First_Index
(Typ
),
6405 Scalar_Comp
=> Is_Scalar_Type
(Ctyp
));
6408 -- Save the last assignment statement associated with the aggregate
6409 -- when building a controlled object. This reference is utilized by
6410 -- the finalization machinery when marking an object as successfully
6413 if Needs_Finalization
(Typ
)
6414 and then Is_Entity_Name
(Target
)
6415 and then Present
(Entity
(Target
))
6416 and then Ekind
(Entity
(Target
)) in E_Constant | E_Variable
6418 Set_Last_Aggregate_Assignment
(Entity
(Target
), Last
(Aggr_Code
));
6422 -- If the aggregate is the expression in a declaration, the expanded
6423 -- code must be inserted after it. The defining entity might not come
6424 -- from source if this is part of an inlined body, but the declaration
6426 -- The test below looks very specialized and kludgy???
6428 if Comes_From_Source
(Tmp
)
6430 (Nkind
(Parent
(N
)) = N_Object_Declaration
6431 and then Comes_From_Source
(Parent
(N
))
6432 and then Tmp
= Defining_Entity
(Parent
(N
)))
6434 if Parent_Kind
/= N_Object_Declaration
or else Is_Frozen
(Tmp
) then
6435 Insert_Actions_After
(Parent_Node
, Aggr_Code
);
6438 Comp_Stmt
: constant Node_Id
:=
6439 Make_Compound_Statement
6440 (Sloc
(Parent_Node
), Actions
=> Aggr_Code
);
6442 Insert_Action_After
(Parent_Node
, Comp_Stmt
);
6443 Set_Initialization_Statements
(Tmp
, Comp_Stmt
);
6447 Insert_Actions
(N
, Aggr_Code
);
6450 -- If the aggregate has been assigned in place, remove the original
6453 if Parent_Kind
= N_Assignment_Statement
and then Maybe_In_Place_OK
then
6454 Rewrite
(Parent_Node
, Make_Null_Statement
(Loc
));
6456 -- Or else, if a temporary was created, replace the aggregate with it
6458 elsif Parent_Kind
/= N_Object_Declaration
6459 or else Tmp
/= Defining_Identifier
(Parent_Node
)
6461 Rewrite
(N
, New_Occurrence_Of
(Tmp
, Loc
));
6462 Analyze_And_Resolve
(N
, Typ
);
6464 end Expand_Array_Aggregate
;
6466 ------------------------
6467 -- Expand_N_Aggregate --
6468 ------------------------
6470 procedure Expand_N_Aggregate
(N
: Node_Id
) is
6471 T
: constant Entity_Id
:= Etype
(N
);
6473 -- Record aggregate case
6475 if Is_Record_Type
(T
)
6476 and then not Is_Private_Type
(T
)
6477 and then not Is_Homogeneous_Aggregate
(N
)
6479 Expand_Record_Aggregate
(N
);
6481 elsif Has_Aspect
(T
, Aspect_Aggregate
) then
6482 Expand_Container_Aggregate
(N
);
6484 -- Array aggregate case
6487 -- A special case, if we have a string subtype with bounds 1 .. N,
6488 -- where N is known at compile time, and the aggregate is of the
6489 -- form (others => 'x'), with a single choice and no expressions,
6490 -- and N is less than 80 (an arbitrary limit for now), then replace
6491 -- the aggregate by the equivalent string literal (but do not mark
6492 -- it as static since it is not).
6494 -- Note: this entire circuit is redundant with respect to code in
6495 -- Expand_Array_Aggregate that collapses others choices to positional
6496 -- form, but there are two problems with that circuit:
6498 -- a) It is limited to very small cases due to ill-understood
6499 -- interactions with bootstrapping. That limit is removed by
6500 -- use of the No_Implicit_Loops restriction.
6502 -- b) It incorrectly ends up with the resulting expressions being
6503 -- considered static when they are not. For example, the
6504 -- following test should fail:
6506 -- pragma Restrictions (No_Implicit_Loops);
6507 -- package NonSOthers4 is
6508 -- B : constant String (1 .. 6) := (others => 'A');
6509 -- DH : constant String (1 .. 8) := B & "BB";
6511 -- pragma Export (C, X, Link_Name => DH);
6514 -- But it succeeds (DH looks static to pragma Export)
6516 -- To be sorted out ???
6518 if Present
(Component_Associations
(N
)) then
6520 CA
: constant Node_Id
:= First
(Component_Associations
(N
));
6521 MX
: constant := 80;
6525 and then Nkind
(First
(Choice_List
(CA
))) = N_Others_Choice
6526 and then Nkind
(Expression
(CA
)) = N_Character_Literal
6527 and then No
(Expressions
(N
))
6530 X
: constant Node_Id
:= First_Index
(T
);
6531 EC
: constant Node_Id
:= Expression
(CA
);
6532 CV
: constant Uint
:= Char_Literal_Value
(EC
);
6533 CC
: constant Char_Code
:= UI_To_CC
(CV
);
6536 if Nkind
(X
) = N_Range
6537 and then Compile_Time_Known_Value
(Low_Bound
(X
))
6538 and then Expr_Value
(Low_Bound
(X
)) = 1
6539 and then Compile_Time_Known_Value
(High_Bound
(X
))
6542 Hi
: constant Uint
:= Expr_Value
(High_Bound
(X
));
6548 for J
in 1 .. UI_To_Int
(Hi
) loop
6549 Store_String_Char
(CC
);
6553 Make_String_Literal
(Sloc
(N
),
6554 Strval
=> End_String
));
6556 if In_Character_Range
(CC
) then
6558 elsif In_Wide_Character_Range
(CC
) then
6559 Set_Has_Wide_Character
(N
);
6561 Set_Has_Wide_Wide_Character
(N
);
6564 Analyze_And_Resolve
(N
, T
);
6565 Set_Is_Static_Expression
(N
, False);
6575 -- Not that special case, so normal expansion of array aggregate
6577 Expand_Array_Aggregate
(N
);
6581 when RE_Not_Available
=>
6583 end Expand_N_Aggregate
;
6585 --------------------------------
6586 -- Expand_Container_Aggregate --
6587 --------------------------------
6589 procedure Expand_Container_Aggregate
(N
: Node_Id
) is
6590 Loc
: constant Source_Ptr
:= Sloc
(N
);
6591 Typ
: constant Entity_Id
:= Etype
(N
);
6592 Asp
: constant Node_Id
:= Find_Value_Of_Aspect
(Typ
, Aspect_Aggregate
);
6594 Empty_Subp
: Node_Id
:= Empty
;
6595 Add_Named_Subp
: Node_Id
:= Empty
;
6596 Add_Unnamed_Subp
: Node_Id
:= Empty
;
6597 New_Indexed_Subp
: Node_Id
:= Empty
;
6598 Assign_Indexed_Subp
: Node_Id
:= Empty
;
6600 Aggr_Code
: constant List_Id
:= New_List
;
6601 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C', N
);
6606 Init_Stat
: Node_Id
;
6609 -- The following are used when the size of the aggregate is not
6610 -- static and requires a dynamic evaluation.
6612 Siz_Exp
: Node_Id
:= Empty
;
6613 Count_Type
: Entity_Id
;
6615 function Aggregate_Size
return Int
;
6616 -- Compute number of entries in aggregate, including choices
6617 -- that cover a range or subtype, as well as iterated constructs.
6618 -- Return -1 if the size is not known statically, in which case
6619 -- allocate a default size for the aggregate, or build an expression
6620 -- to estimate the size dynamically.
6622 function Build_Siz_Exp
(Comp
: Node_Id
) return Int
;
6623 -- When the aggregate contains a single Iterated_Component_Association
6624 -- or Element_Association with non-static bounds, build an expression
6625 -- to be used as the allocated size of the container. This may be an
6626 -- overestimate if a filter is present, but is a safe approximation.
6627 -- If bounds are dynamic the aggregate is created in two passes, and
6628 -- the first generates a loop for the sole purpose of computing the
6629 -- number of elements that will be generated on the second pass.
6631 procedure Expand_Iterated_Component
(Comp
: Node_Id
);
6632 -- Handle iterated_component_association and iterated_Element
6633 -- association by generating a loop over the specified range,
6634 -- given either by a loop parameter specification or an iterator
6637 --------------------
6638 -- Aggregate_Size --
6639 --------------------
6641 function Aggregate_Size
return Int
is
6647 procedure Add_Range_Size
;
6648 -- Compute number of components specified by a component association
6649 -- given by a range or subtype name.
6651 --------------------
6652 -- Add_Range_Size --
6653 --------------------
6655 procedure Add_Range_Size
is
6657 -- The bounds of the discrete range are integers or enumeration
6660 if Nkind
(Lo
) = N_Integer_Literal
then
6661 Siz
:= Siz
+ UI_To_Int
(Intval
(Hi
))
6662 - UI_To_Int
(Intval
(Lo
)) + 1;
6664 Siz
:= Siz
+ UI_To_Int
(Enumeration_Pos
(Hi
))
6665 - UI_To_Int
(Enumeration_Pos
(Lo
)) + 1;
6670 -- Aggregate is either all positional or all named
6672 Siz
:= List_Length
(Expressions
(N
));
6674 if Present
(Component_Associations
(N
)) then
6675 Comp
:= First
(Component_Associations
(N
));
6676 -- If there is a single component association it can be
6677 -- an iterated component with dynamic bounds or an element
6678 -- iterator over an iterable object. If it is an array
6679 -- we can use the attribute Length to get its size;
6680 -- for a predefined container the function Length plays
6681 -- the same role. There is no available mechanism for
6682 -- user-defined containers. For now we treat all of these
6685 if List_Length
(Component_Associations
(N
)) = 1
6686 and then Nkind
(Comp
) in N_Iterated_Component_Association |
6687 N_Iterated_Element_Association
6689 return Build_Siz_Exp
(Comp
);
6692 -- Otherwise all associations must specify static sizes.
6694 while Present
(Comp
) loop
6695 Choice
:= First
(Choice_List
(Comp
));
6697 while Present
(Choice
) loop
6700 if Nkind
(Choice
) = N_Range
then
6701 Lo
:= Low_Bound
(Choice
);
6702 Hi
:= High_Bound
(Choice
);
6705 elsif Is_Entity_Name
(Choice
)
6706 and then Is_Type
(Entity
(Choice
))
6708 Lo
:= Type_Low_Bound
(Entity
(Choice
));
6709 Hi
:= Type_High_Bound
(Entity
(Choice
));
6715 New_Copy_Tree
(Hi
)));
6718 -- Single choice (syntax excludes a subtype
6737 function Build_Siz_Exp
(Comp
: Node_Id
) return Int
is
6740 if Nkind
(Comp
) = N_Range
then
6741 Lo
:= Low_Bound
(Comp
);
6742 Hi
:= High_Bound
(Comp
);
6746 -- Compute static size when possible.
6748 if Is_Static_Expression
(Lo
)
6749 and then Is_Static_Expression
(Hi
)
6751 if Nkind
(Lo
) = N_Integer_Literal
then
6752 Siz
:= UI_To_Int
(Intval
(Hi
)) - UI_To_Int
(Intval
(Lo
)) + 1;
6754 Siz
:= UI_To_Int
(Enumeration_Pos
(Hi
))
6755 - UI_To_Int
(Enumeration_Pos
(Lo
)) + 1;
6761 Make_Op_Add
(Sloc
(Comp
),
6763 Make_Op_Subtract
(Sloc
(Comp
),
6764 Left_Opnd
=> New_Copy_Tree
(Hi
),
6765 Right_Opnd
=> New_Copy_Tree
(Lo
)),
6767 Make_Integer_Literal
(Loc
, 1));
6771 elsif Nkind
(Comp
) = N_Iterated_Component_Association
then
6772 return Build_Siz_Exp
(First
(Discrete_Choices
(Comp
)));
6774 elsif Nkind
(Comp
) = N_Iterated_Element_Association
then
6777 -- ??? Need to create code for a loop and add to generated code,
6778 -- as is done for array aggregates with iterated element
6779 -- associations, instead of using Append operations.
6786 -------------------------------
6787 -- Expand_Iterated_Component --
6788 -------------------------------
6790 procedure Expand_Iterated_Component
(Comp
: Node_Id
) is
6791 Expr
: constant Node_Id
:= Expression
(Comp
);
6793 Key_Expr
: Node_Id
:= Empty
;
6794 Loop_Id
: Entity_Id
;
6796 L_Iteration_Scheme
: Node_Id
;
6797 Loop_Stat
: Node_Id
;
6802 if Nkind
(Comp
) = N_Iterated_Element_Association
then
6803 Key_Expr
:= Key_Expression
(Comp
);
6805 -- We create a new entity as loop identifier in all cases,
6806 -- as is done for generated loops elsewhere, as the loop
6807 -- structure has been previously analyzed.
6809 if Present
(Iterator_Specification
(Comp
)) then
6811 -- Either an Iterator_Specification or a Loop_Parameter_
6812 -- Specification is present.
6814 L_Iteration_Scheme
:=
6815 Make_Iteration_Scheme
(Loc
,
6816 Iterator_Specification
=> Iterator_Specification
(Comp
));
6818 Make_Defining_Identifier
(Loc
,
6819 Chars
=> Chars
(Defining_Identifier
6820 (Iterator_Specification
(Comp
))));
6821 Set_Defining_Identifier
6822 (Iterator_Specification
(L_Iteration_Scheme
), Loop_Id
);
6825 L_Iteration_Scheme
:=
6826 Make_Iteration_Scheme
(Loc
,
6827 Loop_Parameter_Specification
=>
6828 Loop_Parameter_Specification
(Comp
));
6830 Make_Defining_Identifier
(Loc
,
6831 Chars
=> Chars
(Defining_Identifier
6832 (Loop_Parameter_Specification
(Comp
))));
6833 Set_Defining_Identifier
6834 (Loop_Parameter_Specification
6835 (L_Iteration_Scheme
), Loop_Id
);
6839 -- Iterated_Component_Association.
6841 if Present
(Iterator_Specification
(Comp
)) then
6843 Make_Defining_Identifier
(Loc
,
6844 Chars
=> Chars
(Defining_Identifier
6845 (Iterator_Specification
(Comp
))));
6846 L_Iteration_Scheme
:=
6847 Make_Iteration_Scheme
(Loc
,
6848 Iterator_Specification
=> Iterator_Specification
(Comp
));
6851 -- Loop_Parameter_Specification is parsed with a choice list.
6852 -- where the range is the first (and only) choice.
6855 Make_Defining_Identifier
(Loc
,
6856 Chars
=> Chars
(Defining_Identifier
(Comp
)));
6857 L_Range
:= Relocate_Node
(First
(Discrete_Choices
(Comp
)));
6859 L_Iteration_Scheme
:=
6860 Make_Iteration_Scheme
(Loc
,
6861 Loop_Parameter_Specification
=>
6862 Make_Loop_Parameter_Specification
(Loc
,
6863 Defining_Identifier
=> Loop_Id
,
6864 Discrete_Subtype_Definition
=> L_Range
));
6868 -- Build insertion statement. For a positional aggregate, only the
6869 -- expression is needed. For a named aggregate, the loop variable,
6870 -- whose type is that of the key, is an additional parameter for
6871 -- the insertion operation.
6872 -- If a Key_Expression is present, it serves as the additional
6873 -- parameter. Otherwise the key is given by the loop parameter
6876 if Present
(Add_Unnamed_Subp
)
6877 and then No
(Add_Named_Subp
)
6880 (Make_Procedure_Call_Statement
(Loc
,
6881 Name
=> New_Occurrence_Of
(Entity
(Add_Unnamed_Subp
), Loc
),
6882 Parameter_Associations
=>
6883 New_List
(New_Occurrence_Of
(Temp
, Loc
),
6884 New_Copy_Tree
(Expr
))));
6886 -- Named or indexed aggregate, for which a key is present,
6887 -- possibly with a specified key_expression.
6889 if Present
(Key_Expr
) then
6890 Params
:= New_List
(New_Occurrence_Of
(Temp
, Loc
),
6891 New_Copy_Tree
(Key_Expr
),
6892 New_Copy_Tree
(Expr
));
6894 Params
:= New_List
(New_Occurrence_Of
(Temp
, Loc
),
6895 New_Occurrence_Of
(Loop_Id
, Loc
),
6896 New_Copy_Tree
(Expr
));
6900 (Make_Procedure_Call_Statement
(Loc
,
6901 Name
=> New_Occurrence_Of
(Entity
(Add_Named_Subp
), Loc
),
6902 Parameter_Associations
=> Params
));
6905 Loop_Stat
:= Make_Implicit_Loop_Statement
6907 Identifier
=> Empty
,
6908 Iteration_Scheme
=> L_Iteration_Scheme
,
6909 Statements
=> Stats
);
6910 Append
(Loop_Stat
, Aggr_Code
);
6912 end Expand_Iterated_Component
;
6914 -- Start of processing for Expand_Container_Aggregate
6917 Parse_Aspect_Aggregate
(Asp
,
6918 Empty_Subp
, Add_Named_Subp
, Add_Unnamed_Subp
,
6919 New_Indexed_Subp
, Assign_Indexed_Subp
);
6921 -- The constructor for bounded containers is a function with
6922 -- a parameter that sets the size of the container. If the
6923 -- size cannot be determined statically we use a default value
6924 -- or a dynamic expression.
6926 Siz
:= Aggregate_Size
;
6928 ---------------------
6929 -- Empty function --
6930 ---------------------
6932 if Ekind
(Entity
(Empty_Subp
)) = E_Function
6933 and then Present
(First_Formal
(Entity
(Empty_Subp
)))
6935 Default
:= Default_Value
(First_Formal
(Entity
(Empty_Subp
)));
6937 -- If aggregate size is not static, we can use default value
6938 -- of formal parameter for allocation. We assume that this
6939 -- (implementation-dependent) value is static, even though
6940 -- the AI does not require it.
6942 -- Create declaration for size: a constant literal in the simple
6943 -- case, an expression if iterated component associations may be
6944 -- involved, the default otherwise.
6946 Count_Type
:= Etype
(First_Formal
(Entity
(Empty_Subp
)));
6948 if No
(Siz_Exp
) then
6949 Siz
:= UI_To_Int
(Intval
(Default
));
6950 Siz_Exp
:= Make_Integer_Literal
(Loc
, Siz
);
6953 Siz_Exp
:= Make_Type_Conversion
(Loc
,
6955 New_Occurrence_Of
(Count_Type
, Loc
),
6956 Expression
=> Siz_Exp
);
6960 Siz_Exp
:= Make_Integer_Literal
(Loc
, Siz
);
6963 Siz_Decl
:= Make_Object_Declaration
(Loc
,
6964 Defining_Identifier
=> Make_Temporary
(Loc
, 'S', N
),
6965 Object_Definition
=>
6966 New_Occurrence_Of
(Count_Type
, Loc
),
6967 Expression
=> Siz_Exp
);
6968 Append
(Siz_Decl
, Aggr_Code
);
6970 if Nkind
(Siz_Exp
) = N_Integer_Literal
then
6972 Make_Object_Declaration
(Loc
,
6973 Defining_Identifier
=> Temp
,
6974 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6975 Expression
=> Make_Function_Call
(Loc
,
6976 Name
=> New_Occurrence_Of
(Entity
(Empty_Subp
), Loc
),
6977 Parameter_Associations
=>
6980 (Defining_Identifier
(Siz_Decl
), Loc
))));
6984 Make_Object_Declaration
(Loc
,
6985 Defining_Identifier
=> Temp
,
6986 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6987 Expression
=> Make_Function_Call
(Loc
,
6989 New_Occurrence_Of
(Entity
(New_Indexed_Subp
), Loc
),
6990 Parameter_Associations
=>
6992 Make_Integer_Literal
(Loc
, 1),
6994 (Defining_Identifier
(Siz_Decl
), Loc
))));
6997 Append
(Init_Stat
, Aggr_Code
);
6999 -- Size is dynamic: Create declaration for object, and initialize
7000 -- with a call to the null container, or an assignment to it.
7004 Make_Object_Declaration
(Loc
,
7005 Defining_Identifier
=> Temp
,
7006 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
7008 Insert_Action
(N
, Decl
);
7010 -- The Empty entity is either a parameterless function, or
7013 if Ekind
(Entity
(Empty_Subp
)) = E_Function
then
7014 Init_Stat
:= Make_Assignment_Statement
(Loc
,
7015 Name
=> New_Occurrence_Of
(Temp
, Loc
),
7016 Expression
=> Make_Function_Call
(Loc
,
7017 Name
=> New_Occurrence_Of
(Entity
(Empty_Subp
), Loc
)));
7020 Init_Stat
:= Make_Assignment_Statement
(Loc
,
7021 Name
=> New_Occurrence_Of
(Temp
, Loc
),
7022 Expression
=> New_Occurrence_Of
(Entity
(Empty_Subp
), Loc
));
7025 Append
(Init_Stat
, Aggr_Code
);
7028 -- Report warning on infinite recursion if an empty container aggregate
7029 -- appears in the return statement of its Empty function.
7031 if Ekind
(Entity
(Empty_Subp
)) = E_Function
7032 and then Nkind
(Parent
(N
)) = N_Simple_Return_Statement
7033 and then Is_Empty_List
(Expressions
(N
))
7034 and then Is_Empty_List
(Component_Associations
(N
))
7035 and then Entity
(Empty_Subp
) = Current_Scope
7037 Error_Msg_Warn
:= SPARK_Mode
/= On
;
7039 ("!empty aggregate returned by the empty function of a container"
7040 & " aggregate<<<", Parent
(N
));
7042 ("\this will result in infinite recursion??", Parent
(N
));
7045 ---------------------------
7046 -- Positional aggregate --
7047 ---------------------------
7049 -- If the aggregate is positional the aspect must include
7050 -- an Add_Unnamed subprogram.
7052 if Present
(Add_Unnamed_Subp
) then
7053 if Present
(Expressions
(N
)) then
7055 Insert
: constant Entity_Id
:= Entity
(Add_Unnamed_Subp
);
7060 Comp
:= First
(Expressions
(N
));
7061 while Present
(Comp
) loop
7062 Stat
:= Make_Procedure_Call_Statement
(Loc
,
7063 Name
=> New_Occurrence_Of
(Insert
, Loc
),
7064 Parameter_Associations
=>
7065 New_List
(New_Occurrence_Of
(Temp
, Loc
),
7066 New_Copy_Tree
(Comp
)));
7067 Append
(Stat
, Aggr_Code
);
7073 -- Indexed aggregates are handled below. Unnamed aggregates
7074 -- such as sets may include iterated component associations.
7076 if No
(New_Indexed_Subp
) then
7077 Comp
:= First
(Component_Associations
(N
));
7078 while Present
(Comp
) loop
7079 if Nkind
(Comp
) = N_Iterated_Component_Association
then
7080 Expand_Iterated_Component
(Comp
);
7086 ---------------------
7087 -- Named_Aggregate --
7088 ---------------------
7090 elsif Present
(Add_Named_Subp
) then
7092 Insert
: constant Entity_Id
:= Entity
(Add_Named_Subp
);
7096 Comp
:= First
(Component_Associations
(N
));
7098 -- Each component association may contain several choices;
7099 -- generate an insertion statement for each.
7101 while Present
(Comp
) loop
7102 if Nkind
(Comp
) in N_Iterated_Component_Association
7103 | N_Iterated_Element_Association
7105 Expand_Iterated_Component
(Comp
);
7107 Key
:= First
(Choices
(Comp
));
7109 while Present
(Key
) loop
7110 Stat
:= Make_Procedure_Call_Statement
(Loc
,
7111 Name
=> New_Occurrence_Of
(Insert
, Loc
),
7112 Parameter_Associations
=>
7113 New_List
(New_Occurrence_Of
(Temp
, Loc
),
7114 New_Copy_Tree
(Key
),
7115 New_Copy_Tree
(Expression
(Comp
))));
7116 Append
(Stat
, Aggr_Code
);
7127 -----------------------
7128 -- Indexed_Aggregate --
7129 -----------------------
7131 -- For an indexed aggregate there must be an Assigned_Indexeed
7132 -- subprogram. Note that unlike array aggregates, a container
7133 -- aggregate must be fully positional or fully indexed. In the
7134 -- first case the expansion has already taken place.
7135 -- TBA: the keys for an indexed aggregate must provide a dense
7136 -- range with no repetitions.
7138 if Present
(Assign_Indexed_Subp
)
7139 and then Present
(Component_Associations
(N
))
7142 Insert
: constant Entity_Id
:= Entity
(Assign_Indexed_Subp
);
7143 Index_Type
: constant Entity_Id
:=
7144 Etype
(Next_Formal
(First_Formal
(Insert
)));
7146 function Expand_Range_Component
7148 Expr
: Node_Id
) return Node_Id
;
7149 -- Transform a component assoication with a range into an
7150 -- explicit loop. If the choice is a subtype name, it is
7151 -- rewritten as a range with the corresponding bounds, which
7152 -- are known to be static.
7160 -----------------------------
7161 -- Expand_Raange_Component --
7162 -----------------------------
7164 function Expand_Range_Component
7166 Expr
: Node_Id
) return Node_Id
7168 Loop_Id
: constant Entity_Id
:=
7169 Make_Temporary
(Loc
, 'T');
7171 L_Iteration_Scheme
: Node_Id
;
7175 L_Iteration_Scheme
:=
7176 Make_Iteration_Scheme
(Loc
,
7177 Loop_Parameter_Specification
=>
7178 Make_Loop_Parameter_Specification
(Loc
,
7179 Defining_Identifier
=> Loop_Id
,
7180 Discrete_Subtype_Definition
=> New_Copy_Tree
(Rng
)));
7183 (Make_Procedure_Call_Statement
(Loc
,
7185 New_Occurrence_Of
(Entity
(Assign_Indexed_Subp
), Loc
),
7186 Parameter_Associations
=>
7187 New_List
(New_Occurrence_Of
(Temp
, Loc
),
7188 New_Occurrence_Of
(Loop_Id
, Loc
),
7189 New_Copy_Tree
(Expr
))));
7191 return Make_Implicit_Loop_Statement
7193 Identifier
=> Empty
,
7194 Iteration_Scheme
=> L_Iteration_Scheme
,
7195 Statements
=> Stats
);
7196 end Expand_Range_Component
;
7201 -- Modify the call to the constructor to allocate the
7202 -- required size for the aggregwte : call the provided
7203 -- constructor rather than the Empty aggregate.
7205 Index
:= Make_Op_Add
(Loc
,
7206 Left_Opnd
=> New_Copy_Tree
(Type_Low_Bound
(Index_Type
)),
7207 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
- 1));
7209 Set_Expression
(Init_Stat
,
7210 Make_Function_Call
(Loc
,
7212 New_Occurrence_Of
(Entity
(New_Indexed_Subp
), Loc
),
7213 Parameter_Associations
=>
7215 New_Copy_Tree
(Type_Low_Bound
(Index_Type
)),
7219 if Present
(Expressions
(N
)) then
7220 Comp
:= First
(Expressions
(N
));
7222 while Present
(Comp
) loop
7224 -- Compute index position for successive components
7225 -- in the list of expressions, and use the indexed
7226 -- assignment procedure for each.
7228 Index
:= Make_Op_Add
(Loc
,
7229 Left_Opnd
=> Type_Low_Bound
(Index_Type
),
7230 Right_Opnd
=> Make_Integer_Literal
(Loc
, Pos
));
7232 Stat
:= Make_Procedure_Call_Statement
(Loc
,
7233 Name
=> New_Occurrence_Of
(Insert
, Loc
),
7234 Parameter_Associations
=>
7235 New_List
(New_Occurrence_Of
(Temp
, Loc
),
7237 New_Copy_Tree
(Comp
)));
7241 Append
(Stat
, Aggr_Code
);
7246 if Present
(Component_Associations
(N
)) then
7247 Comp
:= First
(Component_Associations
(N
));
7249 -- The choice may be a static value, or a range with
7252 while Present
(Comp
) loop
7253 if Nkind
(Comp
) = N_Component_Association
then
7254 Key
:= First
(Choices
(Comp
));
7255 while Present
(Key
) loop
7257 -- If the expression is a box, the corresponding
7258 -- component (s) is left uninitialized.
7260 if Box_Present
(Comp
) then
7263 elsif Nkind
(Key
) = N_Range
then
7265 -- Create loop for tne specified range,
7266 -- with copies of the expression.
7269 Expand_Range_Component
(Key
, Expression
(Comp
));
7272 Stat
:= Make_Procedure_Call_Statement
(Loc
,
7273 Name
=> New_Occurrence_Of
7274 (Entity
(Assign_Indexed_Subp
), Loc
),
7275 Parameter_Associations
=>
7276 New_List
(New_Occurrence_Of
(Temp
, Loc
),
7277 New_Copy_Tree
(Key
),
7278 New_Copy_Tree
(Expression
(Comp
))));
7281 Append
(Stat
, Aggr_Code
);
7288 -- Iterated component association. Discard
7289 -- positional insertion procedure.
7291 if No
(Iterator_Specification
(Comp
)) then
7292 Add_Named_Subp
:= Assign_Indexed_Subp
;
7293 Add_Unnamed_Subp
:= Empty
;
7296 Expand_Iterated_Component
(Comp
);
7305 Insert_Actions
(N
, Aggr_Code
);
7306 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
7307 Analyze_And_Resolve
(N
, Typ
);
7308 end Expand_Container_Aggregate
;
7310 ------------------------------
7311 -- Expand_N_Delta_Aggregate --
7312 ------------------------------
7314 procedure Expand_N_Delta_Aggregate
(N
: Node_Id
) is
7315 Loc
: constant Source_Ptr
:= Sloc
(N
);
7316 Typ
: constant Entity_Id
:= Etype
(Expression
(N
));
7321 Make_Object_Declaration
(Loc
,
7322 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
7323 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7324 Expression
=> New_Copy_Tree
(Expression
(N
)));
7326 if Is_Array_Type
(Etype
(N
)) then
7327 Expand_Delta_Array_Aggregate
(N
, New_List
(Decl
));
7329 Expand_Delta_Record_Aggregate
(N
, New_List
(Decl
));
7331 end Expand_N_Delta_Aggregate
;
7333 ----------------------------------
7334 -- Expand_Delta_Array_Aggregate --
7335 ----------------------------------
7337 procedure Expand_Delta_Array_Aggregate
(N
: Node_Id
; Deltas
: List_Id
) is
7338 Loc
: constant Source_Ptr
:= Sloc
(N
);
7339 Temp
: constant Entity_Id
:= Defining_Identifier
(First
(Deltas
));
7342 function Generate_Loop
(C
: Node_Id
) return Node_Id
;
7343 -- Generate a loop containing individual component assignments for
7344 -- choices that are ranges, subtype indications, subtype names, and
7345 -- iterated component associations.
7351 function Generate_Loop
(C
: Node_Id
) return Node_Id
is
7352 Sl
: constant Source_Ptr
:= Sloc
(C
);
7356 if Nkind
(Parent
(C
)) = N_Iterated_Component_Association
then
7358 Make_Defining_Identifier
(Loc
,
7359 Chars
=> (Chars
(Defining_Identifier
(Parent
(C
)))));
7361 Ix
:= Make_Temporary
(Sl
, 'I');
7365 Make_Implicit_Loop_Statement
(C
,
7367 Make_Iteration_Scheme
(Sl
,
7368 Loop_Parameter_Specification
=>
7369 Make_Loop_Parameter_Specification
(Sl
,
7370 Defining_Identifier
=> Ix
,
7371 Discrete_Subtype_Definition
=> New_Copy_Tree
(C
))),
7373 Statements
=> New_List
(
7374 Make_Assignment_Statement
(Sl
,
7376 Make_Indexed_Component
(Sl
,
7377 Prefix
=> New_Occurrence_Of
(Temp
, Sl
),
7378 Expressions
=> New_List
(New_Occurrence_Of
(Ix
, Sl
))),
7379 Expression
=> New_Copy_Tree
(Expression
(Assoc
)))),
7380 End_Label
=> Empty
);
7387 -- Start of processing for Expand_Delta_Array_Aggregate
7390 Assoc
:= First
(Component_Associations
(N
));
7391 while Present
(Assoc
) loop
7392 Choice
:= First
(Choice_List
(Assoc
));
7393 if Nkind
(Assoc
) = N_Iterated_Component_Association
then
7394 while Present
(Choice
) loop
7395 Append_To
(Deltas
, Generate_Loop
(Choice
));
7400 while Present
(Choice
) loop
7402 -- Choice can be given by a range, a subtype indication, a
7403 -- subtype name, a scalar value, or an entity.
7405 if Nkind
(Choice
) = N_Range
7406 or else (Is_Entity_Name
(Choice
)
7407 and then Is_Type
(Entity
(Choice
)))
7409 Append_To
(Deltas
, Generate_Loop
(Choice
));
7411 elsif Nkind
(Choice
) = N_Subtype_Indication
then
7413 Generate_Loop
(Range_Expression
(Constraint
(Choice
))));
7417 Make_Assignment_Statement
(Sloc
(Choice
),
7419 Make_Indexed_Component
(Sloc
(Choice
),
7420 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7421 Expressions
=> New_List
(New_Copy_Tree
(Choice
))),
7422 Expression
=> New_Copy_Tree
(Expression
(Assoc
))));
7432 Insert_Actions
(N
, Deltas
);
7433 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
7434 end Expand_Delta_Array_Aggregate
;
7436 -----------------------------------
7437 -- Expand_Delta_Record_Aggregate --
7438 -----------------------------------
7440 procedure Expand_Delta_Record_Aggregate
(N
: Node_Id
; Deltas
: List_Id
) is
7441 Loc
: constant Source_Ptr
:= Sloc
(N
);
7442 Temp
: constant Entity_Id
:= Defining_Identifier
(First
(Deltas
));
7447 Assoc
:= First
(Component_Associations
(N
));
7449 while Present
(Assoc
) loop
7450 Choice
:= First
(Choice_List
(Assoc
));
7451 while Present
(Choice
) loop
7453 Make_Assignment_Statement
(Sloc
(Choice
),
7455 Make_Selected_Component
(Sloc
(Choice
),
7456 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7457 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Choice
))),
7458 Expression
=> New_Copy_Tree
(Expression
(Assoc
))));
7465 Insert_Actions
(N
, Deltas
);
7466 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
7467 end Expand_Delta_Record_Aggregate
;
7469 ----------------------------------
7470 -- Expand_N_Extension_Aggregate --
7471 ----------------------------------
7473 -- If the ancestor part is an expression, add a component association for
7474 -- the parent field. If the type of the ancestor part is not the direct
7475 -- parent of the expected type, build recursively the needed ancestors.
7476 -- If the ancestor part is a subtype_mark, replace aggregate with a
7477 -- declaration for a temporary of the expected type, followed by
7478 -- individual assignments to the given components.
7480 procedure Expand_N_Extension_Aggregate
(N
: Node_Id
) is
7481 A
: constant Node_Id
:= Ancestor_Part
(N
);
7482 Loc
: constant Source_Ptr
:= Sloc
(N
);
7483 Typ
: constant Entity_Id
:= Etype
(N
);
7486 -- If the ancestor is a subtype mark, an init proc must be called
7487 -- on the resulting object which thus has to be materialized in
7490 if Is_Entity_Name
(A
) and then Is_Type
(Entity
(A
)) then
7491 Convert_To_Assignments
(N
, Typ
);
7493 -- The extension aggregate is transformed into a record aggregate
7494 -- of the following form (c1 and c2 are inherited components)
7496 -- (Exp with c3 => a, c4 => b)
7497 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c3 => a, c4 => b)
7502 if Tagged_Type_Expansion
then
7503 Expand_Record_Aggregate
(N
,
7506 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
),
7509 -- No tag is needed in the case of a VM
7512 Expand_Record_Aggregate
(N
, Parent_Expr
=> A
);
7517 when RE_Not_Available
=>
7519 end Expand_N_Extension_Aggregate
;
7521 -----------------------------
7522 -- Expand_Record_Aggregate --
7523 -----------------------------
7525 procedure Expand_Record_Aggregate
7527 Orig_Tag
: Node_Id
:= Empty
;
7528 Parent_Expr
: Node_Id
:= Empty
)
7530 Loc
: constant Source_Ptr
:= Sloc
(N
);
7531 Comps
: constant List_Id
:= Component_Associations
(N
);
7532 Typ
: constant Entity_Id
:= Etype
(N
);
7533 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
7535 Static_Components
: Boolean := True;
7536 -- Flag to indicate whether all components are compile-time known,
7537 -- and the aggregate can be constructed statically and handled by
7538 -- the back-end. Set to False by Component_OK_For_Backend.
7540 procedure Build_Back_End_Aggregate
;
7541 -- Build a proper aggregate to be handled by the back-end
7543 function Compile_Time_Known_Composite_Value
(N
: Node_Id
) return Boolean;
7544 -- Returns true if N is an expression of composite type which can be
7545 -- fully evaluated at compile time without raising constraint error.
7546 -- Such expressions can be passed as is to Gigi without any expansion.
7548 -- This returns true for N_Aggregate with Compile_Time_Known_Aggregate
7549 -- set and constants whose expression is such an aggregate, recursively.
7551 function Component_OK_For_Backend
return Boolean;
7552 -- Check for presence of a component which makes it impossible for the
7553 -- backend to process the aggregate, thus requiring the use of a series
7554 -- of assignment statements. Cases checked for are a nested aggregate
7555 -- needing Late_Expansion, the presence of a tagged component which may
7556 -- need tag adjustment, and a bit unaligned component reference.
7558 -- We also force expansion into assignments if a component is of a
7559 -- mutable type (including a private type with discriminants) because
7560 -- in that case the size of the component to be copied may be smaller
7561 -- than the side of the target, and there is no simple way for gigi
7562 -- to compute the size of the object to be copied.
7564 -- NOTE: This is part of the ongoing work to define precisely the
7565 -- interface between front-end and back-end handling of aggregates.
7566 -- In general it is desirable to pass aggregates as they are to gigi,
7567 -- in order to minimize elaboration code. This is one case where the
7568 -- semantics of Ada complicate the analysis and lead to anomalies in
7569 -- the gcc back-end if the aggregate is not expanded into assignments.
7571 -- NOTE: This sets the global Static_Components to False in most, but
7572 -- not all, cases when it returns False.
7574 function Has_Per_Object_Constraint
(L
: List_Id
) return Boolean;
7575 -- Return True if any element of L has Has_Per_Object_Constraint set.
7576 -- L should be the Choices component of an N_Component_Association.
7578 function Has_Visible_Private_Ancestor
(Id
: E
) return Boolean;
7579 -- If any ancestor of the current type is private, the aggregate
7580 -- cannot be built in place. We cannot rely on Has_Private_Ancestor,
7581 -- because it will not be set when type and its parent are in the
7582 -- same scope, and the parent component needs expansion.
7584 function Top_Level_Aggregate
(N
: Node_Id
) return Node_Id
;
7585 -- For nested aggregates return the ultimate enclosing aggregate; for
7586 -- non-nested aggregates return N.
7588 ------------------------------
7589 -- Build_Back_End_Aggregate --
7590 ------------------------------
7592 procedure Build_Back_End_Aggregate
is
7595 Tag_Value
: Node_Id
;
7598 if Nkind
(N
) = N_Aggregate
then
7600 -- If the aggregate is static and can be handled by the back-end,
7601 -- nothing left to do.
7603 if Static_Components
then
7604 Set_Compile_Time_Known_Aggregate
(N
);
7605 Set_Expansion_Delayed
(N
, False);
7609 -- If no discriminants, nothing special to do
7611 if not Has_Discriminants
(Typ
) then
7614 -- Case of discriminants present
7616 elsif Is_Derived_Type
(Typ
) then
7618 -- For untagged types, non-stored discriminants are replaced with
7619 -- stored discriminants, which are the ones that gigi uses to
7620 -- describe the type and its components.
7622 Generate_Aggregate_For_Derived_Type
: declare
7623 procedure Prepend_Stored_Values
(T
: Entity_Id
);
7624 -- Scan the list of stored discriminants of the type, and add
7625 -- their values to the aggregate being built.
7627 ---------------------------
7628 -- Prepend_Stored_Values --
7629 ---------------------------
7631 procedure Prepend_Stored_Values
(T
: Entity_Id
) is
7633 First_Comp
: Node_Id
:= Empty
;
7636 Discr
:= First_Stored_Discriminant
(T
);
7637 while Present
(Discr
) loop
7639 Make_Component_Association
(Loc
,
7640 Choices
=> New_List
(
7641 New_Occurrence_Of
(Discr
, Loc
)),
7644 (Get_Discriminant_Value
7647 Discriminant_Constraint
(Typ
))));
7649 if No
(First_Comp
) then
7650 Prepend_To
(Component_Associations
(N
), New_Comp
);
7652 Insert_After
(First_Comp
, New_Comp
);
7655 First_Comp
:= New_Comp
;
7656 Next_Stored_Discriminant
(Discr
);
7658 end Prepend_Stored_Values
;
7662 Constraints
: constant List_Id
:= New_List
;
7666 Num_Disc
: Nat
:= 0;
7667 Num_Stor
: Nat
:= 0;
7669 -- Start of processing for Generate_Aggregate_For_Derived_Type
7672 -- Remove the associations for the discriminant of derived type
7675 First_Comp
: Node_Id
;
7678 First_Comp
:= First
(Component_Associations
(N
));
7679 while Present
(First_Comp
) loop
7683 if Ekind
(Entity
(First
(Choices
(Comp
)))) =
7687 Num_Disc
:= Num_Disc
+ 1;
7692 -- Insert stored discriminant associations in the correct
7693 -- order. If there are more stored discriminants than new
7694 -- discriminants, there is at least one new discriminant that
7695 -- constrains more than one of the stored discriminants. In
7696 -- this case we need to construct a proper subtype of the
7697 -- parent type, in order to supply values to all the
7698 -- components. Otherwise there is one-one correspondence
7699 -- between the constraints and the stored discriminants.
7701 Discr
:= First_Stored_Discriminant
(Base_Type
(Typ
));
7702 while Present
(Discr
) loop
7703 Num_Stor
:= Num_Stor
+ 1;
7704 Next_Stored_Discriminant
(Discr
);
7707 -- Case of more stored discriminants than new discriminants
7709 if Num_Stor
> Num_Disc
then
7711 -- Create a proper subtype of the parent type, which is the
7712 -- proper implementation type for the aggregate, and convert
7713 -- it to the intended target type.
7715 Discr
:= First_Stored_Discriminant
(Base_Type
(Typ
));
7716 while Present
(Discr
) loop
7719 (Get_Discriminant_Value
7722 Discriminant_Constraint
(Typ
)));
7724 Append
(New_Comp
, Constraints
);
7725 Next_Stored_Discriminant
(Discr
);
7729 Make_Subtype_Declaration
(Loc
,
7730 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
7731 Subtype_Indication
=>
7732 Make_Subtype_Indication
(Loc
,
7734 New_Occurrence_Of
(Etype
(Base_Type
(Typ
)), Loc
),
7736 Make_Index_Or_Discriminant_Constraint
7737 (Loc
, Constraints
)));
7739 Insert_Action
(N
, Decl
);
7740 Prepend_Stored_Values
(Base_Type
(Typ
));
7742 Set_Etype
(N
, Defining_Identifier
(Decl
));
7745 Rewrite
(N
, Unchecked_Convert_To
(Typ
, N
));
7748 -- Case where we do not have fewer new discriminants than
7749 -- stored discriminants, so in this case we can simply use the
7750 -- stored discriminants of the subtype.
7753 Prepend_Stored_Values
(Typ
);
7755 end Generate_Aggregate_For_Derived_Type
;
7758 if Is_Tagged_Type
(Typ
) then
7760 -- In the tagged case, _parent and _tag component must be created
7762 -- Reset Null_Present unconditionally. Tagged records always have
7763 -- at least one field (the tag or the parent).
7765 Set_Null_Record_Present
(N
, False);
7767 -- When the current aggregate comes from the expansion of an
7768 -- extension aggregate, the parent expr is replaced by an
7769 -- aggregate formed by selected components of this expr.
7771 if Present
(Parent_Expr
) and then Is_Empty_List
(Comps
) then
7772 Comp
:= First_Component_Or_Discriminant
(Typ
);
7773 while Present
(Comp
) loop
7775 -- Skip all expander-generated components
7777 if not Comes_From_Source
(Original_Record_Component
(Comp
))
7783 Make_Selected_Component
(Loc
,
7785 Unchecked_Convert_To
(Typ
,
7786 Duplicate_Subexpr
(Parent_Expr
, True)),
7787 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
7790 Make_Component_Association
(Loc
,
7791 Choices
=> New_List
(
7792 New_Occurrence_Of
(Comp
, Loc
)),
7793 Expression
=> New_Comp
));
7795 Analyze_And_Resolve
(New_Comp
, Etype
(Comp
));
7798 Next_Component_Or_Discriminant
(Comp
);
7802 -- Compute the value for the Tag now, if the type is a root it
7803 -- will be included in the aggregate right away, otherwise it will
7804 -- be propagated to the parent aggregate.
7806 if Present
(Orig_Tag
) then
7807 Tag_Value
:= Orig_Tag
;
7809 elsif not Tagged_Type_Expansion
then
7815 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
7818 -- For a derived type, an aggregate for the parent is formed with
7819 -- all the inherited components.
7821 if Is_Derived_Type
(Typ
) then
7823 First_Comp
: Node_Id
;
7824 Parent_Comps
: List_Id
;
7825 Parent_Aggr
: Node_Id
;
7826 Parent_Name
: Node_Id
;
7829 First_Comp
:= First
(Component_Associations
(N
));
7830 Parent_Comps
:= New_List
;
7832 -- First skip the discriminants
7834 while Present
(First_Comp
)
7835 and then Ekind
(Entity
(First
(Choices
(First_Comp
))))
7841 -- Then remove the inherited component association from the
7842 -- aggregate and store them in the parent aggregate
7844 while Present
(First_Comp
)
7846 Scope
(Original_Record_Component
7847 (Entity
(First
(Choices
(First_Comp
))))) /=
7853 Append
(Comp
, Parent_Comps
);
7857 Make_Aggregate
(Loc
,
7858 Component_Associations
=> Parent_Comps
);
7859 Set_Etype
(Parent_Aggr
, Etype
(Base_Type
(Typ
)));
7861 -- Find the _parent component
7863 Comp
:= First_Component
(Typ
);
7864 while Chars
(Comp
) /= Name_uParent
loop
7865 Next_Component
(Comp
);
7868 Parent_Name
:= New_Occurrence_Of
(Comp
, Loc
);
7870 -- Insert the parent aggregate
7872 Prepend_To
(Component_Associations
(N
),
7873 Make_Component_Association
(Loc
,
7874 Choices
=> New_List
(Parent_Name
),
7875 Expression
=> Parent_Aggr
));
7877 -- Expand recursively the parent propagating the right Tag
7879 Expand_Record_Aggregate
7880 (Parent_Aggr
, Tag_Value
, Parent_Expr
);
7882 -- The ancestor part may be a nested aggregate that has
7883 -- delayed expansion: recheck now.
7885 if not Component_OK_For_Backend
then
7886 Convert_To_Assignments
(N
, Typ
);
7890 -- For a root type, the tag component is added (unless compiling
7891 -- for the VMs, where tags are implicit).
7893 elsif Tagged_Type_Expansion
then
7895 Tag_Name
: constant Node_Id
:=
7897 (First_Tag_Component
(Typ
), Loc
);
7898 Typ_Tag
: constant Entity_Id
:= RTE
(RE_Tag
);
7899 Conv_Node
: constant Node_Id
:=
7900 Unchecked_Convert_To
(Typ_Tag
, Tag_Value
);
7903 Set_Etype
(Conv_Node
, Typ_Tag
);
7904 Prepend_To
(Component_Associations
(N
),
7905 Make_Component_Association
(Loc
,
7906 Choices
=> New_List
(Tag_Name
),
7907 Expression
=> Conv_Node
));
7911 end Build_Back_End_Aggregate
;
7913 ----------------------------------------
7914 -- Compile_Time_Known_Composite_Value --
7915 ----------------------------------------
7917 function Compile_Time_Known_Composite_Value
7918 (N
: Node_Id
) return Boolean
7921 -- If we have an entity name, then see if it is the name of a
7922 -- constant and if so, test the corresponding constant value.
7924 if Is_Entity_Name
(N
) then
7926 E
: constant Entity_Id
:= Entity
(N
);
7929 if Ekind
(E
) /= E_Constant
then
7932 V
:= Constant_Value
(E
);
7934 and then Compile_Time_Known_Composite_Value
(V
);
7938 -- We have a value, see if it is compile time known
7941 if Nkind
(N
) = N_Aggregate
then
7942 return Compile_Time_Known_Aggregate
(N
);
7945 -- All other types of values are not known at compile time
7950 end Compile_Time_Known_Composite_Value
;
7952 ------------------------------
7953 -- Component_OK_For_Backend --
7954 ------------------------------
7956 function Component_OK_For_Backend
return Boolean is
7962 while Present
(C
) loop
7964 -- If the component has box initialization, expansion is needed
7965 -- and component is not ready for backend.
7967 if Box_Present
(C
) then
7971 Expr_Q
:= Unqualify
(Expression
(C
));
7973 -- Return False for array components whose bounds raise
7974 -- constraint error.
7977 Comp
: constant Entity_Id
:= First
(Choices
(C
));
7981 if Present
(Etype
(Comp
))
7982 and then Is_Array_Type
(Etype
(Comp
))
7984 Indx
:= First_Index
(Etype
(Comp
));
7985 while Present
(Indx
) loop
7986 if Nkind
(Type_Low_Bound
(Etype
(Indx
))) =
7987 N_Raise_Constraint_Error
7988 or else Nkind
(Type_High_Bound
(Etype
(Indx
))) =
7989 N_Raise_Constraint_Error
7999 -- Return False if the aggregate has any associations for tagged
8000 -- components that may require tag adjustment.
8002 -- These are cases where the source expression may have a tag that
8003 -- could differ from the component tag (e.g., can occur for type
8004 -- conversions and formal parameters). (Tag adjustment not needed
8005 -- if Tagged_Type_Expansion because object tags are implicit in
8008 if Is_Tagged_Type
(Etype
(Expr_Q
))
8010 (Nkind
(Expr_Q
) = N_Type_Conversion
8012 (Is_Entity_Name
(Expr_Q
)
8013 and then Is_Formal
(Entity
(Expr_Q
))))
8014 and then Tagged_Type_Expansion
8016 Static_Components
:= False;
8019 elsif Is_Delayed_Aggregate
(Expr_Q
) then
8020 Static_Components
:= False;
8023 elsif Nkind
(Expr_Q
) = N_Quantified_Expression
then
8024 Static_Components
:= False;
8027 elsif Possible_Bit_Aligned_Component
(Expr_Q
) then
8028 Static_Components
:= False;
8031 elsif Modify_Tree_For_C
8032 and then Nkind
(C
) = N_Component_Association
8033 and then Has_Per_Object_Constraint
(Choices
(C
))
8035 Static_Components
:= False;
8038 elsif Modify_Tree_For_C
8039 and then Nkind
(Expr_Q
) = N_Identifier
8040 and then Is_Array_Type
(Etype
(Expr_Q
))
8042 Static_Components
:= False;
8045 elsif Modify_Tree_For_C
8046 and then Nkind
(Expr_Q
) = N_Type_Conversion
8047 and then Is_Array_Type
(Etype
(Expr_Q
))
8049 Static_Components
:= False;
8053 if Is_Elementary_Type
(Etype
(Expr_Q
)) then
8054 if not Compile_Time_Known_Value
(Expr_Q
) then
8055 Static_Components
:= False;
8058 elsif not Compile_Time_Known_Composite_Value
(Expr_Q
) then
8059 Static_Components
:= False;
8061 if Is_Private_Type
(Etype
(Expr_Q
))
8062 and then Has_Discriminants
(Etype
(Expr_Q
))
8072 end Component_OK_For_Backend
;
8074 -------------------------------
8075 -- Has_Per_Object_Constraint --
8076 -------------------------------
8078 function Has_Per_Object_Constraint
(L
: List_Id
) return Boolean is
8079 N
: Node_Id
:= First
(L
);
8081 while Present
(N
) loop
8082 if Is_Entity_Name
(N
)
8083 and then Present
(Entity
(N
))
8084 and then Has_Per_Object_Constraint
(Entity
(N
))
8093 end Has_Per_Object_Constraint
;
8095 -----------------------------------
8096 -- Has_Visible_Private_Ancestor --
8097 -----------------------------------
8099 function Has_Visible_Private_Ancestor
(Id
: E
) return Boolean is
8100 R
: constant Entity_Id
:= Root_Type
(Id
);
8101 T1
: Entity_Id
:= Id
;
8105 if Is_Private_Type
(T1
) then
8115 end Has_Visible_Private_Ancestor
;
8117 -------------------------
8118 -- Top_Level_Aggregate --
8119 -------------------------
8121 function Top_Level_Aggregate
(N
: Node_Id
) return Node_Id
is
8126 while Present
(Parent
(Aggr
))
8127 and then Nkind
(Parent
(Aggr
)) in
8128 N_Aggregate | N_Component_Association
8130 Aggr
:= Parent
(Aggr
);
8134 end Top_Level_Aggregate
;
8138 Top_Level_Aggr
: constant Node_Id
:= Top_Level_Aggregate
(N
);
8140 -- Start of processing for Expand_Record_Aggregate
8143 -- No special management required for aggregates used to initialize
8144 -- statically allocated dispatch tables
8146 if Is_Static_Dispatch_Table_Aggregate
(N
) then
8149 -- Case pattern aggregates need to remain as aggregates
8151 elsif Is_Case_Choice_Pattern
(N
) then
8155 -- If the pragma Aggregate_Individually_Assign is set, always convert to
8158 if Aggregate_Individually_Assign
then
8159 Convert_To_Assignments
(N
, Typ
);
8161 -- Ada 2005 (AI-318-2): We need to convert to assignments if components
8162 -- are build-in-place function calls. The assignments will each turn
8163 -- into a build-in-place function call. If components are all static,
8164 -- we can pass the aggregate to the back end regardless of limitedness.
8166 -- Extension aggregates, aggregates in extended return statements, and
8167 -- aggregates for C++ imported types must be expanded.
8169 elsif Ada_Version
>= Ada_2005
and then Is_Limited_View
(Typ
) then
8170 if Nkind
(Parent
(N
)) not in
8171 N_Component_Association | N_Object_Declaration
8173 Convert_To_Assignments
(N
, Typ
);
8175 elsif Nkind
(N
) = N_Extension_Aggregate
8176 or else Convention
(Typ
) = Convention_CPP
8178 Convert_To_Assignments
(N
, Typ
);
8180 elsif not Size_Known_At_Compile_Time
(Typ
)
8181 or else not Component_OK_For_Backend
8182 or else not Static_Components
8184 Convert_To_Assignments
(N
, Typ
);
8186 -- In all other cases, build a proper aggregate to be handled by
8190 Build_Back_End_Aggregate
;
8193 -- Gigi doesn't properly handle temporaries of variable size so we
8194 -- generate it in the front-end
8196 elsif not Size_Known_At_Compile_Time
(Typ
)
8197 and then Tagged_Type_Expansion
8199 Convert_To_Assignments
(N
, Typ
);
8201 -- An aggregate used to initialize a controlled object must be turned
8202 -- into component assignments as the components themselves may require
8203 -- finalization actions such as adjustment.
8205 elsif Needs_Finalization
(Typ
) then
8206 Convert_To_Assignments
(N
, Typ
);
8208 -- Ada 2005 (AI-287): In case of default initialized components we
8209 -- convert the aggregate into assignments.
8211 elsif Has_Default_Init_Comps
(N
) then
8212 Convert_To_Assignments
(N
, Typ
);
8216 elsif not Component_OK_For_Backend
then
8217 Convert_To_Assignments
(N
, Typ
);
8219 -- If an ancestor is private, some components are not inherited and we
8220 -- cannot expand into a record aggregate.
8222 elsif Has_Visible_Private_Ancestor
(Typ
) then
8223 Convert_To_Assignments
(N
, Typ
);
8225 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
8226 -- is not able to handle the aggregate for Late_Request.
8228 elsif Is_Tagged_Type
(Typ
) and then Has_Discriminants
(Typ
) then
8229 Convert_To_Assignments
(N
, Typ
);
8231 -- If the tagged types covers interface types we need to initialize all
8232 -- hidden components containing pointers to secondary dispatch tables.
8234 elsif Is_Tagged_Type
(Typ
) and then Has_Interfaces
(Typ
) then
8235 Convert_To_Assignments
(N
, Typ
);
8237 -- If some components are mutable, the size of the aggregate component
8238 -- may be distinct from the default size of the type component, so
8239 -- we need to expand to insure that the back-end copies the proper
8240 -- size of the data. However, if the aggregate is the initial value of
8241 -- a constant, the target is immutable and might be built statically
8242 -- if components are appropriate.
8244 elsif Has_Mutable_Components
(Typ
)
8246 (Nkind
(Parent
(Top_Level_Aggr
)) /= N_Object_Declaration
8247 or else not Constant_Present
(Parent
(Top_Level_Aggr
))
8248 or else not Static_Components
)
8250 Convert_To_Assignments
(N
, Typ
);
8252 -- If the type involved has bit aligned components, then we are not sure
8253 -- that the back end can handle this case correctly.
8255 elsif Type_May_Have_Bit_Aligned_Components
(Typ
) then
8256 Convert_To_Assignments
(N
, Typ
);
8258 -- When generating C, only generate an aggregate when declaring objects
8259 -- since C does not support aggregates in e.g. assignment statements.
8261 elsif Modify_Tree_For_C
and then not Is_CCG_Supported_Aggregate
(N
) then
8262 Convert_To_Assignments
(N
, Typ
);
8264 -- In all other cases, build a proper aggregate to be handled by gigi
8267 Build_Back_End_Aggregate
;
8269 end Expand_Record_Aggregate
;
8271 ---------------------
8272 -- Get_Base_Object --
8273 ---------------------
8275 function Get_Base_Object
(N
: Node_Id
) return Entity_Id
is
8279 R
:= Get_Referenced_Object
(N
);
8281 while Nkind
(R
) in N_Indexed_Component | N_Selected_Component | N_Slice
8283 R
:= Get_Referenced_Object
(Prefix
(R
));
8286 if Is_Entity_Name
(R
) and then Is_Object
(Entity
(R
)) then
8291 end Get_Base_Object
;
8293 ----------------------------
8294 -- Has_Default_Init_Comps --
8295 ----------------------------
8297 function Has_Default_Init_Comps
(N
: Node_Id
) return Boolean is
8300 -- Component association and expression, respectively
8303 pragma Assert
(Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
);
8305 if Has_Self_Reference
(N
) then
8309 Assoc
:= First
(Component_Associations
(N
));
8310 while Present
(Assoc
) loop
8311 -- Each component association has either a box or an expression
8313 pragma Assert
(Box_Present
(Assoc
) xor Present
(Expression
(Assoc
)));
8315 -- Check if any direct component has default initialized components
8317 if Box_Present
(Assoc
) then
8320 -- Recursive call in case of aggregate expression
8323 Expr
:= Expression
(Assoc
);
8325 if Nkind
(Expr
) in N_Aggregate | N_Extension_Aggregate
8326 and then Has_Default_Init_Comps
(Expr
)
8336 end Has_Default_Init_Comps
;
8338 --------------------------
8339 -- Initialize_Component --
8340 --------------------------
8342 procedure Initialize_Component
8346 Init_Expr
: Node_Id
;
8349 Exceptions_OK
: constant Boolean :=
8350 not Restriction_Active
(No_Exception_Propagation
);
8351 Finalization_OK
: constant Boolean :=
8353 and then Needs_Finalization
(Comp_Typ
);
8354 Loc
: constant Source_Ptr
:= Sloc
(N
);
8356 Blk_Stmts
: List_Id
;
8357 Init_Stmt
: Node_Id
;
8360 pragma Assert
(Nkind
(Init_Expr
) in N_Subexpr
);
8362 -- Protect the initialization statements from aborts. Generate:
8366 if Finalization_OK
and Abort_Allowed
then
8367 if Exceptions_OK
then
8368 Blk_Stmts
:= New_List
;
8373 Append_To
(Blk_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
8375 -- Otherwise aborts are not allowed. All generated code is added
8376 -- directly to the input list.
8382 -- Initialize the component. Generate:
8384 -- Comp := Init_Expr;
8386 -- Note that the initialization expression is not duplicated because
8387 -- either only a single component may be initialized by it (record)
8388 -- or it has already been duplicated if need be (array).
8391 Make_OK_Assignment_Statement
(Loc
,
8392 Name
=> New_Copy_Tree
(Comp
),
8393 Expression
=> Relocate_Node
(Init_Expr
));
8395 Append_To
(Blk_Stmts
, Init_Stmt
);
8397 -- Arrange for the component to be adjusted if need be (the call will be
8398 -- generated by Make_Tag_Ctrl_Assignment). But, in the case of an array
8399 -- aggregate, controlled subaggregates are not considered because each
8400 -- of their individual elements will receive an adjustment of its own.
8403 and then not Is_Limited_View
(Comp_Typ
)
8405 (Is_Array_Type
(Etype
(N
))
8406 and then Is_Array_Type
(Comp_Typ
)
8407 and then Needs_Finalization
(Component_Type
(Comp_Typ
))
8408 and then Nkind
(Unqualify
(Init_Expr
)) = N_Aggregate
)
8410 Set_No_Finalize_Actions
(Init_Stmt
);
8412 -- Or else, only adjust the tag due to a possible view conversion
8415 Set_No_Ctrl_Actions
(Init_Stmt
);
8417 if Tagged_Type_Expansion
and then Is_Tagged_Type
(Comp_Typ
) then
8418 Append_To
(Blk_Stmts
,
8419 Make_Tag_Assignment_From_Type
8420 (Loc
, New_Copy_Tree
(Comp
), Underlying_Type
(Comp_Typ
)));
8424 -- Complete the protection of the initialization statements
8426 if Finalization_OK
and Abort_Allowed
then
8428 -- Wrap the initialization statements in a block to catch a
8429 -- potential exception. Generate:
8433 -- Comp := Init_Expr;
8434 -- Comp._tag := Full_TypP;
8435 -- [Deep_]Adjust (Comp);
8437 -- Abort_Undefer_Direct;
8440 if Exceptions_OK
then
8442 Build_Abort_Undefer_Block
(Loc
,
8446 -- Otherwise exceptions are not propagated. Generate:
8449 -- Comp := Init_Expr;
8450 -- Comp._tag := Full_TypP;
8451 -- [Deep_]Adjust (Comp);
8455 Append_To
(Blk_Stmts
,
8456 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
8459 end Initialize_Component
;
8461 ----------------------------------------
8462 -- Is_Build_In_Place_Aggregate_Return --
8463 ----------------------------------------
8465 function Is_Build_In_Place_Aggregate_Return
(N
: Node_Id
) return Boolean is
8466 P
: Node_Id
:= Parent
(N
);
8469 while Nkind
(P
) in N_Case_Expression
8470 | N_Case_Expression_Alternative
8472 | N_Qualified_Expression
8477 if Nkind
(P
) = N_Simple_Return_Statement
then
8480 elsif Nkind
(Parent
(P
)) = N_Extended_Return_Statement
then
8488 Is_Build_In_Place_Function
8489 (Return_Applies_To
(Return_Statement_Entity
(P
)));
8490 end Is_Build_In_Place_Aggregate_Return
;
8492 --------------------------
8493 -- Is_Delayed_Aggregate --
8494 --------------------------
8496 function Is_Delayed_Aggregate
(N
: Node_Id
) return Boolean is
8497 Unqual_N
: constant Node_Id
:= Unqualify
(N
);
8500 return Nkind
(Unqual_N
) in N_Aggregate | N_Extension_Aggregate
8501 and then Expansion_Delayed
(Unqual_N
);
8502 end Is_Delayed_Aggregate
;
8504 --------------------------------
8505 -- Is_CCG_Supported_Aggregate --
8506 --------------------------------
8508 function Is_CCG_Supported_Aggregate
8509 (N
: Node_Id
) return Boolean
8511 P
: Node_Id
:= Parent
(N
);
8514 -- Aggregates are not supported for nonstandard rep clauses, since they
8515 -- may lead to extra padding fields in CCG.
8517 if Is_Record_Type
(Etype
(N
))
8518 and then Has_Non_Standard_Rep
(Etype
(N
))
8523 while Present
(P
) and then Nkind
(P
) = N_Aggregate
loop
8527 -- Check cases where aggregates are supported by the CCG backend
8529 if Nkind
(P
) = N_Object_Declaration
then
8531 P_Typ
: constant Entity_Id
:= Etype
(Defining_Identifier
(P
));
8534 if Is_Record_Type
(P_Typ
) then
8537 return Compile_Time_Known_Bounds
(P_Typ
);
8541 elsif Nkind
(P
) = N_Qualified_Expression
then
8542 if Nkind
(Parent
(P
)) = N_Object_Declaration
then
8544 P_Typ
: constant Entity_Id
:=
8545 Etype
(Defining_Identifier
(Parent
(P
)));
8547 if Is_Record_Type
(P_Typ
) then
8550 return Compile_Time_Known_Bounds
(P_Typ
);
8554 elsif Nkind
(Parent
(P
)) = N_Allocator
then
8560 end Is_CCG_Supported_Aggregate
;
8562 ----------------------------------------
8563 -- Is_Static_Dispatch_Table_Aggregate --
8564 ----------------------------------------
8566 function Is_Static_Dispatch_Table_Aggregate
(N
: Node_Id
) return Boolean is
8567 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
8570 return Building_Static_Dispatch_Tables
8571 and then Tagged_Type_Expansion
8573 -- Avoid circularity when rebuilding the compiler
8575 and then not Is_RTU
(Cunit_Entity
(Get_Source_Unit
(N
)), Ada_Tags
)
8576 and then (Is_RTE
(Typ
, RE_Dispatch_Table_Wrapper
)
8578 Is_RTE
(Typ
, RE_Address_Array
)
8580 Is_RTE
(Typ
, RE_Type_Specific_Data
)
8582 Is_RTE
(Typ
, RE_Tag_Table
)
8584 Is_RTE
(Typ
, RE_Object_Specific_Data
)
8586 Is_RTE
(Typ
, RE_Interface_Data
)
8588 Is_RTE
(Typ
, RE_Interfaces_Array
)
8590 Is_RTE
(Typ
, RE_Interface_Data_Element
));
8591 end Is_Static_Dispatch_Table_Aggregate
;
8593 -----------------------------
8594 -- Is_Two_Dim_Packed_Array --
8595 -----------------------------
8597 function Is_Two_Dim_Packed_Array
(Typ
: Entity_Id
) return Boolean is
8598 C
: constant Uint
:= Component_Size
(Typ
);
8601 return Number_Dimensions
(Typ
) = 2
8602 and then Is_Bit_Packed_Array
(Typ
)
8603 and then Is_Scalar_Type
(Component_Type
(Typ
))
8604 and then C
in Uint_1 | Uint_2 | Uint_4
; -- False if No_Uint
8605 end Is_Two_Dim_Packed_Array
;
8607 --------------------
8608 -- Late_Expansion --
8609 --------------------
8611 function Late_Expansion
8614 Target
: Node_Id
) return List_Id
8616 Aggr_Code
: List_Id
;
8620 if Is_Array_Type
(Typ
) then
8621 -- If the assignment can be done directly by the back end, then
8622 -- reset Set_Expansion_Delayed and do not expand further.
8624 if not CodePeer_Mode
8625 and then not Modify_Tree_For_C
8626 and then not Possible_Bit_Aligned_Component
(Target
)
8627 and then not Is_Possibly_Unaligned_Slice
(Target
)
8628 and then Aggr_Assignment_OK_For_Backend
(N
)
8630 New_Aggr
:= New_Copy_Tree
(N
);
8631 Set_Expansion_Delayed
(New_Aggr
, False);
8635 Make_OK_Assignment_Statement
(Sloc
(New_Aggr
),
8637 Expression
=> New_Aggr
));
8639 -- Or else, generate component assignments to it
8643 Build_Array_Aggr_Code
8645 Ctype
=> Component_Type
(Typ
),
8646 Index
=> First_Index
(Typ
),
8648 Scalar_Comp
=> Is_Scalar_Type
(Component_Type
(Typ
)),
8649 Indexes
=> No_List
);
8652 -- Directly or indirectly (e.g. access protected procedure) a record
8655 Aggr_Code
:= Build_Record_Aggr_Code
(N
, Typ
, Target
);
8658 -- Save the last assignment statement associated with the aggregate
8659 -- when building a controlled object. This reference is utilized by
8660 -- the finalization machinery when marking an object as successfully
8663 if Needs_Finalization
(Typ
)
8664 and then Is_Entity_Name
(Target
)
8665 and then Present
(Entity
(Target
))
8666 and then Ekind
(Entity
(Target
)) in E_Constant | E_Variable
8668 Set_Last_Aggregate_Assignment
(Entity
(Target
), Last
(Aggr_Code
));
8674 ----------------------------------
8675 -- Make_OK_Assignment_Statement --
8676 ----------------------------------
8678 function Make_OK_Assignment_Statement
8681 Expression
: Node_Id
) return Node_Id
8684 Set_Assignment_OK
(Name
);
8685 return Make_Assignment_Statement
(Sloc
, Name
, Expression
);
8686 end Make_OK_Assignment_Statement
;
8688 ------------------------
8689 -- Max_Aggregate_Size --
8690 ------------------------
8692 function Max_Aggregate_Size
8694 Default_Size
: Nat
:= 5000) return Nat
8696 function Use_Small_Size
(N
: Node_Id
) return Boolean;
8697 -- True if we should return a very small size, which means large
8698 -- aggregates will be implemented as a loop when possible (potentially
8699 -- transformed to memset calls).
8701 function Aggr_Context
(N
: Node_Id
) return Node_Id
;
8702 -- Return the context in which the aggregate appears, not counting
8703 -- qualified expressions and similar.
8709 function Aggr_Context
(N
: Node_Id
) return Node_Id
is
8710 Result
: Node_Id
:= Parent
(N
);
8712 if Nkind
(Result
) in N_Qualified_Expression
8714 | N_Unchecked_Type_Conversion
8717 | N_Component_Association
8720 Result
:= Aggr_Context
(Result
);
8726 --------------------
8727 -- Use_Small_Size --
8728 --------------------
8730 function Use_Small_Size
(N
: Node_Id
) return Boolean is
8731 C
: constant Node_Id
:= Aggr_Context
(N
);
8732 -- The decision depends on the context in which the aggregate occurs,
8733 -- and for variable declarations, whether we are nested inside a
8737 -- True for assignment statements and similar
8739 when N_Assignment_Statement
8740 | N_Simple_Return_Statement
8742 | N_Attribute_Reference
8746 -- True for nested variable declarations. False for library level
8747 -- variables, and for constants (whether or not nested).
8749 when N_Object_Declaration
=>
8750 return not Constant_Present
(C
)
8751 and then Is_Subprogram
(Current_Scope
);
8753 -- False for all other contexts
8762 Typ
: constant Entity_Id
:= Etype
(N
);
8764 -- Start of processing for Max_Aggregate_Size
8767 -- We use a small limit in CodePeer mode where we favor loops instead of
8768 -- thousands of single assignments (from large aggregates).
8770 -- We also increase the limit to 2**24 (about 16 million) if
8771 -- Restrictions (No_Elaboration_Code) or Restrictions
8772 -- (No_Implicit_Loops) is specified, since in either case we are at risk
8773 -- of declaring the program illegal because of this limit. We also
8774 -- increase the limit when Static_Elaboration_Desired, given that this
8775 -- means that objects are intended to be placed in data memory.
8777 -- Same if the aggregate is for a packed two-dimensional array, because
8778 -- if components are static it is much more efficient to construct a
8779 -- one-dimensional equivalent array with static components.
8781 if CodePeer_Mode
then
8783 elsif Restriction_Active
(No_Elaboration_Code
)
8784 or else Restriction_Active
(No_Implicit_Loops
)
8785 or else Is_Two_Dim_Packed_Array
(Typ
)
8786 or else (Ekind
(Current_Scope
) = E_Package
8787 and then Static_Elaboration_Desired
(Current_Scope
))
8790 elsif Use_Small_Size
(N
) then
8794 return Default_Size
;
8795 end Max_Aggregate_Size
;
8797 -----------------------
8798 -- Number_Of_Choices --
8799 -----------------------
8801 function Number_Of_Choices
(N
: Node_Id
) return Nat
is
8805 Nb_Choices
: Nat
:= 0;
8808 if Present
(Expressions
(N
)) then
8812 Assoc
:= First
(Component_Associations
(N
));
8813 while Present
(Assoc
) loop
8814 Choice
:= First
(Choice_List
(Assoc
));
8815 while Present
(Choice
) loop
8816 if Nkind
(Choice
) /= N_Others_Choice
then
8817 Nb_Choices
:= Nb_Choices
+ 1;
8827 end Number_Of_Choices
;
8829 ------------------------------------
8830 -- Packed_Array_Aggregate_Handled --
8831 ------------------------------------
8833 -- The current version of this procedure will handle at compile time
8834 -- any array aggregate that meets these conditions:
8836 -- One and two dimensional, bit packed
8837 -- Underlying packed type is modular type
8838 -- Bounds are within 32-bit Int range
8839 -- All bounds and values are static
8841 -- Note: for now, in the 2-D case, we only handle component sizes of
8842 -- 1, 2, 4 (cases where an integral number of elements occupies a byte).
8844 function Packed_Array_Aggregate_Handled
(N
: Node_Id
) return Boolean is
8845 Loc
: constant Source_Ptr
:= Sloc
(N
);
8846 Typ
: constant Entity_Id
:= Etype
(N
);
8847 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
8849 Not_Handled
: exception;
8850 -- Exception raised if this aggregate cannot be handled
8853 -- Handle one- or two dimensional bit packed array
8855 if not Is_Bit_Packed_Array
(Typ
)
8856 or else Number_Dimensions
(Typ
) > 2
8861 -- If two-dimensional, check whether it can be folded, and transformed
8862 -- into a one-dimensional aggregate for the Packed_Array_Impl_Type of
8863 -- the original type.
8865 if Number_Dimensions
(Typ
) = 2 then
8866 return Two_Dim_Packed_Array_Handled
(N
);
8869 if not Is_Modular_Integer_Type
(Packed_Array_Impl_Type
(Typ
)) then
8873 if not Is_Scalar_Type
(Ctyp
) then
8878 Csiz
: constant Nat
:= UI_To_Int
(Component_Size
(Typ
));
8880 function Get_Component_Val
(N
: Node_Id
) return Uint
;
8881 -- Given a expression value N of the component type Ctyp, returns a
8882 -- value of Csiz (component size) bits representing this value. If
8883 -- the value is nonstatic or any other reason exists why the value
8884 -- cannot be returned, then Not_Handled is raised.
8886 -----------------------
8887 -- Get_Component_Val --
8888 -----------------------
8890 function Get_Component_Val
(N
: Node_Id
) return Uint
is
8894 -- We have to analyze the expression here before doing any further
8895 -- processing here. The analysis of such expressions is deferred
8896 -- till expansion to prevent some problems of premature analysis.
8898 Analyze_And_Resolve
(N
, Ctyp
);
8900 -- Must have a compile time value. String literals have to be
8901 -- converted into temporaries as well, because they cannot easily
8902 -- be converted into their bit representation.
8904 if not Compile_Time_Known_Value
(N
)
8905 or else Nkind
(N
) = N_String_Literal
8910 Val
:= Expr_Rep_Value
(N
);
8912 -- Adjust for bias, and strip proper number of bits
8914 if Has_Biased_Representation
(Ctyp
) then
8915 Val
:= Val
- Expr_Value
(Type_Low_Bound
(Ctyp
));
8918 return Val
mod Uint_2
** Csiz
;
8919 end Get_Component_Val
;
8921 Bounds
: constant Range_Nodes
:= Get_Index_Bounds
(First_Index
(Typ
));
8923 -- Here we know we have a one dimensional bit packed array
8926 -- Cannot do anything if bounds are dynamic
8928 if not (Compile_Time_Known_Value
(Bounds
.First
)
8930 Compile_Time_Known_Value
(Bounds
.Last
))
8936 Bounds_Vals
: Range_Values
;
8937 -- Compile-time known values of bounds
8939 -- Or are silly out of range of int bounds
8941 Bounds_Vals
.First
:= Expr_Value
(Bounds
.First
);
8942 Bounds_Vals
.Last
:= Expr_Value
(Bounds
.Last
);
8944 if not UI_Is_In_Int_Range
(Bounds_Vals
.First
)
8946 not UI_Is_In_Int_Range
(Bounds_Vals
.Last
)
8951 -- At this stage we have a suitable aggregate for handling at
8952 -- compile time. The only remaining checks are that the values of
8953 -- expressions in the aggregate are compile-time known (checks are
8954 -- performed by Get_Component_Val), and that any subtypes or
8955 -- ranges are statically known.
8957 -- If the aggregate is not fully positional at this stage, then
8958 -- convert it to positional form. Either this will fail, in which
8959 -- case we can do nothing, or it will succeed, in which case we
8960 -- have succeeded in handling the aggregate and transforming it
8961 -- into a modular value, or it will stay an aggregate, in which
8962 -- case we have failed to create a packed value for it.
8964 if Present
(Component_Associations
(N
)) then
8965 Convert_To_Positional
(N
, Handle_Bit_Packed
=> True);
8966 return Nkind
(N
) /= N_Aggregate
;
8969 -- Otherwise we are all positional, so convert to proper value
8972 Len
: constant Nat
:=
8973 Int
'Max (0, UI_To_Int
(Bounds_Vals
.Last
) -
8974 UI_To_Int
(Bounds_Vals
.First
) + 1);
8975 -- The length of the array (number of elements)
8977 Aggregate_Val
: Uint
;
8978 -- Value of aggregate. The value is set in the low order bits
8979 -- of this value. For the little-endian case, the values are
8980 -- stored from low-order to high-order and for the big-endian
8981 -- case the values are stored from high order to low order.
8982 -- Note that gigi will take care of the conversions to left
8983 -- justify the value in the big endian case (because of left
8984 -- justified modular type processing), so we do not have to
8985 -- worry about that here.
8988 -- Integer literal for resulting constructed value
8991 -- Shift count from low order for next value
8994 -- Shift increment for loop
8997 -- Next expression from positional parameters of aggregate
8999 Left_Justified
: Boolean;
9000 -- Set True if we are filling the high order bits of the target
9001 -- value (i.e. the value is left justified).
9004 -- For little endian, we fill up the low order bits of the
9005 -- target value. For big endian we fill up the high order bits
9006 -- of the target value (which is a left justified modular
9009 Left_Justified
:= Bytes_Big_Endian
;
9011 -- Switch justification if using -gnatd8
9013 if Debug_Flag_8
then
9014 Left_Justified
:= not Left_Justified
;
9017 -- Switch justfification if reverse storage order
9019 if Reverse_Storage_Order
(Base_Type
(Typ
)) then
9020 Left_Justified
:= not Left_Justified
;
9023 if Left_Justified
then
9024 Shift
:= Csiz
* (Len
- 1);
9031 -- Loop to set the values
9034 Aggregate_Val
:= Uint_0
;
9036 Expr
:= First
(Expressions
(N
));
9037 Aggregate_Val
:= Get_Component_Val
(Expr
) * Uint_2
** Shift
;
9039 for J
in 2 .. Len
loop
9040 Shift
:= Shift
+ Incr
;
9044 Get_Component_Val
(Expr
) * Uint_2
** Shift
;
9048 -- Now we can rewrite with the proper value
9050 Lit
:= Make_Integer_Literal
(Loc
, Intval
=> Aggregate_Val
);
9051 Set_Print_In_Hex
(Lit
);
9053 -- Construct the expression using this literal. Note that it
9054 -- is important to qualify the literal with its proper modular
9055 -- type since universal integer does not have the required
9056 -- range and also this is a left justified modular type,
9057 -- which is important in the big-endian case.
9060 Unchecked_Convert_To
(Typ
,
9061 Make_Qualified_Expression
(Loc
,
9063 New_Occurrence_Of
(Packed_Array_Impl_Type
(Typ
), Loc
),
9064 Expression
=> Lit
)));
9066 Analyze_And_Resolve
(N
, Typ
);
9075 end Packed_Array_Aggregate_Handled
;
9077 ----------------------------
9078 -- Has_Mutable_Components --
9079 ----------------------------
9081 function Has_Mutable_Components
(Typ
: Entity_Id
) return Boolean is
9086 Comp
:= First_Component
(Typ
);
9087 while Present
(Comp
) loop
9088 Ctyp
:= Underlying_Type
(Etype
(Comp
));
9089 if Is_Record_Type
(Ctyp
)
9090 and then Has_Discriminants
(Ctyp
)
9091 and then not Is_Constrained
(Ctyp
)
9096 Next_Component
(Comp
);
9100 end Has_Mutable_Components
;
9102 ------------------------------
9103 -- Initialize_Discriminants --
9104 ------------------------------
9106 procedure Initialize_Discriminants
(N
: Node_Id
; Typ
: Entity_Id
) is
9107 Loc
: constant Source_Ptr
:= Sloc
(N
);
9108 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
9109 Par
: constant Entity_Id
:= Etype
(Bas
);
9110 Decl
: constant Node_Id
:= Parent
(Par
);
9114 if Is_Tagged_Type
(Bas
)
9115 and then Is_Derived_Type
(Bas
)
9116 and then Has_Discriminants
(Par
)
9117 and then Has_Discriminants
(Bas
)
9118 and then Number_Discriminants
(Bas
) /= Number_Discriminants
(Par
)
9119 and then Nkind
(Decl
) = N_Full_Type_Declaration
9120 and then Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
9122 Present
(Variant_Part
(Component_List
(Type_Definition
(Decl
))))
9123 and then Nkind
(N
) /= N_Extension_Aggregate
9126 -- Call init proc to set discriminants.
9127 -- There should eventually be a special procedure for this ???
9129 Ref
:= New_Occurrence_Of
(Defining_Identifier
(N
), Loc
);
9130 Insert_Actions_After
(N
,
9131 Build_Initialization_Call
(Sloc
(N
), Ref
, Typ
));
9133 end Initialize_Discriminants
;
9141 Obj_Type
: Entity_Id
;
9142 Typ
: Entity_Id
) return Boolean
9145 -- No sliding if the type of the object is not established yet, if it is
9146 -- an unconstrained type whose actual subtype comes from the aggregate,
9147 -- or if the two types are identical. If the aggregate contains only
9148 -- an Others_Clause it gets its type from the context and no sliding
9149 -- is involved either.
9151 if not Is_Array_Type
(Obj_Type
) then
9154 elsif not Is_Constrained
(Obj_Type
) then
9157 elsif Typ
= Obj_Type
then
9160 elsif Is_Others_Aggregate
(Aggr
) then
9164 -- Sliding can only occur along the first dimension
9165 -- If any the bounds of non-static sliding is required
9166 -- to force potential range checks.
9169 Bounds1
: constant Range_Nodes
:=
9170 Get_Index_Bounds
(First_Index
(Typ
));
9171 Bounds2
: constant Range_Nodes
:=
9172 Get_Index_Bounds
(First_Index
(Obj_Type
));
9175 if not Is_OK_Static_Expression
(Bounds1
.First
) or else
9176 not Is_OK_Static_Expression
(Bounds2
.First
) or else
9177 not Is_OK_Static_Expression
(Bounds1
.Last
) or else
9178 not Is_OK_Static_Expression
(Bounds2
.Last
)
9183 return Expr_Value
(Bounds1
.First
) /= Expr_Value
(Bounds2
.First
)
9185 Expr_Value
(Bounds1
.Last
) /= Expr_Value
(Bounds2
.Last
);
9191 ---------------------
9192 -- Sort_Case_Table --
9193 ---------------------
9195 procedure Sort_Case_Table
(Case_Table
: in out Case_Table_Type
) is
9196 L
: constant Int
:= Case_Table
'First;
9197 U
: constant Int
:= Case_Table
'Last;
9205 T
:= Case_Table
(K
+ 1);
9209 and then Expr_Value
(Case_Table
(J
- 1).Choice_Lo
) >
9210 Expr_Value
(T
.Choice_Lo
)
9212 Case_Table
(J
) := Case_Table
(J
- 1);
9216 Case_Table
(J
) := T
;
9219 end Sort_Case_Table
;
9221 ----------------------------
9222 -- Static_Array_Aggregate --
9223 ----------------------------
9225 function Static_Array_Aggregate
(N
: Node_Id
) return Boolean is
9226 function Is_Static_Component
(Nod
: Node_Id
) return Boolean;
9227 -- Return True if Nod has a compile-time known value and can be passed
9228 -- as is to the back-end without further expansion.
9230 ---------------------------
9231 -- Is_Static_Component --
9232 ---------------------------
9234 function Is_Static_Component
(Nod
: Node_Id
) return Boolean is
9236 if Nkind
(Nod
) in N_Integer_Literal | N_Real_Literal
then
9239 elsif Is_Entity_Name
(Nod
)
9240 and then Present
(Entity
(Nod
))
9241 and then Ekind
(Entity
(Nod
)) = E_Enumeration_Literal
9245 elsif Nkind
(Nod
) = N_Aggregate
9246 and then Compile_Time_Known_Aggregate
(Nod
)
9253 end Is_Static_Component
;
9257 Bounds
: constant Node_Id
:= Aggregate_Bounds
(N
);
9258 Typ
: constant Entity_Id
:= Etype
(N
);
9265 -- Start of processing for Static_Array_Aggregate
9268 if Is_Packed
(Typ
) or else Has_Discriminants
(Component_Type
(Typ
)) then
9273 and then Nkind
(Bounds
) = N_Range
9274 and then Nkind
(Low_Bound
(Bounds
)) = N_Integer_Literal
9275 and then Nkind
(High_Bound
(Bounds
)) = N_Integer_Literal
9277 Lo
:= Low_Bound
(Bounds
);
9278 Hi
:= High_Bound
(Bounds
);
9280 if No
(Component_Associations
(N
)) then
9282 -- Verify that all components are static
9284 Expr
:= First
(Expressions
(N
));
9285 while Present
(Expr
) loop
9286 if not Is_Static_Component
(Expr
) then
9296 -- We allow only a single named association, either a static
9297 -- range or an others_clause, with a static expression.
9299 Expr
:= First
(Component_Associations
(N
));
9301 if Present
(Expressions
(N
)) then
9304 elsif Present
(Next
(Expr
)) then
9307 elsif Present
(Next
(First
(Choice_List
(Expr
)))) then
9311 -- The aggregate is static if all components are literals,
9312 -- or else all its components are static aggregates for the
9313 -- component type. We also limit the size of a static aggregate
9314 -- to prevent runaway static expressions.
9316 if not Is_Static_Component
(Expression
(Expr
)) then
9320 if not Aggr_Size_OK
(N
) then
9324 -- Create a positional aggregate with the right number of
9325 -- copies of the expression.
9327 Agg
:= Make_Aggregate
(Sloc
(N
), New_List
, No_List
);
9329 for I
in UI_To_Int
(Intval
(Lo
)) .. UI_To_Int
(Intval
(Hi
))
9331 Append_To
(Expressions
(Agg
), New_Copy
(Expression
(Expr
)));
9333 -- The copied expression must be analyzed and resolved.
9334 -- Besides setting the type, this ensures that static
9335 -- expressions are appropriately marked as such.
9338 (Last
(Expressions
(Agg
)), Component_Type
(Typ
));
9341 Set_Aggregate_Bounds
(Agg
, Bounds
);
9342 Set_Etype
(Agg
, Typ
);
9345 Set_Compile_Time_Known_Aggregate
(N
);
9354 end Static_Array_Aggregate
;
9356 ----------------------------------
9357 -- Two_Dim_Packed_Array_Handled --
9358 ----------------------------------
9360 function Two_Dim_Packed_Array_Handled
(N
: Node_Id
) return Boolean is
9361 Loc
: constant Source_Ptr
:= Sloc
(N
);
9362 Typ
: constant Entity_Id
:= Etype
(N
);
9363 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
9364 Comp_Size
: constant Int
:= UI_To_Int
(Component_Size
(Typ
));
9365 Packed_Array
: constant Entity_Id
:=
9366 Packed_Array_Impl_Type
(Base_Type
(Typ
));
9369 -- Expression in original aggregate
9372 -- One-dimensional subaggregate
9376 -- For now, only deal with cases where an integral number of elements
9377 -- fit in a single byte. This includes the most common boolean case.
9379 if not (Comp_Size
= 1 or else
9380 Comp_Size
= 2 or else
9386 Convert_To_Positional
(N
, Handle_Bit_Packed
=> True);
9388 -- Verify that all components are static
9390 if Nkind
(N
) = N_Aggregate
9391 and then Compile_Time_Known_Aggregate
(N
)
9395 -- The aggregate may have been reanalyzed and converted already
9397 elsif Nkind
(N
) /= N_Aggregate
then
9400 -- If component associations remain, the aggregate is not static
9402 elsif Present
(Component_Associations
(N
)) then
9406 One_Dim
:= First
(Expressions
(N
));
9407 while Present
(One_Dim
) loop
9408 if Present
(Component_Associations
(One_Dim
)) then
9412 One_Comp
:= First
(Expressions
(One_Dim
));
9413 while Present
(One_Comp
) loop
9414 if not Is_OK_Static_Expression
(One_Comp
) then
9425 -- Two-dimensional aggregate is now fully positional so pack one
9426 -- dimension to create a static one-dimensional array, and rewrite
9427 -- as an unchecked conversion to the original type.
9430 Byte_Size
: constant Int
:= UI_To_Int
(Component_Size
(Packed_Array
));
9431 -- The packed array type is a byte array
9434 -- Number of components accumulated in current byte
9437 -- Assembled list of packed values for equivalent aggregate
9440 -- Integer value of component
9443 -- Step size for packing
9446 -- Endian-dependent start position for packing
9449 -- Current insertion position
9452 -- Component of packed array being assembled
9459 -- Account for endianness. See corresponding comment in
9460 -- Packed_Array_Aggregate_Handled concerning the following.
9464 xor Reverse_Storage_Order
(Base_Type
(Typ
))
9466 Init_Shift
:= Byte_Size
- Comp_Size
;
9473 -- Iterate over each subaggregate
9475 Shift
:= Init_Shift
;
9476 One_Dim
:= First
(Expressions
(N
));
9477 while Present
(One_Dim
) loop
9478 One_Comp
:= First
(Expressions
(One_Dim
));
9479 while Present
(One_Comp
) loop
9480 if Packed_Num
= Byte_Size
/ Comp_Size
then
9482 -- Byte is complete, add to list of expressions
9484 Append
(Make_Integer_Literal
(Sloc
(One_Dim
), Val
), Comps
);
9486 Shift
:= Init_Shift
;
9490 Comp_Val
:= Expr_Rep_Value
(One_Comp
);
9492 -- Adjust for bias, and strip proper number of bits
9494 if Has_Biased_Representation
(Ctyp
) then
9495 Comp_Val
:= Comp_Val
- Expr_Value
(Type_Low_Bound
(Ctyp
));
9498 Comp_Val
:= Comp_Val
mod Uint_2
** Comp_Size
;
9499 Val
:= UI_To_Int
(Val
+ Comp_Val
* Uint_2
** Shift
);
9500 Shift
:= Shift
+ Incr
;
9502 Packed_Num
:= Packed_Num
+ 1;
9509 if Packed_Num
> 0 then
9511 -- Add final incomplete byte if present
9513 Append
(Make_Integer_Literal
(Sloc
(One_Dim
), Val
), Comps
);
9517 Unchecked_Convert_To
(Typ
,
9518 Make_Qualified_Expression
(Loc
,
9519 Subtype_Mark
=> New_Occurrence_Of
(Packed_Array
, Loc
),
9520 Expression
=> Make_Aggregate
(Loc
, Expressions
=> Comps
))));
9521 Analyze_And_Resolve
(N
);
9524 end Two_Dim_Packed_Array_Handled
;