1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Expander
; use Expander
;
33 with Exp_Util
; use Exp_Util
;
34 with Exp_Ch3
; use Exp_Ch3
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch7
; use Exp_Ch7
;
37 with Exp_Ch9
; use Exp_Ch9
;
38 with Exp_Disp
; use Exp_Disp
;
39 with Exp_Tss
; use Exp_Tss
;
40 with Fname
; use Fname
;
41 with Freeze
; use Freeze
;
42 with Itypes
; use Itypes
;
44 with Namet
; use Namet
;
45 with Nmake
; use Nmake
;
46 with Nlists
; use Nlists
;
48 with Restrict
; use Restrict
;
49 with Rident
; use Rident
;
50 with Rtsfind
; use Rtsfind
;
51 with Ttypes
; use Ttypes
;
53 with Sem_Aggr
; use Sem_Aggr
;
54 with Sem_Aux
; use Sem_Aux
;
55 with Sem_Ch3
; use Sem_Ch3
;
56 with Sem_Eval
; use Sem_Eval
;
57 with Sem_Res
; use Sem_Res
;
58 with Sem_Util
; use Sem_Util
;
59 with Sinfo
; use Sinfo
;
60 with Snames
; use Snames
;
61 with Stand
; use Stand
;
62 with Stringt
; use Stringt
;
63 with Targparm
; use Targparm
;
64 with Tbuild
; use Tbuild
;
65 with Uintp
; use Uintp
;
67 package body Exp_Aggr
is
69 type Case_Bounds
is record
72 Choice_Node
: Node_Id
;
75 type Case_Table_Type
is array (Nat
range <>) of Case_Bounds
;
76 -- Table type used by Check_Case_Choices procedure
78 function Has_Default_Init_Comps
(N
: Node_Id
) return Boolean;
79 -- N is an aggregate (record or array). Checks the presence of default
80 -- initialization (<>) in any component (Ada 2005: AI-287).
82 function Is_Static_Dispatch_Table_Aggregate
(N
: Node_Id
) return Boolean;
83 -- Returns true if N is an aggregate used to initialize the components
84 -- of an statically allocated dispatch table.
87 (Obj_Type
: Entity_Id
;
88 Typ
: Entity_Id
) return Boolean;
89 -- A static array aggregate in an object declaration can in most cases be
90 -- expanded in place. The one exception is when the aggregate is given
91 -- with component associations that specify different bounds from those of
92 -- the type definition in the object declaration. In this pathological
93 -- case the aggregate must slide, and we must introduce an intermediate
94 -- temporary to hold it.
96 -- The same holds in an assignment to one-dimensional array of arrays,
97 -- when a component may be given with bounds that differ from those of the
100 procedure Sort_Case_Table
(Case_Table
: in out Case_Table_Type
);
101 -- Sort the Case Table using the Lower Bound of each Choice as the key.
102 -- A simple insertion sort is used since the number of choices in a case
103 -- statement of variant part will usually be small and probably in near
106 procedure Collect_Initialization_Statements
109 Node_After
: Node_Id
);
110 -- If Obj is not frozen, collect actions inserted after N until, but not
111 -- including, Node_After, for initialization of Obj, and move them to an
112 -- expression with actions, which becomes the Initialization_Statements for
115 ------------------------------------------------------
116 -- Local subprograms for Record Aggregate Expansion --
117 ------------------------------------------------------
119 function Build_Record_Aggr_Code
122 Lhs
: Node_Id
) return List_Id
;
123 -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
124 -- aggregate. Target is an expression containing the location on which the
125 -- component by component assignments will take place. Returns the list of
126 -- assignments plus all other adjustments needed for tagged and controlled
129 procedure Convert_To_Assignments
(N
: Node_Id
; Typ
: Entity_Id
);
130 -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
131 -- aggregate (which can only be a record type, this procedure is only used
132 -- for record types). Transform the given aggregate into a sequence of
133 -- assignments performed component by component.
135 procedure Expand_Record_Aggregate
137 Orig_Tag
: Node_Id
:= Empty
;
138 Parent_Expr
: Node_Id
:= Empty
);
139 -- This is the top level procedure for record aggregate expansion.
140 -- Expansion for record aggregates needs expand aggregates for tagged
141 -- record types. Specifically Expand_Record_Aggregate adds the Tag
142 -- field in front of the Component_Association list that was created
143 -- during resolution by Resolve_Record_Aggregate.
145 -- N is the record aggregate node.
146 -- Orig_Tag is the value of the Tag that has to be provided for this
147 -- specific aggregate. It carries the tag corresponding to the type
148 -- of the outermost aggregate during the recursive expansion
149 -- Parent_Expr is the ancestor part of the original extension
152 function Has_Mutable_Components
(Typ
: Entity_Id
) return Boolean;
153 -- Return true if one of the component is of a discriminated type with
154 -- defaults. An aggregate for a type with mutable components must be
155 -- expanded into individual assignments.
157 procedure Initialize_Discriminants
(N
: Node_Id
; Typ
: Entity_Id
);
158 -- If the type of the aggregate is a type extension with renamed discrimi-
159 -- nants, we must initialize the hidden discriminants of the parent.
160 -- Otherwise, the target object must not be initialized. The discriminants
161 -- are initialized by calling the initialization procedure for the type.
162 -- This is incorrect if the initialization of other components has any
163 -- side effects. We restrict this call to the case where the parent type
164 -- has a variant part, because this is the only case where the hidden
165 -- discriminants are accessed, namely when calling discriminant checking
166 -- functions of the parent type, and when applying a stream attribute to
167 -- an object of the derived type.
169 -----------------------------------------------------
170 -- Local Subprograms for Array Aggregate Expansion --
171 -----------------------------------------------------
173 function Aggr_Size_OK
(N
: Node_Id
; Typ
: Entity_Id
) return Boolean;
174 -- Very large static aggregates present problems to the back-end, and are
175 -- transformed into assignments and loops. This function verifies that the
176 -- total number of components of an aggregate is acceptable for rewriting
177 -- into a purely positional static form. Aggr_Size_OK must be called before
180 -- This function also detects and warns about one-component aggregates that
181 -- appear in a non-static context. Even if the component value is static,
182 -- such an aggregate must be expanded into an assignment.
184 function Backend_Processing_Possible
(N
: Node_Id
) return Boolean;
185 -- This function checks if array aggregate N can be processed directly
186 -- by the backend. If this is the case True is returned.
188 function Build_Array_Aggr_Code
193 Scalar_Comp
: Boolean;
194 Indexes
: List_Id
:= No_List
) return List_Id
;
195 -- This recursive routine returns a list of statements containing the
196 -- loops and assignments that are needed for the expansion of the array
199 -- N is the (sub-)aggregate node to be expanded into code. This node has
200 -- been fully analyzed, and its Etype is properly set.
202 -- Index is the index node corresponding to the array sub-aggregate N
204 -- Into is the target expression into which we are copying the aggregate.
205 -- Note that this node may not have been analyzed yet, and so the Etype
206 -- field may not be set.
208 -- Scalar_Comp is True if the component type of the aggregate is scalar
210 -- Indexes is the current list of expressions used to index the object we
213 procedure Convert_Array_Aggr_In_Allocator
217 -- If the aggregate appears within an allocator and can be expanded in
218 -- place, this routine generates the individual assignments to components
219 -- of the designated object. This is an optimization over the general
220 -- case, where a temporary is first created on the stack and then used to
221 -- construct the allocated object on the heap.
223 procedure Convert_To_Positional
225 Max_Others_Replicate
: Nat
:= 5;
226 Handle_Bit_Packed
: Boolean := False);
227 -- If possible, convert named notation to positional notation. This
228 -- conversion is possible only in some static cases. If the conversion is
229 -- possible, then N is rewritten with the analyzed converted aggregate.
230 -- The parameter Max_Others_Replicate controls the maximum number of
231 -- values corresponding to an others choice that will be converted to
232 -- positional notation (the default of 5 is the normal limit, and reflects
233 -- the fact that normally the loop is better than a lot of separate
234 -- assignments). Note that this limit gets overridden in any case if
235 -- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
236 -- set. The parameter Handle_Bit_Packed is usually set False (since we do
237 -- not expect the back end to handle bit packed arrays, so the normal case
238 -- of conversion is pointless), but in the special case of a call from
239 -- Packed_Array_Aggregate_Handled, we set this parameter to True, since
240 -- these are cases we handle in there.
242 -- It would seem worthwhile to have a higher default value for Max_Others_
243 -- replicate, but aggregates in the compiler make this impossible: the
244 -- compiler bootstrap fails if Max_Others_Replicate is greater than 25.
245 -- This is unexpected ???
247 procedure Expand_Array_Aggregate
(N
: Node_Id
);
248 -- This is the top-level routine to perform array aggregate expansion.
249 -- N is the N_Aggregate node to be expanded.
251 function Is_Two_Dim_Packed_Array
(Typ
: Entity_Id
) return Boolean;
252 -- For two-dimensional packed aggregates with constant bounds and constant
253 -- components, it is preferable to pack the inner aggregates because the
254 -- whole matrix can then be presented to the back-end as a one-dimensional
255 -- list of literals. This is much more efficient than expanding into single
256 -- component assignments. This function determines if the type Typ is for
257 -- an array that is suitable for this optimization: it returns True if Typ
258 -- is a two dimensional bit packed array with component size 1, 2, or 4.
260 function Late_Expansion
263 Target
: Node_Id
) return List_Id
;
264 -- This routine implements top-down expansion of nested aggregates. In
265 -- doing so, it avoids the generation of temporaries at each level. N is
266 -- a nested record or array aggregate with the Expansion_Delayed flag.
267 -- Typ is the expected type of the aggregate. Target is a (duplicatable)
268 -- expression that will hold the result of the aggregate expansion.
270 function Make_OK_Assignment_Statement
273 Expression
: Node_Id
) return Node_Id
;
274 -- This is like Make_Assignment_Statement, except that Assignment_OK
275 -- is set in the left operand. All assignments built by this unit use
276 -- this routine. This is needed to deal with assignments to initialized
277 -- constants that are done in place.
279 function Number_Of_Choices
(N
: Node_Id
) return Nat
;
280 -- Returns the number of discrete choices (not including the others choice
281 -- if present) contained in (sub-)aggregate N.
283 function Packed_Array_Aggregate_Handled
(N
: Node_Id
) return Boolean;
284 -- Given an array aggregate, this function handles the case of a packed
285 -- array aggregate with all constant values, where the aggregate can be
286 -- evaluated at compile time. If this is possible, then N is rewritten
287 -- to be its proper compile time value with all the components properly
288 -- assembled. The expression is analyzed and resolved and True is returned.
289 -- If this transformation is not possible, N is unchanged and False is
292 function Safe_Slice_Assignment
(N
: Node_Id
) return Boolean;
293 -- If a slice assignment has an aggregate with a single others_choice,
294 -- the assignment can be done in place even if bounds are not static,
295 -- by converting it into a loop over the discrete range of the slice.
297 function Two_Dim_Packed_Array_Handled
(N
: Node_Id
) return Boolean;
298 -- If the type of the aggregate is a two-dimensional bit_packed array
299 -- it may be transformed into an array of bytes with constant values,
300 -- and presented to the back-end as a static value. The function returns
301 -- false if this transformation cannot be performed. THis is similar to,
302 -- and reuses part of the machinery in Packed_Array_Aggregate_Handled.
308 function Aggr_Size_OK
(N
: Node_Id
; Typ
: Entity_Id
) return Boolean is
317 -- Determines the maximum size of an array aggregate produced by
318 -- converting named to positional notation (e.g. from others clauses).
319 -- This avoids running away with attempts to convert huge aggregates,
320 -- which hit memory limits in the backend.
322 function Component_Count
(T
: Entity_Id
) return Int
;
323 -- The limit is applied to the total number of components that the
324 -- aggregate will have, which is the number of static expressions
325 -- that will appear in the flattened array. This requires a recursive
326 -- computation of the number of scalar components of the structure.
328 ---------------------
329 -- Component_Count --
330 ---------------------
332 function Component_Count
(T
: Entity_Id
) return Int
is
337 if Is_Scalar_Type
(T
) then
340 elsif Is_Record_Type
(T
) then
341 Comp
:= First_Component
(T
);
342 while Present
(Comp
) loop
343 Res
:= Res
+ Component_Count
(Etype
(Comp
));
344 Next_Component
(Comp
);
349 elsif Is_Array_Type
(T
) then
351 Lo
: constant Node_Id
:=
352 Type_Low_Bound
(Etype
(First_Index
(T
)));
353 Hi
: constant Node_Id
:=
354 Type_High_Bound
(Etype
(First_Index
(T
)));
356 Siz
: constant Int
:= Component_Count
(Component_Type
(T
));
359 if not Compile_Time_Known_Value
(Lo
)
360 or else not Compile_Time_Known_Value
(Hi
)
365 Siz
* UI_To_Int
(Expr_Value
(Hi
) - Expr_Value
(Lo
) + 1);
370 -- Can only be a null for an access type
376 -- Start of processing for Aggr_Size_OK
379 -- The normal aggregate limit is 5000, but we increase this limit to
380 -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code) or
381 -- Restrictions (No_Implicit_Loops) is specified, since in either case
382 -- we are at risk of declaring the program illegal because of this
383 -- limit. We also increase the limit when Static_Elaboration_Desired,
384 -- given that this means that objects are intended to be placed in data
387 -- We also increase the limit if the aggregate is for a packed two-
388 -- dimensional array, because if components are static it is much more
389 -- efficient to construct a one-dimensional equivalent array with static
392 -- Finally, we use a small limit in CodePeer mode where we favor loops
393 -- instead of thousands of single assignments (from large aggregates).
395 Max_Aggr_Size
:= 5000;
397 if CodePeer_Mode
then
398 Max_Aggr_Size
:= 100;
400 elsif Restriction_Active
(No_Elaboration_Code
)
401 or else Restriction_Active
(No_Implicit_Loops
)
402 or else Is_Two_Dim_Packed_Array
(Typ
)
403 or else ((Ekind
(Current_Scope
) = E_Package
404 and then Static_Elaboration_Desired
(Current_Scope
)))
406 Max_Aggr_Size
:= 2 ** 24;
409 Siz
:= Component_Count
(Component_Type
(Typ
));
411 Indx
:= First_Index
(Typ
);
412 while Present
(Indx
) loop
413 Lo
:= Type_Low_Bound
(Etype
(Indx
));
414 Hi
:= Type_High_Bound
(Etype
(Indx
));
416 -- Bounds need to be known at compile time
418 if not Compile_Time_Known_Value
(Lo
)
419 or else not Compile_Time_Known_Value
(Hi
)
424 Lov
:= Expr_Value
(Lo
);
425 Hiv
:= Expr_Value
(Hi
);
427 -- A flat array is always safe
433 -- One-component aggregates are suspicious, and if the context type
434 -- is an object declaration with non-static bounds it will trip gcc;
435 -- such an aggregate must be expanded into a single assignment.
438 and then Nkind
(Parent
(N
)) = N_Object_Declaration
441 Index_Type
: constant Entity_Id
:=
443 (First_Index
(Etype
(Defining_Identifier
(Parent
(N
)))));
447 if not Compile_Time_Known_Value
(Type_Low_Bound
(Index_Type
))
448 or else not Compile_Time_Known_Value
449 (Type_High_Bound
(Index_Type
))
451 if Present
(Component_Associations
(N
)) then
453 First
(Choices
(First
(Component_Associations
(N
))));
455 if Is_Entity_Name
(Indx
)
456 and then not Is_Type
(Entity
(Indx
))
459 ("single component aggregate in "
460 & "non-static context??", Indx
);
461 Error_Msg_N
("\maybe subtype name was meant??", Indx
);
471 Rng
: constant Uint
:= Hiv
- Lov
+ 1;
474 -- Check if size is too large
476 if not UI_Is_In_Int_Range
(Rng
) then
480 Siz
:= Siz
* UI_To_Int
(Rng
);
484 or else Siz
> Max_Aggr_Size
489 -- Bounds must be in integer range, for later array construction
491 if not UI_Is_In_Int_Range
(Lov
)
493 not UI_Is_In_Int_Range
(Hiv
)
504 ---------------------------------
505 -- Backend_Processing_Possible --
506 ---------------------------------
508 -- Backend processing by Gigi/gcc is possible only if all the following
509 -- conditions are met:
511 -- 1. N is fully positional
513 -- 2. N is not a bit-packed array aggregate;
515 -- 3. The size of N's array type must be known at compile time. Note
516 -- that this implies that the component size is also known
518 -- 4. The array type of N does not follow the Fortran layout convention
519 -- or if it does it must be 1 dimensional.
521 -- 5. The array component type may not be tagged (which could necessitate
522 -- reassignment of proper tags).
524 -- 6. The array component type must not have unaligned bit components
526 -- 7. None of the components of the aggregate may be bit unaligned
529 -- 8. There cannot be delayed components, since we do not know enough
530 -- at this stage to know if back end processing is possible.
532 -- 9. There cannot be any discriminated record components, since the
533 -- back end cannot handle this complex case.
535 -- 10. No controlled actions need to be generated for components
537 -- 11. For a VM back end, the array should have no aliased components
539 function Backend_Processing_Possible
(N
: Node_Id
) return Boolean is
540 Typ
: constant Entity_Id
:= Etype
(N
);
541 -- Typ is the correct constrained array subtype of the aggregate
543 function Component_Check
(N
: Node_Id
; Index
: Node_Id
) return Boolean;
544 -- This routine checks components of aggregate N, enforcing checks
545 -- 1, 7, 8, and 9. In the multi-dimensional case, these checks are
546 -- performed on subaggregates. The Index value is the current index
547 -- being checked in the multi-dimensional case.
549 ---------------------
550 -- Component_Check --
551 ---------------------
553 function Component_Check
(N
: Node_Id
; Index
: Node_Id
) return Boolean is
557 -- Checks 1: (no component associations)
559 if Present
(Component_Associations
(N
)) then
563 -- Checks on components
565 -- Recurse to check subaggregates, which may appear in qualified
566 -- expressions. If delayed, the front-end will have to expand.
567 -- If the component is a discriminated record, treat as non-static,
568 -- as the back-end cannot handle this properly.
570 Expr
:= First
(Expressions
(N
));
571 while Present
(Expr
) loop
573 -- Checks 8: (no delayed components)
575 if Is_Delayed_Aggregate
(Expr
) then
579 -- Checks 9: (no discriminated records)
581 if Present
(Etype
(Expr
))
582 and then Is_Record_Type
(Etype
(Expr
))
583 and then Has_Discriminants
(Etype
(Expr
))
588 -- Checks 7. Component must not be bit aligned component
590 if Possible_Bit_Aligned_Component
(Expr
) then
594 -- Recursion to following indexes for multiple dimension case
596 if Present
(Next_Index
(Index
))
597 and then not Component_Check
(Expr
, Next_Index
(Index
))
602 -- All checks for that component finished, on to next
610 -- Start of processing for Backend_Processing_Possible
613 -- Checks 2 (array not bit packed) and 10 (no controlled actions)
615 if Is_Bit_Packed_Array
(Typ
) or else Needs_Finalization
(Typ
) then
619 -- If component is limited, aggregate must be expanded because each
620 -- component assignment must be built in place.
622 if Is_Immutably_Limited_Type
(Component_Type
(Typ
)) then
626 -- Checks 4 (array must not be multi-dimensional Fortran case)
628 if Convention
(Typ
) = Convention_Fortran
629 and then Number_Dimensions
(Typ
) > 1
634 -- Checks 3 (size of array must be known at compile time)
636 if not Size_Known_At_Compile_Time
(Typ
) then
640 -- Checks on components
642 if not Component_Check
(N
, First_Index
(Typ
)) then
646 -- Checks 5 (if the component type is tagged, then we may need to do
647 -- tag adjustments. Perhaps this should be refined to check for any
648 -- component associations that actually need tag adjustment, similar
649 -- to the test in Component_Not_OK_For_Backend for record aggregates
650 -- with tagged components, but not clear whether it's worthwhile ???;
651 -- in the case of the JVM, object tags are handled implicitly)
653 if Is_Tagged_Type
(Component_Type
(Typ
))
654 and then Tagged_Type_Expansion
659 -- Checks 6 (component type must not have bit aligned components)
661 if Type_May_Have_Bit_Aligned_Components
(Component_Type
(Typ
)) then
665 -- Checks 11: Array aggregates with aliased components are currently
666 -- not well supported by the VM backend; disable temporarily this
667 -- backend processing until it is definitely supported.
669 if VM_Target
/= No_VM
670 and then Has_Aliased_Components
(Base_Type
(Typ
))
675 -- Backend processing is possible
677 Set_Size_Known_At_Compile_Time
(Etype
(N
), True);
679 end Backend_Processing_Possible
;
681 ---------------------------
682 -- Build_Array_Aggr_Code --
683 ---------------------------
685 -- The code that we generate from a one dimensional aggregate is
687 -- 1. If the sub-aggregate contains discrete choices we
689 -- (a) Sort the discrete choices
691 -- (b) Otherwise for each discrete choice that specifies a range we
692 -- emit a loop. If a range specifies a maximum of three values, or
693 -- we are dealing with an expression we emit a sequence of
694 -- assignments instead of a loop.
696 -- (c) Generate the remaining loops to cover the others choice if any
698 -- 2. If the aggregate contains positional elements we
700 -- (a) translate the positional elements in a series of assignments
702 -- (b) Generate a final loop to cover the others choice if any.
703 -- Note that this final loop has to be a while loop since the case
705 -- L : Integer := Integer'Last;
706 -- H : Integer := Integer'Last;
707 -- A : array (L .. H) := (1, others =>0);
709 -- cannot be handled by a for loop. Thus for the following
711 -- array (L .. H) := (.. positional elements.., others =>E);
713 -- we always generate something like:
715 -- J : Index_Type := Index_Of_Last_Positional_Element;
717 -- J := Index_Base'Succ (J)
721 function Build_Array_Aggr_Code
726 Scalar_Comp
: Boolean;
727 Indexes
: List_Id
:= No_List
) return List_Id
729 Loc
: constant Source_Ptr
:= Sloc
(N
);
730 Index_Base
: constant Entity_Id
:= Base_Type
(Etype
(Index
));
731 Index_Base_L
: constant Node_Id
:= Type_Low_Bound
(Index_Base
);
732 Index_Base_H
: constant Node_Id
:= Type_High_Bound
(Index_Base
);
734 function Add
(Val
: Int
; To
: Node_Id
) return Node_Id
;
735 -- Returns an expression where Val is added to expression To, unless
736 -- To+Val is provably out of To's base type range. To must be an
737 -- already analyzed expression.
739 function Empty_Range
(L
, H
: Node_Id
) return Boolean;
740 -- Returns True if the range defined by L .. H is certainly empty
742 function Equal
(L
, H
: Node_Id
) return Boolean;
743 -- Returns True if L = H for sure
745 function Index_Base_Name
return Node_Id
;
746 -- Returns a new reference to the index type name
748 function Gen_Assign
(Ind
: Node_Id
; Expr
: Node_Id
) return List_Id
;
749 -- Ind must be a side-effect free expression. If the input aggregate
750 -- N to Build_Loop contains no sub-aggregates, then this function
751 -- returns the assignment statement:
753 -- Into (Indexes, Ind) := Expr;
755 -- Otherwise we call Build_Code recursively
757 -- Ada 2005 (AI-287): In case of default initialized component, Expr
758 -- is empty and we generate a call to the corresponding IP subprogram.
760 function Gen_Loop
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
;
761 -- Nodes L and H must be side-effect free expressions.
762 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
763 -- This routine returns the for loop statement
765 -- for J in Index_Base'(L) .. Index_Base'(H) loop
766 -- Into (Indexes, J) := Expr;
769 -- Otherwise we call Build_Code recursively.
770 -- As an optimization if the loop covers 3 or less scalar elements we
771 -- generate a sequence of assignments.
773 function Gen_While
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
;
774 -- Nodes L and H must be side-effect free expressions.
775 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
776 -- This routine returns the while loop statement
778 -- J : Index_Base := L;
780 -- J := Index_Base'Succ (J);
781 -- Into (Indexes, J) := Expr;
784 -- Otherwise we call Build_Code recursively
786 function Local_Compile_Time_Known_Value
(E
: Node_Id
) return Boolean;
787 function Local_Expr_Value
(E
: Node_Id
) return Uint
;
788 -- These two Local routines are used to replace the corresponding ones
789 -- in sem_eval because while processing the bounds of an aggregate with
790 -- discrete choices whose index type is an enumeration, we build static
791 -- expressions not recognized by Compile_Time_Known_Value as such since
792 -- they have not yet been analyzed and resolved. All the expressions in
793 -- question are things like Index_Base_Name'Val (Const) which we can
794 -- easily recognize as being constant.
800 function Add
(Val
: Int
; To
: Node_Id
) return Node_Id
is
805 U_Val
: constant Uint
:= UI_From_Int
(Val
);
808 -- Note: do not try to optimize the case of Val = 0, because
809 -- we need to build a new node with the proper Sloc value anyway.
811 -- First test if we can do constant folding
813 if Local_Compile_Time_Known_Value
(To
) then
814 U_To
:= Local_Expr_Value
(To
) + Val
;
816 -- Determine if our constant is outside the range of the index.
817 -- If so return an Empty node. This empty node will be caught
818 -- by Empty_Range below.
820 if Compile_Time_Known_Value
(Index_Base_L
)
821 and then U_To
< Expr_Value
(Index_Base_L
)
825 elsif Compile_Time_Known_Value
(Index_Base_H
)
826 and then U_To
> Expr_Value
(Index_Base_H
)
831 Expr_Pos
:= Make_Integer_Literal
(Loc
, U_To
);
832 Set_Is_Static_Expression
(Expr_Pos
);
834 if not Is_Enumeration_Type
(Index_Base
) then
837 -- If we are dealing with enumeration return
838 -- Index_Base'Val (Expr_Pos)
842 Make_Attribute_Reference
844 Prefix
=> Index_Base_Name
,
845 Attribute_Name
=> Name_Val
,
846 Expressions
=> New_List
(Expr_Pos
));
852 -- If we are here no constant folding possible
854 if not Is_Enumeration_Type
(Index_Base
) then
857 Left_Opnd
=> Duplicate_Subexpr
(To
),
858 Right_Opnd
=> Make_Integer_Literal
(Loc
, U_Val
));
860 -- If we are dealing with enumeration return
861 -- Index_Base'Val (Index_Base'Pos (To) + Val)
865 Make_Attribute_Reference
867 Prefix
=> Index_Base_Name
,
868 Attribute_Name
=> Name_Pos
,
869 Expressions
=> New_List
(Duplicate_Subexpr
(To
)));
874 Right_Opnd
=> Make_Integer_Literal
(Loc
, U_Val
));
877 Make_Attribute_Reference
879 Prefix
=> Index_Base_Name
,
880 Attribute_Name
=> Name_Val
,
881 Expressions
=> New_List
(Expr_Pos
));
891 function Empty_Range
(L
, H
: Node_Id
) return Boolean is
892 Is_Empty
: Boolean := False;
897 -- First check if L or H were already detected as overflowing the
898 -- index base range type by function Add above. If this is so Add
899 -- returns the empty node.
901 if No
(L
) or else No
(H
) then
908 -- L > H range is empty
914 -- B_L > H range must be empty
920 -- L > B_H range must be empty
924 High
:= Index_Base_H
;
927 if Local_Compile_Time_Known_Value
(Low
)
928 and then Local_Compile_Time_Known_Value
(High
)
931 UI_Gt
(Local_Expr_Value
(Low
), Local_Expr_Value
(High
));
944 function Equal
(L
, H
: Node_Id
) return Boolean is
949 elsif Local_Compile_Time_Known_Value
(L
)
950 and then Local_Compile_Time_Known_Value
(H
)
952 return UI_Eq
(Local_Expr_Value
(L
), Local_Expr_Value
(H
));
962 function Gen_Assign
(Ind
: Node_Id
; Expr
: Node_Id
) return List_Id
is
963 L
: constant List_Id
:= New_List
;
966 New_Indexes
: List_Id
;
967 Indexed_Comp
: Node_Id
;
969 Comp_Type
: Entity_Id
:= Empty
;
971 function Add_Loop_Actions
(Lis
: List_Id
) return List_Id
;
972 -- Collect insert_actions generated in the construction of a
973 -- loop, and prepend them to the sequence of assignments to
974 -- complete the eventual body of the loop.
976 ----------------------
977 -- Add_Loop_Actions --
978 ----------------------
980 function Add_Loop_Actions
(Lis
: List_Id
) return List_Id
is
984 -- Ada 2005 (AI-287): Do nothing else in case of default
985 -- initialized component.
990 elsif Nkind
(Parent
(Expr
)) = N_Component_Association
991 and then Present
(Loop_Actions
(Parent
(Expr
)))
993 Append_List
(Lis
, Loop_Actions
(Parent
(Expr
)));
994 Res
:= Loop_Actions
(Parent
(Expr
));
995 Set_Loop_Actions
(Parent
(Expr
), No_List
);
1001 end Add_Loop_Actions
;
1003 -- Start of processing for Gen_Assign
1006 if No
(Indexes
) then
1007 New_Indexes
:= New_List
;
1009 New_Indexes
:= New_Copy_List_Tree
(Indexes
);
1012 Append_To
(New_Indexes
, Ind
);
1014 if Present
(Next_Index
(Index
)) then
1017 Build_Array_Aggr_Code
1020 Index
=> Next_Index
(Index
),
1022 Scalar_Comp
=> Scalar_Comp
,
1023 Indexes
=> New_Indexes
));
1026 -- If we get here then we are at a bottom-level (sub-)aggregate
1030 (Make_Indexed_Component
(Loc
,
1031 Prefix
=> New_Copy_Tree
(Into
),
1032 Expressions
=> New_Indexes
));
1034 Set_Assignment_OK
(Indexed_Comp
);
1036 -- Ada 2005 (AI-287): In case of default initialized component, Expr
1037 -- is not present (and therefore we also initialize Expr_Q to empty).
1041 elsif Nkind
(Expr
) = N_Qualified_Expression
then
1042 Expr_Q
:= Expression
(Expr
);
1047 if Present
(Etype
(N
))
1048 and then Etype
(N
) /= Any_Composite
1050 Comp_Type
:= Component_Type
(Etype
(N
));
1051 pragma Assert
(Comp_Type
= Ctype
); -- AI-287
1053 elsif Present
(Next
(First
(New_Indexes
))) then
1055 -- Ada 2005 (AI-287): Do nothing in case of default initialized
1056 -- component because we have received the component type in
1057 -- the formal parameter Ctype.
1059 -- ??? Some assert pragmas have been added to check if this new
1060 -- formal can be used to replace this code in all cases.
1062 if Present
(Expr
) then
1064 -- This is a multidimensional array. Recover the component
1065 -- type from the outermost aggregate, because subaggregates
1066 -- do not have an assigned type.
1073 while Present
(P
) loop
1074 if Nkind
(P
) = N_Aggregate
1075 and then Present
(Etype
(P
))
1077 Comp_Type
:= Component_Type
(Etype
(P
));
1085 pragma Assert
(Comp_Type
= Ctype
); -- AI-287
1090 -- Ada 2005 (AI-287): We only analyze the expression in case of non-
1091 -- default initialized components (otherwise Expr_Q is not present).
1094 and then Nkind_In
(Expr_Q
, N_Aggregate
, N_Extension_Aggregate
)
1096 -- At this stage the Expression may not have been analyzed yet
1097 -- because the array aggregate code has not been updated to use
1098 -- the Expansion_Delayed flag and avoid analysis altogether to
1099 -- solve the same problem (see Resolve_Aggr_Expr). So let us do
1100 -- the analysis of non-array aggregates now in order to get the
1101 -- value of Expansion_Delayed flag for the inner aggregate ???
1103 if Present
(Comp_Type
) and then not Is_Array_Type
(Comp_Type
) then
1104 Analyze_And_Resolve
(Expr_Q
, Comp_Type
);
1107 if Is_Delayed_Aggregate
(Expr_Q
) then
1109 -- This is either a subaggregate of a multidimensional array,
1110 -- or a component of an array type whose component type is
1111 -- also an array. In the latter case, the expression may have
1112 -- component associations that provide different bounds from
1113 -- those of the component type, and sliding must occur. Instead
1114 -- of decomposing the current aggregate assignment, force the
1115 -- re-analysis of the assignment, so that a temporary will be
1116 -- generated in the usual fashion, and sliding will take place.
1118 if Nkind
(Parent
(N
)) = N_Assignment_Statement
1119 and then Is_Array_Type
(Comp_Type
)
1120 and then Present
(Component_Associations
(Expr_Q
))
1121 and then Must_Slide
(Comp_Type
, Etype
(Expr_Q
))
1123 Set_Expansion_Delayed
(Expr_Q
, False);
1124 Set_Analyzed
(Expr_Q
, False);
1129 Late_Expansion
(Expr_Q
, Etype
(Expr_Q
), Indexed_Comp
));
1134 -- Ada 2005 (AI-287): In case of default initialized component, call
1135 -- the initialization subprogram associated with the component type.
1136 -- If the component type is an access type, add an explicit null
1137 -- assignment, because for the back-end there is an initialization
1138 -- present for the whole aggregate, and no default initialization
1141 -- In addition, if the component type is controlled, we must call
1142 -- its Initialize procedure explicitly, because there is no explicit
1143 -- object creation that will invoke it otherwise.
1146 if Present
(Base_Init_Proc
(Base_Type
(Ctype
)))
1147 or else Has_Task
(Base_Type
(Ctype
))
1150 Build_Initialization_Call
(Loc
,
1151 Id_Ref
=> Indexed_Comp
,
1153 With_Default_Init
=> True));
1155 elsif Is_Access_Type
(Ctype
) then
1157 Make_Assignment_Statement
(Loc
,
1158 Name
=> Indexed_Comp
,
1159 Expression
=> Make_Null
(Loc
)));
1162 if Needs_Finalization
(Ctype
) then
1165 Obj_Ref
=> New_Copy_Tree
(Indexed_Comp
),
1170 -- Now generate the assignment with no associated controlled
1171 -- actions since the target of the assignment may not have been
1172 -- initialized, it is not possible to Finalize it as expected by
1173 -- normal controlled assignment. The rest of the controlled
1174 -- actions are done manually with the proper finalization list
1175 -- coming from the context.
1178 Make_OK_Assignment_Statement
(Loc
,
1179 Name
=> Indexed_Comp
,
1180 Expression
=> New_Copy_Tree
(Expr
));
1182 if Present
(Comp_Type
) and then Needs_Finalization
(Comp_Type
) then
1183 Set_No_Ctrl_Actions
(A
);
1185 -- If this is an aggregate for an array of arrays, each
1186 -- sub-aggregate will be expanded as well, and even with
1187 -- No_Ctrl_Actions the assignments of inner components will
1188 -- require attachment in their assignments to temporaries.
1189 -- These temporaries must be finalized for each subaggregate,
1190 -- to prevent multiple attachments of the same temporary
1191 -- location to same finalization chain (and consequently
1192 -- circular lists). To ensure that finalization takes place
1193 -- for each subaggregate we wrap the assignment in a block.
1195 if Is_Array_Type
(Comp_Type
)
1196 and then Nkind
(Expr
) = N_Aggregate
1199 Make_Block_Statement
(Loc
,
1200 Handled_Statement_Sequence
=>
1201 Make_Handled_Sequence_Of_Statements
(Loc
,
1202 Statements
=> New_List
(A
)));
1208 -- Adjust the tag if tagged (because of possible view
1209 -- conversions), unless compiling for a VM where
1210 -- tags are implicit.
1212 if Present
(Comp_Type
)
1213 and then Is_Tagged_Type
(Comp_Type
)
1214 and then Tagged_Type_Expansion
1217 Full_Typ
: constant Entity_Id
:= Underlying_Type
(Comp_Type
);
1221 Make_OK_Assignment_Statement
(Loc
,
1223 Make_Selected_Component
(Loc
,
1224 Prefix
=> New_Copy_Tree
(Indexed_Comp
),
1227 (First_Tag_Component
(Full_Typ
), Loc
)),
1230 Unchecked_Convert_To
(RTE
(RE_Tag
),
1232 (Node
(First_Elmt
(Access_Disp_Table
(Full_Typ
))),
1239 -- Adjust and attach the component to the proper final list, which
1240 -- can be the controller of the outer record object or the final
1241 -- list associated with the scope.
1243 -- If the component is itself an array of controlled types, whose
1244 -- value is given by a sub-aggregate, then the attach calls have
1245 -- been generated when individual subcomponent are assigned, and
1246 -- must not be done again to prevent malformed finalization chains
1247 -- (see comments above, concerning the creation of a block to hold
1248 -- inner finalization actions).
1250 if Present
(Comp_Type
)
1251 and then Needs_Finalization
(Comp_Type
)
1252 and then not Is_Limited_Type
(Comp_Type
)
1254 (Is_Array_Type
(Comp_Type
)
1255 and then Is_Controlled
(Component_Type
(Comp_Type
))
1256 and then Nkind
(Expr
) = N_Aggregate
)
1260 Obj_Ref
=> New_Copy_Tree
(Indexed_Comp
),
1265 return Add_Loop_Actions
(L
);
1272 function Gen_Loop
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
is
1282 -- Index_Base'(L) .. Index_Base'(H)
1284 L_Iteration_Scheme
: Node_Id
;
1285 -- L_J in Index_Base'(L) .. Index_Base'(H)
1288 -- The statements to execute in the loop
1290 S
: constant List_Id
:= New_List
;
1291 -- List of statements
1294 -- Copy of expression tree, used for checking purposes
1297 -- If loop bounds define an empty range return the null statement
1299 if Empty_Range
(L
, H
) then
1300 Append_To
(S
, Make_Null_Statement
(Loc
));
1302 -- Ada 2005 (AI-287): Nothing else need to be done in case of
1303 -- default initialized component.
1309 -- The expression must be type-checked even though no component
1310 -- of the aggregate will have this value. This is done only for
1311 -- actual components of the array, not for subaggregates. Do
1312 -- the check on a copy, because the expression may be shared
1313 -- among several choices, some of which might be non-null.
1315 if Present
(Etype
(N
))
1316 and then Is_Array_Type
(Etype
(N
))
1317 and then No
(Next_Index
(Index
))
1319 Expander_Mode_Save_And_Set
(False);
1320 Tcopy
:= New_Copy_Tree
(Expr
);
1321 Set_Parent
(Tcopy
, N
);
1322 Analyze_And_Resolve
(Tcopy
, Component_Type
(Etype
(N
)));
1323 Expander_Mode_Restore
;
1329 -- If loop bounds are the same then generate an assignment
1331 elsif Equal
(L
, H
) then
1332 return Gen_Assign
(New_Copy_Tree
(L
), Expr
);
1334 -- If H - L <= 2 then generate a sequence of assignments when we are
1335 -- processing the bottom most aggregate and it contains scalar
1338 elsif No
(Next_Index
(Index
))
1339 and then Scalar_Comp
1340 and then Local_Compile_Time_Known_Value
(L
)
1341 and then Local_Compile_Time_Known_Value
(H
)
1342 and then Local_Expr_Value
(H
) - Local_Expr_Value
(L
) <= 2
1345 Append_List_To
(S
, Gen_Assign
(New_Copy_Tree
(L
), Expr
));
1346 Append_List_To
(S
, Gen_Assign
(Add
(1, To
=> L
), Expr
));
1348 if Local_Expr_Value
(H
) - Local_Expr_Value
(L
) = 2 then
1349 Append_List_To
(S
, Gen_Assign
(Add
(2, To
=> L
), Expr
));
1355 -- Otherwise construct the loop, starting with the loop index L_J
1357 L_J
:= Make_Temporary
(Loc
, 'J', L
);
1359 -- Construct "L .. H" in Index_Base. We use a qualified expression
1360 -- for the bound to convert to the index base, but we don't need
1361 -- to do that if we already have the base type at hand.
1363 if Etype
(L
) = Index_Base
then
1367 Make_Qualified_Expression
(Loc
,
1368 Subtype_Mark
=> Index_Base_Name
,
1372 if Etype
(H
) = Index_Base
then
1376 Make_Qualified_Expression
(Loc
,
1377 Subtype_Mark
=> Index_Base_Name
,
1386 -- Construct "for L_J in Index_Base range L .. H"
1388 L_Iteration_Scheme
:=
1389 Make_Iteration_Scheme
1391 Loop_Parameter_Specification
=>
1392 Make_Loop_Parameter_Specification
1394 Defining_Identifier
=> L_J
,
1395 Discrete_Subtype_Definition
=> L_Range
));
1397 -- Construct the statements to execute in the loop body
1399 L_Body
:= Gen_Assign
(New_Reference_To
(L_J
, Loc
), Expr
);
1401 -- Construct the final loop
1403 Append_To
(S
, Make_Implicit_Loop_Statement
1405 Identifier
=> Empty
,
1406 Iteration_Scheme
=> L_Iteration_Scheme
,
1407 Statements
=> L_Body
));
1409 -- A small optimization: if the aggregate is initialized with a box
1410 -- and the component type has no initialization procedure, remove the
1411 -- useless empty loop.
1413 if Nkind
(First
(S
)) = N_Loop_Statement
1414 and then Is_Empty_List
(Statements
(First
(S
)))
1416 return New_List
(Make_Null_Statement
(Loc
));
1426 -- The code built is
1428 -- W_J : Index_Base := L;
1429 -- while W_J < H loop
1430 -- W_J := Index_Base'Succ (W);
1434 function Gen_While
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
is
1438 -- W_J : Base_Type := L;
1440 W_Iteration_Scheme
: Node_Id
;
1443 W_Index_Succ
: Node_Id
;
1444 -- Index_Base'Succ (J)
1446 W_Increment
: Node_Id
;
1447 -- W_J := Index_Base'Succ (W)
1449 W_Body
: constant List_Id
:= New_List
;
1450 -- The statements to execute in the loop
1452 S
: constant List_Id
:= New_List
;
1453 -- list of statement
1456 -- If loop bounds define an empty range or are equal return null
1458 if Empty_Range
(L
, H
) or else Equal
(L
, H
) then
1459 Append_To
(S
, Make_Null_Statement
(Loc
));
1463 -- Build the decl of W_J
1465 W_J
:= Make_Temporary
(Loc
, 'J', L
);
1467 Make_Object_Declaration
1469 Defining_Identifier
=> W_J
,
1470 Object_Definition
=> Index_Base_Name
,
1473 -- Theoretically we should do a New_Copy_Tree (L) here, but we know
1474 -- that in this particular case L is a fresh Expr generated by
1475 -- Add which we are the only ones to use.
1477 Append_To
(S
, W_Decl
);
1479 -- Construct " while W_J < H"
1481 W_Iteration_Scheme
:=
1482 Make_Iteration_Scheme
1484 Condition
=> Make_Op_Lt
1486 Left_Opnd
=> New_Reference_To
(W_J
, Loc
),
1487 Right_Opnd
=> New_Copy_Tree
(H
)));
1489 -- Construct the statements to execute in the loop body
1492 Make_Attribute_Reference
1494 Prefix
=> Index_Base_Name
,
1495 Attribute_Name
=> Name_Succ
,
1496 Expressions
=> New_List
(New_Reference_To
(W_J
, Loc
)));
1499 Make_OK_Assignment_Statement
1501 Name
=> New_Reference_To
(W_J
, Loc
),
1502 Expression
=> W_Index_Succ
);
1504 Append_To
(W_Body
, W_Increment
);
1505 Append_List_To
(W_Body
,
1506 Gen_Assign
(New_Reference_To
(W_J
, Loc
), Expr
));
1508 -- Construct the final loop
1510 Append_To
(S
, Make_Implicit_Loop_Statement
1512 Identifier
=> Empty
,
1513 Iteration_Scheme
=> W_Iteration_Scheme
,
1514 Statements
=> W_Body
));
1519 ---------------------
1520 -- Index_Base_Name --
1521 ---------------------
1523 function Index_Base_Name
return Node_Id
is
1525 return New_Reference_To
(Index_Base
, Sloc
(N
));
1526 end Index_Base_Name
;
1528 ------------------------------------
1529 -- Local_Compile_Time_Known_Value --
1530 ------------------------------------
1532 function Local_Compile_Time_Known_Value
(E
: Node_Id
) return Boolean is
1534 return Compile_Time_Known_Value
(E
)
1536 (Nkind
(E
) = N_Attribute_Reference
1537 and then Attribute_Name
(E
) = Name_Val
1538 and then Compile_Time_Known_Value
(First
(Expressions
(E
))));
1539 end Local_Compile_Time_Known_Value
;
1541 ----------------------
1542 -- Local_Expr_Value --
1543 ----------------------
1545 function Local_Expr_Value
(E
: Node_Id
) return Uint
is
1547 if Compile_Time_Known_Value
(E
) then
1548 return Expr_Value
(E
);
1550 return Expr_Value
(First
(Expressions
(E
)));
1552 end Local_Expr_Value
;
1554 -- Build_Array_Aggr_Code Variables
1561 Others_Expr
: Node_Id
:= Empty
;
1562 Others_Box_Present
: Boolean := False;
1564 Aggr_L
: constant Node_Id
:= Low_Bound
(Aggregate_Bounds
(N
));
1565 Aggr_H
: constant Node_Id
:= High_Bound
(Aggregate_Bounds
(N
));
1566 -- The aggregate bounds of this specific sub-aggregate. Note that if
1567 -- the code generated by Build_Array_Aggr_Code is executed then these
1568 -- bounds are OK. Otherwise a Constraint_Error would have been raised.
1570 Aggr_Low
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Aggr_L
);
1571 Aggr_High
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Aggr_H
);
1572 -- After Duplicate_Subexpr these are side-effect free
1577 Nb_Choices
: Nat
:= 0;
1578 Table
: Case_Table_Type
(1 .. Number_Of_Choices
(N
));
1579 -- Used to sort all the different choice values
1582 -- Number of elements in the positional aggregate
1584 New_Code
: constant List_Id
:= New_List
;
1586 -- Start of processing for Build_Array_Aggr_Code
1589 -- First before we start, a special case. if we have a bit packed
1590 -- array represented as a modular type, then clear the value to
1591 -- zero first, to ensure that unused bits are properly cleared.
1596 and then Is_Bit_Packed_Array
(Typ
)
1597 and then Is_Modular_Integer_Type
(Packed_Array_Type
(Typ
))
1599 Append_To
(New_Code
,
1600 Make_Assignment_Statement
(Loc
,
1601 Name
=> New_Copy_Tree
(Into
),
1603 Unchecked_Convert_To
(Typ
,
1604 Make_Integer_Literal
(Loc
, Uint_0
))));
1607 -- If the component type contains tasks, we need to build a Master
1608 -- entity in the current scope, because it will be needed if build-
1609 -- in-place functions are called in the expanded code.
1611 if Nkind
(Parent
(N
)) = N_Object_Declaration
1612 and then Has_Task
(Typ
)
1614 Build_Master_Entity
(Defining_Identifier
(Parent
(N
)));
1617 -- STEP 1: Process component associations
1619 -- For those associations that may generate a loop, initialize
1620 -- Loop_Actions to collect inserted actions that may be crated.
1622 -- Skip this if no component associations
1624 if No
(Expressions
(N
)) then
1626 -- STEP 1 (a): Sort the discrete choices
1628 Assoc
:= First
(Component_Associations
(N
));
1629 while Present
(Assoc
) loop
1630 Choice
:= First
(Choices
(Assoc
));
1631 while Present
(Choice
) loop
1632 if Nkind
(Choice
) = N_Others_Choice
then
1633 Set_Loop_Actions
(Assoc
, New_List
);
1635 if Box_Present
(Assoc
) then
1636 Others_Box_Present
:= True;
1638 Others_Expr
:= Expression
(Assoc
);
1643 Get_Index_Bounds
(Choice
, Low
, High
);
1646 Set_Loop_Actions
(Assoc
, New_List
);
1649 Nb_Choices
:= Nb_Choices
+ 1;
1650 if Box_Present
(Assoc
) then
1651 Table
(Nb_Choices
) := (Choice_Lo
=> Low
,
1653 Choice_Node
=> Empty
);
1655 Table
(Nb_Choices
) := (Choice_Lo
=> Low
,
1657 Choice_Node
=> Expression
(Assoc
));
1665 -- If there is more than one set of choices these must be static
1666 -- and we can therefore sort them. Remember that Nb_Choices does not
1667 -- account for an others choice.
1669 if Nb_Choices
> 1 then
1670 Sort_Case_Table
(Table
);
1673 -- STEP 1 (b): take care of the whole set of discrete choices
1675 for J
in 1 .. Nb_Choices
loop
1676 Low
:= Table
(J
).Choice_Lo
;
1677 High
:= Table
(J
).Choice_Hi
;
1678 Expr
:= Table
(J
).Choice_Node
;
1679 Append_List
(Gen_Loop
(Low
, High
, Expr
), To
=> New_Code
);
1682 -- STEP 1 (c): generate the remaining loops to cover others choice
1683 -- We don't need to generate loops over empty gaps, but if there is
1684 -- a single empty range we must analyze the expression for semantics
1686 if Present
(Others_Expr
) or else Others_Box_Present
then
1688 First
: Boolean := True;
1691 for J
in 0 .. Nb_Choices
loop
1695 Low
:= Add
(1, To
=> Table
(J
).Choice_Hi
);
1698 if J
= Nb_Choices
then
1701 High
:= Add
(-1, To
=> Table
(J
+ 1).Choice_Lo
);
1704 -- If this is an expansion within an init proc, make
1705 -- sure that discriminant references are replaced by
1706 -- the corresponding discriminal.
1708 if Inside_Init_Proc
then
1709 if Is_Entity_Name
(Low
)
1710 and then Ekind
(Entity
(Low
)) = E_Discriminant
1712 Set_Entity
(Low
, Discriminal
(Entity
(Low
)));
1715 if Is_Entity_Name
(High
)
1716 and then Ekind
(Entity
(High
)) = E_Discriminant
1718 Set_Entity
(High
, Discriminal
(Entity
(High
)));
1723 or else not Empty_Range
(Low
, High
)
1727 (Gen_Loop
(Low
, High
, Others_Expr
), To
=> New_Code
);
1733 -- STEP 2: Process positional components
1736 -- STEP 2 (a): Generate the assignments for each positional element
1737 -- Note that here we have to use Aggr_L rather than Aggr_Low because
1738 -- Aggr_L is analyzed and Add wants an analyzed expression.
1740 Expr
:= First
(Expressions
(N
));
1742 while Present
(Expr
) loop
1743 Nb_Elements
:= Nb_Elements
+ 1;
1744 Append_List
(Gen_Assign
(Add
(Nb_Elements
, To
=> Aggr_L
), Expr
),
1749 -- STEP 2 (b): Generate final loop if an others choice is present
1750 -- Here Nb_Elements gives the offset of the last positional element.
1752 if Present
(Component_Associations
(N
)) then
1753 Assoc
:= Last
(Component_Associations
(N
));
1755 -- Ada 2005 (AI-287)
1757 if Box_Present
(Assoc
) then
1758 Append_List
(Gen_While
(Add
(Nb_Elements
, To
=> Aggr_L
),
1763 Expr
:= Expression
(Assoc
);
1765 Append_List
(Gen_While
(Add
(Nb_Elements
, To
=> Aggr_L
),
1774 end Build_Array_Aggr_Code
;
1776 ----------------------------
1777 -- Build_Record_Aggr_Code --
1778 ----------------------------
1780 function Build_Record_Aggr_Code
1783 Lhs
: Node_Id
) return List_Id
1785 Loc
: constant Source_Ptr
:= Sloc
(N
);
1786 L
: constant List_Id
:= New_List
;
1787 N_Typ
: constant Entity_Id
:= Etype
(N
);
1793 Comp_Type
: Entity_Id
;
1794 Selector
: Entity_Id
;
1795 Comp_Expr
: Node_Id
;
1798 -- If this is an internal aggregate, the External_Final_List is an
1799 -- expression for the controller record of the enclosing type.
1801 -- If the current aggregate has several controlled components, this
1802 -- expression will appear in several calls to attach to the finali-
1803 -- zation list, and it must not be shared.
1805 Ancestor_Is_Expression
: Boolean := False;
1806 Ancestor_Is_Subtype_Mark
: Boolean := False;
1808 Init_Typ
: Entity_Id
:= Empty
;
1810 Finalization_Done
: Boolean := False;
1811 -- True if Generate_Finalization_Actions has already been called; calls
1812 -- after the first do nothing.
1814 function Ancestor_Discriminant_Value
(Disc
: Entity_Id
) return Node_Id
;
1815 -- Returns the value that the given discriminant of an ancestor type
1816 -- should receive (in the absence of a conflict with the value provided
1817 -- by an ancestor part of an extension aggregate).
1819 procedure Check_Ancestor_Discriminants
(Anc_Typ
: Entity_Id
);
1820 -- Check that each of the discriminant values defined by the ancestor
1821 -- part of an extension aggregate match the corresponding values
1822 -- provided by either an association of the aggregate or by the
1823 -- constraint imposed by a parent type (RM95-4.3.2(8)).
1825 function Compatible_Int_Bounds
1826 (Agg_Bounds
: Node_Id
;
1827 Typ_Bounds
: Node_Id
) return Boolean;
1828 -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is
1829 -- assumed that both bounds are integer ranges.
1831 procedure Generate_Finalization_Actions
;
1832 -- Deal with the various controlled type data structure initializations
1833 -- (but only if it hasn't been done already).
1835 function Get_Constraint_Association
(T
: Entity_Id
) return Node_Id
;
1836 -- Returns the first discriminant association in the constraint
1837 -- associated with T, if any, otherwise returns Empty.
1839 procedure Init_Hidden_Discriminants
(Typ
: Entity_Id
; List
: List_Id
);
1840 -- If Typ is derived, and constrains discriminants of the parent type,
1841 -- these discriminants are not components of the aggregate, and must be
1842 -- initialized. The assignments are appended to List.
1844 function Get_Explicit_Discriminant_Value
(D
: Entity_Id
) return Node_Id
;
1845 -- If the ancestor part is an unconstrained type and further ancestors
1846 -- do not provide discriminants for it, check aggregate components for
1847 -- values of the discriminants.
1849 function Is_Int_Range_Bounds
(Bounds
: Node_Id
) return Boolean;
1850 -- Check whether Bounds is a range node and its lower and higher bounds
1851 -- are integers literals.
1853 ---------------------------------
1854 -- Ancestor_Discriminant_Value --
1855 ---------------------------------
1857 function Ancestor_Discriminant_Value
(Disc
: Entity_Id
) return Node_Id
is
1859 Assoc_Elmt
: Elmt_Id
;
1860 Aggr_Comp
: Entity_Id
;
1861 Corresp_Disc
: Entity_Id
;
1862 Current_Typ
: Entity_Id
:= Base_Type
(Typ
);
1863 Parent_Typ
: Entity_Id
;
1864 Parent_Disc
: Entity_Id
;
1865 Save_Assoc
: Node_Id
:= Empty
;
1868 -- First check any discriminant associations to see if any of them
1869 -- provide a value for the discriminant.
1871 if Present
(Discriminant_Specifications
(Parent
(Current_Typ
))) then
1872 Assoc
:= First
(Component_Associations
(N
));
1873 while Present
(Assoc
) loop
1874 Aggr_Comp
:= Entity
(First
(Choices
(Assoc
)));
1876 if Ekind
(Aggr_Comp
) = E_Discriminant
then
1877 Save_Assoc
:= Expression
(Assoc
);
1879 Corresp_Disc
:= Corresponding_Discriminant
(Aggr_Comp
);
1880 while Present
(Corresp_Disc
) loop
1882 -- If found a corresponding discriminant then return the
1883 -- value given in the aggregate. (Note: this is not
1884 -- correct in the presence of side effects. ???)
1886 if Disc
= Corresp_Disc
then
1887 return Duplicate_Subexpr
(Expression
(Assoc
));
1891 Corresponding_Discriminant
(Corresp_Disc
);
1899 -- No match found in aggregate, so chain up parent types to find
1900 -- a constraint that defines the value of the discriminant.
1902 Parent_Typ
:= Etype
(Current_Typ
);
1903 while Current_Typ
/= Parent_Typ
loop
1904 if Has_Discriminants
(Parent_Typ
)
1905 and then not Has_Unknown_Discriminants
(Parent_Typ
)
1907 Parent_Disc
:= First_Discriminant
(Parent_Typ
);
1909 -- We either get the association from the subtype indication
1910 -- of the type definition itself, or from the discriminant
1911 -- constraint associated with the type entity (which is
1912 -- preferable, but it's not always present ???)
1914 if Is_Empty_Elmt_List
(
1915 Discriminant_Constraint
(Current_Typ
))
1917 Assoc
:= Get_Constraint_Association
(Current_Typ
);
1918 Assoc_Elmt
:= No_Elmt
;
1921 First_Elmt
(Discriminant_Constraint
(Current_Typ
));
1922 Assoc
:= Node
(Assoc_Elmt
);
1925 -- Traverse the discriminants of the parent type looking
1926 -- for one that corresponds.
1928 while Present
(Parent_Disc
) and then Present
(Assoc
) loop
1929 Corresp_Disc
:= Parent_Disc
;
1930 while Present
(Corresp_Disc
)
1931 and then Disc
/= Corresp_Disc
1934 Corresponding_Discriminant
(Corresp_Disc
);
1937 if Disc
= Corresp_Disc
then
1938 if Nkind
(Assoc
) = N_Discriminant_Association
then
1939 Assoc
:= Expression
(Assoc
);
1942 -- If the located association directly denotes a
1943 -- discriminant, then use the value of a saved
1944 -- association of the aggregate. This is a kludge to
1945 -- handle certain cases involving multiple discriminants
1946 -- mapped to a single discriminant of a descendant. It's
1947 -- not clear how to locate the appropriate discriminant
1948 -- value for such cases. ???
1950 if Is_Entity_Name
(Assoc
)
1951 and then Ekind
(Entity
(Assoc
)) = E_Discriminant
1953 Assoc
:= Save_Assoc
;
1956 return Duplicate_Subexpr
(Assoc
);
1959 Next_Discriminant
(Parent_Disc
);
1961 if No
(Assoc_Elmt
) then
1964 Next_Elmt
(Assoc_Elmt
);
1965 if Present
(Assoc_Elmt
) then
1966 Assoc
:= Node
(Assoc_Elmt
);
1974 Current_Typ
:= Parent_Typ
;
1975 Parent_Typ
:= Etype
(Current_Typ
);
1978 -- In some cases there's no ancestor value to locate (such as
1979 -- when an ancestor part given by an expression defines the
1980 -- discriminant value).
1983 end Ancestor_Discriminant_Value
;
1985 ----------------------------------
1986 -- Check_Ancestor_Discriminants --
1987 ----------------------------------
1989 procedure Check_Ancestor_Discriminants
(Anc_Typ
: Entity_Id
) is
1991 Disc_Value
: Node_Id
;
1995 Discr
:= First_Discriminant
(Base_Type
(Anc_Typ
));
1996 while Present
(Discr
) loop
1997 Disc_Value
:= Ancestor_Discriminant_Value
(Discr
);
1999 if Present
(Disc_Value
) then
2000 Cond
:= Make_Op_Ne
(Loc
,
2002 Make_Selected_Component
(Loc
,
2003 Prefix
=> New_Copy_Tree
(Target
),
2004 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)),
2005 Right_Opnd
=> Disc_Value
);
2008 Make_Raise_Constraint_Error
(Loc
,
2010 Reason
=> CE_Discriminant_Check_Failed
));
2013 Next_Discriminant
(Discr
);
2015 end Check_Ancestor_Discriminants
;
2017 ---------------------------
2018 -- Compatible_Int_Bounds --
2019 ---------------------------
2021 function Compatible_Int_Bounds
2022 (Agg_Bounds
: Node_Id
;
2023 Typ_Bounds
: Node_Id
) return Boolean
2025 Agg_Lo
: constant Uint
:= Intval
(Low_Bound
(Agg_Bounds
));
2026 Agg_Hi
: constant Uint
:= Intval
(High_Bound
(Agg_Bounds
));
2027 Typ_Lo
: constant Uint
:= Intval
(Low_Bound
(Typ_Bounds
));
2028 Typ_Hi
: constant Uint
:= Intval
(High_Bound
(Typ_Bounds
));
2030 return Typ_Lo
<= Agg_Lo
and then Agg_Hi
<= Typ_Hi
;
2031 end Compatible_Int_Bounds
;
2033 --------------------------------
2034 -- Get_Constraint_Association --
2035 --------------------------------
2037 function Get_Constraint_Association
(T
: Entity_Id
) return Node_Id
is
2044 -- Handle private types in instances
2047 and then Is_Private_Type
(Typ
)
2048 and then Present
(Full_View
(Typ
))
2050 Typ
:= Full_View
(Typ
);
2053 Indic
:= Subtype_Indication
(Type_Definition
(Parent
(Typ
)));
2055 -- ??? Also need to cover case of a type mark denoting a subtype
2058 if Nkind
(Indic
) = N_Subtype_Indication
2059 and then Present
(Constraint
(Indic
))
2061 return First
(Constraints
(Constraint
(Indic
)));
2065 end Get_Constraint_Association
;
2067 -------------------------------------
2068 -- Get_Explicit_Discriminant_Value --
2069 -------------------------------------
2071 function Get_Explicit_Discriminant_Value
2072 (D
: Entity_Id
) return Node_Id
2079 -- The aggregate has been normalized and all associations have a
2082 Assoc
:= First
(Component_Associations
(N
));
2083 while Present
(Assoc
) loop
2084 Choice
:= First
(Choices
(Assoc
));
2086 if Chars
(Choice
) = Chars
(D
) then
2087 Val
:= Expression
(Assoc
);
2096 end Get_Explicit_Discriminant_Value
;
2098 -------------------------------
2099 -- Init_Hidden_Discriminants --
2100 -------------------------------
2102 procedure Init_Hidden_Discriminants
(Typ
: Entity_Id
; List
: List_Id
) is
2104 Parent_Type
: Entity_Id
;
2106 Discr_Val
: Elmt_Id
;
2109 Btype
:= Base_Type
(Typ
);
2110 while Is_Derived_Type
(Btype
)
2111 and then Present
(Stored_Constraint
(Btype
))
2113 Parent_Type
:= Etype
(Btype
);
2115 Disc
:= First_Discriminant
(Parent_Type
);
2116 Discr_Val
:= First_Elmt
(Stored_Constraint
(Base_Type
(Typ
)));
2117 while Present
(Discr_Val
) loop
2119 -- Only those discriminants of the parent that are not
2120 -- renamed by discriminants of the derived type need to
2121 -- be added explicitly.
2123 if not Is_Entity_Name
(Node
(Discr_Val
))
2124 or else Ekind
(Entity
(Node
(Discr_Val
))) /= E_Discriminant
2127 Make_Selected_Component
(Loc
,
2128 Prefix
=> New_Copy_Tree
(Target
),
2129 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
2132 Make_OK_Assignment_Statement
(Loc
,
2134 Expression
=> New_Copy_Tree
(Node
(Discr_Val
)));
2136 Set_No_Ctrl_Actions
(Instr
);
2137 Append_To
(List
, Instr
);
2140 Next_Discriminant
(Disc
);
2141 Next_Elmt
(Discr_Val
);
2144 Btype
:= Base_Type
(Parent_Type
);
2146 end Init_Hidden_Discriminants
;
2148 -------------------------
2149 -- Is_Int_Range_Bounds --
2150 -------------------------
2152 function Is_Int_Range_Bounds
(Bounds
: Node_Id
) return Boolean is
2154 return Nkind
(Bounds
) = N_Range
2155 and then Nkind
(Low_Bound
(Bounds
)) = N_Integer_Literal
2156 and then Nkind
(High_Bound
(Bounds
)) = N_Integer_Literal
;
2157 end Is_Int_Range_Bounds
;
2159 -----------------------------------
2160 -- Generate_Finalization_Actions --
2161 -----------------------------------
2163 procedure Generate_Finalization_Actions
is
2165 -- Do the work only the first time this is called
2167 if Finalization_Done
then
2171 Finalization_Done
:= True;
2173 -- Determine the external finalization list. It is either the
2174 -- finalization list of the outer-scope or the one coming from
2175 -- an outer aggregate. When the target is not a temporary, the
2176 -- proper scope is the scope of the target rather than the
2177 -- potentially transient current scope.
2179 if Is_Controlled
(Typ
)
2180 and then Ancestor_Is_Subtype_Mark
2182 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2183 Set_Assignment_OK
(Ref
);
2186 Make_Procedure_Call_Statement
(Loc
,
2189 (Find_Prim_Op
(Init_Typ
, Name_Initialize
), Loc
),
2190 Parameter_Associations
=> New_List
(New_Copy_Tree
(Ref
))));
2192 end Generate_Finalization_Actions
;
2194 function Rewrite_Discriminant
(Expr
: Node_Id
) return Traverse_Result
;
2195 -- If default expression of a component mentions a discriminant of the
2196 -- type, it must be rewritten as the discriminant of the target object.
2198 function Replace_Type
(Expr
: Node_Id
) return Traverse_Result
;
2199 -- If the aggregate contains a self-reference, traverse each expression
2200 -- to replace a possible self-reference with a reference to the proper
2201 -- component of the target of the assignment.
2203 --------------------------
2204 -- Rewrite_Discriminant --
2205 --------------------------
2207 function Rewrite_Discriminant
(Expr
: Node_Id
) return Traverse_Result
is
2209 if Is_Entity_Name
(Expr
)
2210 and then Present
(Entity
(Expr
))
2211 and then Ekind
(Entity
(Expr
)) = E_In_Parameter
2212 and then Present
(Discriminal_Link
(Entity
(Expr
)))
2213 and then Scope
(Discriminal_Link
(Entity
(Expr
)))
2214 = Base_Type
(Etype
(N
))
2217 Make_Selected_Component
(Loc
,
2218 Prefix
=> New_Copy_Tree
(Lhs
),
2219 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Expr
))));
2222 end Rewrite_Discriminant
;
2228 function Replace_Type
(Expr
: Node_Id
) return Traverse_Result
is
2230 -- Note regarding the Root_Type test below: Aggregate components for
2231 -- self-referential types include attribute references to the current
2232 -- instance, of the form: Typ'access, etc.. These references are
2233 -- rewritten as references to the target of the aggregate: the
2234 -- left-hand side of an assignment, the entity in a declaration,
2235 -- or a temporary. Without this test, we would improperly extended
2236 -- this rewriting to attribute references whose prefix was not the
2237 -- type of the aggregate.
2239 if Nkind
(Expr
) = N_Attribute_Reference
2240 and then Is_Entity_Name
(Prefix
(Expr
))
2241 and then Is_Type
(Entity
(Prefix
(Expr
)))
2242 and then Root_Type
(Etype
(N
)) = Root_Type
(Entity
(Prefix
(Expr
)))
2244 if Is_Entity_Name
(Lhs
) then
2245 Rewrite
(Prefix
(Expr
),
2246 New_Occurrence_Of
(Entity
(Lhs
), Loc
));
2248 elsif Nkind
(Lhs
) = N_Selected_Component
then
2250 Make_Attribute_Reference
(Loc
,
2251 Attribute_Name
=> Name_Unrestricted_Access
,
2252 Prefix
=> New_Copy_Tree
(Lhs
)));
2253 Set_Analyzed
(Parent
(Expr
), False);
2257 Make_Attribute_Reference
(Loc
,
2258 Attribute_Name
=> Name_Unrestricted_Access
,
2259 Prefix
=> New_Copy_Tree
(Lhs
)));
2260 Set_Analyzed
(Parent
(Expr
), False);
2267 procedure Replace_Self_Reference
is
2268 new Traverse_Proc
(Replace_Type
);
2270 procedure Replace_Discriminants
is
2271 new Traverse_Proc
(Rewrite_Discriminant
);
2273 -- Start of processing for Build_Record_Aggr_Code
2276 if Has_Self_Reference
(N
) then
2277 Replace_Self_Reference
(N
);
2280 -- If the target of the aggregate is class-wide, we must convert it
2281 -- to the actual type of the aggregate, so that the proper components
2282 -- are visible. We know already that the types are compatible.
2284 if Present
(Etype
(Lhs
))
2285 and then Is_Class_Wide_Type
(Etype
(Lhs
))
2287 Target
:= Unchecked_Convert_To
(Typ
, Lhs
);
2292 -- Deal with the ancestor part of extension aggregates or with the
2293 -- discriminants of the root type.
2295 if Nkind
(N
) = N_Extension_Aggregate
then
2297 Ancestor
: constant Node_Id
:= Ancestor_Part
(N
);
2301 -- If the ancestor part is a subtype mark "T", we generate
2303 -- init-proc (T (tmp)); if T is constrained and
2304 -- init-proc (S (tmp)); where S applies an appropriate
2305 -- constraint if T is unconstrained
2307 if Is_Entity_Name
(Ancestor
)
2308 and then Is_Type
(Entity
(Ancestor
))
2310 Ancestor_Is_Subtype_Mark
:= True;
2312 if Is_Constrained
(Entity
(Ancestor
)) then
2313 Init_Typ
:= Entity
(Ancestor
);
2315 -- For an ancestor part given by an unconstrained type mark,
2316 -- create a subtype constrained by appropriate corresponding
2317 -- discriminant values coming from either associations of the
2318 -- aggregate or a constraint on a parent type. The subtype will
2319 -- be used to generate the correct default value for the
2322 elsif Has_Discriminants
(Entity
(Ancestor
)) then
2324 Anc_Typ
: constant Entity_Id
:= Entity
(Ancestor
);
2325 Anc_Constr
: constant List_Id
:= New_List
;
2326 Discrim
: Entity_Id
;
2327 Disc_Value
: Node_Id
;
2328 New_Indic
: Node_Id
;
2329 Subt_Decl
: Node_Id
;
2332 Discrim
:= First_Discriminant
(Anc_Typ
);
2333 while Present
(Discrim
) loop
2334 Disc_Value
:= Ancestor_Discriminant_Value
(Discrim
);
2336 -- If no usable discriminant in ancestors, check
2337 -- whether aggregate has an explicit value for it.
2339 if No
(Disc_Value
) then
2341 Get_Explicit_Discriminant_Value
(Discrim
);
2344 Append_To
(Anc_Constr
, Disc_Value
);
2345 Next_Discriminant
(Discrim
);
2349 Make_Subtype_Indication
(Loc
,
2350 Subtype_Mark
=> New_Occurrence_Of
(Anc_Typ
, Loc
),
2352 Make_Index_Or_Discriminant_Constraint
(Loc
,
2353 Constraints
=> Anc_Constr
));
2355 Init_Typ
:= Create_Itype
(Ekind
(Anc_Typ
), N
);
2358 Make_Subtype_Declaration
(Loc
,
2359 Defining_Identifier
=> Init_Typ
,
2360 Subtype_Indication
=> New_Indic
);
2362 -- Itypes must be analyzed with checks off Declaration
2363 -- must have a parent for proper handling of subsidiary
2366 Set_Parent
(Subt_Decl
, N
);
2367 Analyze
(Subt_Decl
, Suppress
=> All_Checks
);
2371 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2372 Set_Assignment_OK
(Ref
);
2374 if not Is_Interface
(Init_Typ
) then
2376 Build_Initialization_Call
(Loc
,
2379 In_Init_Proc
=> Within_Init_Proc
,
2380 With_Default_Init
=> Has_Default_Init_Comps
(N
)
2382 Has_Task
(Base_Type
(Init_Typ
))));
2384 if Is_Constrained
(Entity
(Ancestor
))
2385 and then Has_Discriminants
(Entity
(Ancestor
))
2387 Check_Ancestor_Discriminants
(Entity
(Ancestor
));
2391 -- Handle calls to C++ constructors
2393 elsif Is_CPP_Constructor_Call
(Ancestor
) then
2394 Init_Typ
:= Etype
(Ancestor
);
2395 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2396 Set_Assignment_OK
(Ref
);
2399 Build_Initialization_Call
(Loc
,
2402 In_Init_Proc
=> Within_Init_Proc
,
2403 With_Default_Init
=> Has_Default_Init_Comps
(N
),
2404 Constructor_Ref
=> Ancestor
));
2406 -- Ada 2005 (AI-287): If the ancestor part is an aggregate of
2407 -- limited type, a recursive call expands the ancestor. Note that
2408 -- in the limited case, the ancestor part must be either a
2409 -- function call (possibly qualified, or wrapped in an unchecked
2410 -- conversion) or aggregate (definitely qualified).
2411 -- The ancestor part can also be a function call (that may be
2412 -- transformed into an explicit dereference) or a qualification
2415 elsif Is_Limited_Type
(Etype
(Ancestor
))
2416 and then Nkind_In
(Unqualify
(Ancestor
), N_Aggregate
,
2417 N_Extension_Aggregate
)
2419 Ancestor_Is_Expression
:= True;
2421 -- Set up finalization data for enclosing record, because
2422 -- controlled subcomponents of the ancestor part will be
2425 Generate_Finalization_Actions
;
2428 Build_Record_Aggr_Code
2429 (N
=> Unqualify
(Ancestor
),
2430 Typ
=> Etype
(Unqualify
(Ancestor
)),
2433 -- If the ancestor part is an expression "E", we generate
2437 -- In Ada 2005, this includes the case of a (possibly qualified)
2438 -- limited function call. The assignment will turn into a
2439 -- build-in-place function call (for further details, see
2440 -- Make_Build_In_Place_Call_In_Assignment).
2443 Ancestor_Is_Expression
:= True;
2444 Init_Typ
:= Etype
(Ancestor
);
2446 -- If the ancestor part is an aggregate, force its full
2447 -- expansion, which was delayed.
2449 if Nkind_In
(Unqualify
(Ancestor
), N_Aggregate
,
2450 N_Extension_Aggregate
)
2452 Set_Analyzed
(Ancestor
, False);
2453 Set_Analyzed
(Expression
(Ancestor
), False);
2456 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2457 Set_Assignment_OK
(Ref
);
2459 -- Make the assignment without usual controlled actions since
2460 -- we only want the post adjust but not the pre finalize here
2461 -- Add manual adjust when necessary.
2463 Assign
:= New_List
(
2464 Make_OK_Assignment_Statement
(Loc
,
2466 Expression
=> Ancestor
));
2467 Set_No_Ctrl_Actions
(First
(Assign
));
2469 -- Assign the tag now to make sure that the dispatching call in
2470 -- the subsequent deep_adjust works properly (unless VM_Target,
2471 -- where tags are implicit).
2473 if Tagged_Type_Expansion
then
2475 Make_OK_Assignment_Statement
(Loc
,
2477 Make_Selected_Component
(Loc
,
2478 Prefix
=> New_Copy_Tree
(Target
),
2481 (First_Tag_Component
(Base_Type
(Typ
)), Loc
)),
2484 Unchecked_Convert_To
(RTE
(RE_Tag
),
2487 (Access_Disp_Table
(Base_Type
(Typ
)))),
2490 Set_Assignment_OK
(Name
(Instr
));
2491 Append_To
(Assign
, Instr
);
2493 -- Ada 2005 (AI-251): If tagged type has progenitors we must
2494 -- also initialize tags of the secondary dispatch tables.
2496 if Has_Interfaces
(Base_Type
(Typ
)) then
2498 (Typ
=> Base_Type
(Typ
),
2500 Stmts_List
=> Assign
);
2504 -- Call Adjust manually
2506 if Needs_Finalization
(Etype
(Ancestor
))
2507 and then not Is_Limited_Type
(Etype
(Ancestor
))
2511 Obj_Ref
=> New_Copy_Tree
(Ref
),
2512 Typ
=> Etype
(Ancestor
)));
2516 Make_Unsuppress_Block
(Loc
, Name_Discriminant_Check
, Assign
));
2518 if Has_Discriminants
(Init_Typ
) then
2519 Check_Ancestor_Discriminants
(Init_Typ
);
2524 -- Generate assignments of hidden assignments. If the base type is an
2525 -- unchecked union, the discriminants are unknown to the back-end and
2526 -- absent from a value of the type, so assignments for them are not
2529 if Has_Discriminants
(Typ
)
2530 and then not Is_Unchecked_Union
(Base_Type
(Typ
))
2532 Init_Hidden_Discriminants
(Typ
, L
);
2535 -- Normal case (not an extension aggregate)
2538 -- Generate the discriminant expressions, component by component.
2539 -- If the base type is an unchecked union, the discriminants are
2540 -- unknown to the back-end and absent from a value of the type, so
2541 -- assignments for them are not emitted.
2543 if Has_Discriminants
(Typ
)
2544 and then not Is_Unchecked_Union
(Base_Type
(Typ
))
2546 Init_Hidden_Discriminants
(Typ
, L
);
2548 -- Generate discriminant init values for the visible discriminants
2551 Discriminant
: Entity_Id
;
2552 Discriminant_Value
: Node_Id
;
2555 Discriminant
:= First_Stored_Discriminant
(Typ
);
2556 while Present
(Discriminant
) loop
2558 Make_Selected_Component
(Loc
,
2559 Prefix
=> New_Copy_Tree
(Target
),
2560 Selector_Name
=> New_Occurrence_Of
(Discriminant
, Loc
));
2562 Discriminant_Value
:=
2563 Get_Discriminant_Value
(
2566 Discriminant_Constraint
(N_Typ
));
2569 Make_OK_Assignment_Statement
(Loc
,
2571 Expression
=> New_Copy_Tree
(Discriminant_Value
));
2573 Set_No_Ctrl_Actions
(Instr
);
2574 Append_To
(L
, Instr
);
2576 Next_Stored_Discriminant
(Discriminant
);
2582 -- For CPP types we generate an implicit call to the C++ default
2583 -- constructor to ensure the proper initialization of the _Tag
2586 if Is_CPP_Class
(Root_Type
(Typ
))
2587 and then CPP_Num_Prims
(Typ
) > 0
2589 Invoke_Constructor
: declare
2590 CPP_Parent
: constant Entity_Id
:= Enclosing_CPP_Parent
(Typ
);
2592 procedure Invoke_IC_Proc
(T
: Entity_Id
);
2593 -- Recursive routine used to climb to parents. Required because
2594 -- parents must be initialized before descendants to ensure
2595 -- propagation of inherited C++ slots.
2597 --------------------
2598 -- Invoke_IC_Proc --
2599 --------------------
2601 procedure Invoke_IC_Proc
(T
: Entity_Id
) is
2603 -- Avoid generating extra calls. Initialization required
2604 -- only for types defined from the level of derivation of
2605 -- type of the constructor and the type of the aggregate.
2607 if T
= CPP_Parent
then
2611 Invoke_IC_Proc
(Etype
(T
));
2613 -- Generate call to the IC routine
2615 if Present
(CPP_Init_Proc
(T
)) then
2617 Make_Procedure_Call_Statement
(Loc
,
2618 New_Reference_To
(CPP_Init_Proc
(T
), Loc
)));
2622 -- Start of processing for Invoke_Constructor
2625 -- Implicit invocation of the C++ constructor
2627 if Nkind
(N
) = N_Aggregate
then
2629 Make_Procedure_Call_Statement
(Loc
,
2632 (Base_Init_Proc
(CPP_Parent
), Loc
),
2633 Parameter_Associations
=> New_List
(
2634 Unchecked_Convert_To
(CPP_Parent
,
2635 New_Copy_Tree
(Lhs
)))));
2638 Invoke_IC_Proc
(Typ
);
2639 end Invoke_Constructor
;
2642 -- Generate the assignments, component by component
2644 -- tmp.comp1 := Expr1_From_Aggr;
2645 -- tmp.comp2 := Expr2_From_Aggr;
2648 Comp
:= First
(Component_Associations
(N
));
2649 while Present
(Comp
) loop
2650 Selector
:= Entity
(First
(Choices
(Comp
)));
2654 if Is_CPP_Constructor_Call
(Expression
(Comp
)) then
2656 Build_Initialization_Call
(Loc
,
2657 Id_Ref
=> Make_Selected_Component
(Loc
,
2658 Prefix
=> New_Copy_Tree
(Target
),
2660 New_Occurrence_Of
(Selector
, Loc
)),
2661 Typ
=> Etype
(Selector
),
2663 With_Default_Init
=> True,
2664 Constructor_Ref
=> Expression
(Comp
)));
2666 -- Ada 2005 (AI-287): For each default-initialized component generate
2667 -- a call to the corresponding IP subprogram if available.
2669 elsif Box_Present
(Comp
)
2670 and then Has_Non_Null_Base_Init_Proc
(Etype
(Selector
))
2672 if Ekind
(Selector
) /= E_Discriminant
then
2673 Generate_Finalization_Actions
;
2676 -- Ada 2005 (AI-287): If the component type has tasks then
2677 -- generate the activation chain and master entities (except
2678 -- in case of an allocator because in that case these entities
2679 -- are generated by Build_Task_Allocate_Block_With_Init_Stmts).
2682 Ctype
: constant Entity_Id
:= Etype
(Selector
);
2683 Inside_Allocator
: Boolean := False;
2684 P
: Node_Id
:= Parent
(N
);
2687 if Is_Task_Type
(Ctype
) or else Has_Task
(Ctype
) then
2688 while Present
(P
) loop
2689 if Nkind
(P
) = N_Allocator
then
2690 Inside_Allocator
:= True;
2697 if not Inside_Init_Proc
and not Inside_Allocator
then
2698 Build_Activation_Chain_Entity
(N
);
2704 Build_Initialization_Call
(Loc
,
2705 Id_Ref
=> Make_Selected_Component
(Loc
,
2706 Prefix
=> New_Copy_Tree
(Target
),
2708 New_Occurrence_Of
(Selector
, Loc
)),
2709 Typ
=> Etype
(Selector
),
2711 With_Default_Init
=> True));
2713 -- Prepare for component assignment
2715 elsif Ekind
(Selector
) /= E_Discriminant
2716 or else Nkind
(N
) = N_Extension_Aggregate
2718 -- All the discriminants have now been assigned
2720 -- This is now a good moment to initialize and attach all the
2721 -- controllers. Their position may depend on the discriminants.
2723 if Ekind
(Selector
) /= E_Discriminant
then
2724 Generate_Finalization_Actions
;
2727 Comp_Type
:= Underlying_Type
(Etype
(Selector
));
2729 Make_Selected_Component
(Loc
,
2730 Prefix
=> New_Copy_Tree
(Target
),
2731 Selector_Name
=> New_Occurrence_Of
(Selector
, Loc
));
2733 if Nkind
(Expression
(Comp
)) = N_Qualified_Expression
then
2734 Expr_Q
:= Expression
(Expression
(Comp
));
2736 Expr_Q
:= Expression
(Comp
);
2739 -- Now either create the assignment or generate the code for the
2740 -- inner aggregate top-down.
2742 if Is_Delayed_Aggregate
(Expr_Q
) then
2744 -- We have the following case of aggregate nesting inside
2745 -- an object declaration:
2747 -- type Arr_Typ is array (Integer range <>) of ...;
2749 -- type Rec_Typ (...) is record
2750 -- Obj_Arr_Typ : Arr_Typ (A .. B);
2753 -- Obj_Rec_Typ : Rec_Typ := (...,
2754 -- Obj_Arr_Typ => (X => (...), Y => (...)));
2756 -- The length of the ranges of the aggregate and Obj_Add_Typ
2757 -- are equal (B - A = Y - X), but they do not coincide (X /=
2758 -- A and B /= Y). This case requires array sliding which is
2759 -- performed in the following manner:
2761 -- subtype Arr_Sub is Arr_Typ (X .. Y);
2763 -- Temp (X) := (...);
2765 -- Temp (Y) := (...);
2766 -- Obj_Rec_Typ.Obj_Arr_Typ := Temp;
2768 if Ekind
(Comp_Type
) = E_Array_Subtype
2769 and then Is_Int_Range_Bounds
(Aggregate_Bounds
(Expr_Q
))
2770 and then Is_Int_Range_Bounds
(First_Index
(Comp_Type
))
2772 Compatible_Int_Bounds
2773 (Agg_Bounds
=> Aggregate_Bounds
(Expr_Q
),
2774 Typ_Bounds
=> First_Index
(Comp_Type
))
2776 -- Create the array subtype with bounds equal to those of
2777 -- the corresponding aggregate.
2780 SubE
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
2782 SubD
: constant Node_Id
:=
2783 Make_Subtype_Declaration
(Loc
,
2784 Defining_Identifier
=> SubE
,
2785 Subtype_Indication
=>
2786 Make_Subtype_Indication
(Loc
,
2788 New_Reference_To
(Etype
(Comp_Type
), Loc
),
2790 Make_Index_Or_Discriminant_Constraint
2792 Constraints
=> New_List
(
2794 (Aggregate_Bounds
(Expr_Q
))))));
2796 -- Create a temporary array of the above subtype which
2797 -- will be used to capture the aggregate assignments.
2799 TmpE
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A', N
);
2801 TmpD
: constant Node_Id
:=
2802 Make_Object_Declaration
(Loc
,
2803 Defining_Identifier
=> TmpE
,
2804 Object_Definition
=> New_Reference_To
(SubE
, Loc
));
2807 Set_No_Initialization
(TmpD
);
2808 Append_To
(L
, SubD
);
2809 Append_To
(L
, TmpD
);
2811 -- Expand aggregate into assignments to the temp array
2814 Late_Expansion
(Expr_Q
, Comp_Type
,
2815 New_Reference_To
(TmpE
, Loc
)));
2820 Make_Assignment_Statement
(Loc
,
2821 Name
=> New_Copy_Tree
(Comp_Expr
),
2822 Expression
=> New_Reference_To
(TmpE
, Loc
)));
2825 -- Normal case (sliding not required)
2829 Late_Expansion
(Expr_Q
, Comp_Type
, Comp_Expr
));
2832 -- Expr_Q is not delayed aggregate
2835 if Has_Discriminants
(Typ
) then
2836 Replace_Discriminants
(Expr_Q
);
2840 Make_OK_Assignment_Statement
(Loc
,
2842 Expression
=> Expr_Q
);
2844 Set_No_Ctrl_Actions
(Instr
);
2845 Append_To
(L
, Instr
);
2847 -- Adjust the tag if tagged (because of possible view
2848 -- conversions), unless compiling for a VM where tags are
2851 -- tmp.comp._tag := comp_typ'tag;
2853 if Is_Tagged_Type
(Comp_Type
)
2854 and then Tagged_Type_Expansion
2857 Make_OK_Assignment_Statement
(Loc
,
2859 Make_Selected_Component
(Loc
,
2860 Prefix
=> New_Copy_Tree
(Comp_Expr
),
2863 (First_Tag_Component
(Comp_Type
), Loc
)),
2866 Unchecked_Convert_To
(RTE
(RE_Tag
),
2868 (Node
(First_Elmt
(Access_Disp_Table
(Comp_Type
))),
2871 Append_To
(L
, Instr
);
2875 -- Adjust (tmp.comp);
2877 if Needs_Finalization
(Comp_Type
)
2878 and then not Is_Limited_Type
(Comp_Type
)
2882 Obj_Ref
=> New_Copy_Tree
(Comp_Expr
),
2889 elsif Ekind
(Selector
) = E_Discriminant
2890 and then Nkind
(N
) /= N_Extension_Aggregate
2891 and then Nkind
(Parent
(N
)) = N_Component_Association
2892 and then Is_Constrained
(Typ
)
2894 -- We must check that the discriminant value imposed by the
2895 -- context is the same as the value given in the subaggregate,
2896 -- because after the expansion into assignments there is no
2897 -- record on which to perform a regular discriminant check.
2904 D_Val
:= First_Elmt
(Discriminant_Constraint
(Typ
));
2905 Disc
:= First_Discriminant
(Typ
);
2906 while Chars
(Disc
) /= Chars
(Selector
) loop
2907 Next_Discriminant
(Disc
);
2911 pragma Assert
(Present
(D_Val
));
2913 -- This check cannot performed for components that are
2914 -- constrained by a current instance, because this is not a
2915 -- value that can be compared with the actual constraint.
2917 if Nkind
(Node
(D_Val
)) /= N_Attribute_Reference
2918 or else not Is_Entity_Name
(Prefix
(Node
(D_Val
)))
2919 or else not Is_Type
(Entity
(Prefix
(Node
(D_Val
))))
2922 Make_Raise_Constraint_Error
(Loc
,
2925 Left_Opnd
=> New_Copy_Tree
(Node
(D_Val
)),
2926 Right_Opnd
=> Expression
(Comp
)),
2927 Reason
=> CE_Discriminant_Check_Failed
));
2930 -- Find self-reference in previous discriminant assignment,
2931 -- and replace with proper expression.
2938 while Present
(Ass
) loop
2939 if Nkind
(Ass
) = N_Assignment_Statement
2940 and then Nkind
(Name
(Ass
)) = N_Selected_Component
2941 and then Chars
(Selector_Name
(Name
(Ass
))) =
2945 (Ass
, New_Copy_Tree
(Expression
(Comp
)));
2958 -- If the type is tagged, the tag needs to be initialized (unless
2959 -- compiling for the Java VM where tags are implicit). It is done
2960 -- late in the initialization process because in some cases, we call
2961 -- the init proc of an ancestor which will not leave out the right tag
2963 if Ancestor_Is_Expression
then
2966 -- For CPP types we generated a call to the C++ default constructor
2967 -- before the components have been initialized to ensure the proper
2968 -- initialization of the _Tag component (see above).
2970 elsif Is_CPP_Class
(Typ
) then
2973 elsif Is_Tagged_Type
(Typ
) and then Tagged_Type_Expansion
then
2975 Make_OK_Assignment_Statement
(Loc
,
2977 Make_Selected_Component
(Loc
,
2978 Prefix
=> New_Copy_Tree
(Target
),
2981 (First_Tag_Component
(Base_Type
(Typ
)), Loc
)),
2984 Unchecked_Convert_To
(RTE
(RE_Tag
),
2986 (Node
(First_Elmt
(Access_Disp_Table
(Base_Type
(Typ
)))),
2989 Append_To
(L
, Instr
);
2991 -- Ada 2005 (AI-251): If the tagged type has been derived from
2992 -- abstract interfaces we must also initialize the tags of the
2993 -- secondary dispatch tables.
2995 if Has_Interfaces
(Base_Type
(Typ
)) then
2997 (Typ
=> Base_Type
(Typ
),
3003 -- If the controllers have not been initialized yet (by lack of non-
3004 -- discriminant components), let's do it now.
3006 Generate_Finalization_Actions
;
3009 end Build_Record_Aggr_Code
;
3011 ---------------------------------------
3012 -- Collect_Initialization_Statements --
3013 ---------------------------------------
3015 procedure Collect_Initialization_Statements
3018 Node_After
: Node_Id
)
3020 Loc
: constant Source_Ptr
:= Sloc
(N
);
3021 Init_Actions
: constant List_Id
:= New_List
;
3022 Init_Node
: Node_Id
;
3026 -- Nothing to do if Obj is already frozen, as in this case we known we
3027 -- won't need to move the initialization statements about later on.
3029 if Is_Frozen
(Obj
) then
3034 while Next
(Init_Node
) /= Node_After
loop
3035 Append_To
(Init_Actions
, Remove_Next
(Init_Node
));
3038 if not Is_Empty_List
(Init_Actions
) then
3040 Make_Expression_With_Actions
(Loc
,
3041 Actions
=> Init_Actions
,
3042 Expression
=> Make_Null_Statement
(Loc
));
3043 Insert_Action_After
(Init_Node
, EA
);
3044 Set_Initialization_Statements
(Obj
, EA
);
3046 end Collect_Initialization_Statements
;
3048 -------------------------------
3049 -- Convert_Aggr_In_Allocator --
3050 -------------------------------
3052 procedure Convert_Aggr_In_Allocator
3057 Loc
: constant Source_Ptr
:= Sloc
(Aggr
);
3058 Typ
: constant Entity_Id
:= Etype
(Aggr
);
3059 Temp
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3061 Occ
: constant Node_Id
:=
3062 Unchecked_Convert_To
(Typ
,
3063 Make_Explicit_Dereference
(Loc
, New_Reference_To
(Temp
, Loc
)));
3066 if Is_Array_Type
(Typ
) then
3067 Convert_Array_Aggr_In_Allocator
(Decl
, Aggr
, Occ
);
3069 elsif Has_Default_Init_Comps
(Aggr
) then
3071 L
: constant List_Id
:= New_List
;
3072 Init_Stmts
: List_Id
;
3075 Init_Stmts
:= Late_Expansion
(Aggr
, Typ
, Occ
);
3077 if Has_Task
(Typ
) then
3078 Build_Task_Allocate_Block_With_Init_Stmts
(L
, Aggr
, Init_Stmts
);
3079 Insert_Actions
(Alloc
, L
);
3081 Insert_Actions
(Alloc
, Init_Stmts
);
3086 Insert_Actions
(Alloc
, Late_Expansion
(Aggr
, Typ
, Occ
));
3088 end Convert_Aggr_In_Allocator
;
3090 --------------------------------
3091 -- Convert_Aggr_In_Assignment --
3092 --------------------------------
3094 procedure Convert_Aggr_In_Assignment
(N
: Node_Id
) is
3095 Aggr
: Node_Id
:= Expression
(N
);
3096 Typ
: constant Entity_Id
:= Etype
(Aggr
);
3097 Occ
: constant Node_Id
:= New_Copy_Tree
(Name
(N
));
3100 if Nkind
(Aggr
) = N_Qualified_Expression
then
3101 Aggr
:= Expression
(Aggr
);
3104 Insert_Actions_After
(N
, Late_Expansion
(Aggr
, Typ
, Occ
));
3105 end Convert_Aggr_In_Assignment
;
3107 ---------------------------------
3108 -- Convert_Aggr_In_Object_Decl --
3109 ---------------------------------
3111 procedure Convert_Aggr_In_Object_Decl
(N
: Node_Id
) is
3112 Obj
: constant Entity_Id
:= Defining_Identifier
(N
);
3113 Aggr
: Node_Id
:= Expression
(N
);
3114 Loc
: constant Source_Ptr
:= Sloc
(Aggr
);
3115 Typ
: constant Entity_Id
:= Etype
(Aggr
);
3116 Occ
: constant Node_Id
:= New_Occurrence_Of
(Obj
, Loc
);
3118 function Discriminants_Ok
return Boolean;
3119 -- If the object type is constrained, the discriminants in the
3120 -- aggregate must be checked against the discriminants of the subtype.
3121 -- This cannot be done using Apply_Discriminant_Checks because after
3122 -- expansion there is no aggregate left to check.
3124 ----------------------
3125 -- Discriminants_Ok --
3126 ----------------------
3128 function Discriminants_Ok
return Boolean is
3129 Cond
: Node_Id
:= Empty
;
3138 D
:= First_Discriminant
(Typ
);
3139 Disc1
:= First_Elmt
(Discriminant_Constraint
(Typ
));
3140 Disc2
:= First_Elmt
(Discriminant_Constraint
(Etype
(Obj
)));
3141 while Present
(Disc1
) and then Present
(Disc2
) loop
3142 Val1
:= Node
(Disc1
);
3143 Val2
:= Node
(Disc2
);
3145 if not Is_OK_Static_Expression
(Val1
)
3146 or else not Is_OK_Static_Expression
(Val2
)
3148 Check
:= Make_Op_Ne
(Loc
,
3149 Left_Opnd
=> Duplicate_Subexpr
(Val1
),
3150 Right_Opnd
=> Duplicate_Subexpr
(Val2
));
3156 Cond
:= Make_Or_Else
(Loc
,
3158 Right_Opnd
=> Check
);
3161 elsif Expr_Value
(Val1
) /= Expr_Value
(Val2
) then
3162 Apply_Compile_Time_Constraint_Error
(Aggr
,
3163 Msg
=> "incorrect value for discriminant&??",
3164 Reason
=> CE_Discriminant_Check_Failed
,
3169 Next_Discriminant
(D
);
3174 -- If any discriminant constraint is non-static, emit a check
3176 if Present
(Cond
) then
3178 Make_Raise_Constraint_Error
(Loc
,
3180 Reason
=> CE_Discriminant_Check_Failed
));
3184 end Discriminants_Ok
;
3186 -- Start of processing for Convert_Aggr_In_Object_Decl
3189 Set_Assignment_OK
(Occ
);
3191 if Nkind
(Aggr
) = N_Qualified_Expression
then
3192 Aggr
:= Expression
(Aggr
);
3195 if Has_Discriminants
(Typ
)
3196 and then Typ
/= Etype
(Obj
)
3197 and then Is_Constrained
(Etype
(Obj
))
3198 and then not Discriminants_Ok
3203 -- If the context is an extended return statement, it has its own
3204 -- finalization machinery (i.e. works like a transient scope) and
3205 -- we do not want to create an additional one, because objects on
3206 -- the finalization list of the return must be moved to the caller's
3207 -- finalization list to complete the return.
3209 -- However, if the aggregate is limited, it is built in place, and the
3210 -- controlled components are not assigned to intermediate temporaries
3211 -- so there is no need for a transient scope in this case either.
3213 if Requires_Transient_Scope
(Typ
)
3214 and then Ekind
(Current_Scope
) /= E_Return_Statement
3215 and then not Is_Limited_Type
(Typ
)
3217 Establish_Transient_Scope
3220 Is_Controlled
(Typ
) or else Has_Controlled_Component
(Typ
));
3224 Node_After
: constant Node_Id
:= Next
(N
);
3226 Insert_Actions_After
(N
, Late_Expansion
(Aggr
, Typ
, Occ
));
3227 Collect_Initialization_Statements
(Obj
, N
, Node_After
);
3229 Set_No_Initialization
(N
);
3230 Initialize_Discriminants
(N
, Typ
);
3231 end Convert_Aggr_In_Object_Decl
;
3233 -------------------------------------
3234 -- Convert_Array_Aggr_In_Allocator --
3235 -------------------------------------
3237 procedure Convert_Array_Aggr_In_Allocator
3242 Aggr_Code
: List_Id
;
3243 Typ
: constant Entity_Id
:= Etype
(Aggr
);
3244 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
3247 -- The target is an explicit dereference of the allocated object.
3248 -- Generate component assignments to it, as for an aggregate that
3249 -- appears on the right-hand side of an assignment statement.
3252 Build_Array_Aggr_Code
(Aggr
,
3254 Index
=> First_Index
(Typ
),
3256 Scalar_Comp
=> Is_Scalar_Type
(Ctyp
));
3258 Insert_Actions_After
(Decl
, Aggr_Code
);
3259 end Convert_Array_Aggr_In_Allocator
;
3261 ----------------------------
3262 -- Convert_To_Assignments --
3263 ----------------------------
3265 procedure Convert_To_Assignments
(N
: Node_Id
; Typ
: Entity_Id
) is
3266 Loc
: constant Source_Ptr
:= Sloc
(N
);
3271 Target_Expr
: Node_Id
;
3272 Parent_Kind
: Node_Kind
;
3273 Unc_Decl
: Boolean := False;
3274 Parent_Node
: Node_Id
;
3277 pragma Assert
(not Is_Static_Dispatch_Table_Aggregate
(N
));
3278 pragma Assert
(Is_Record_Type
(Typ
));
3280 Parent_Node
:= Parent
(N
);
3281 Parent_Kind
:= Nkind
(Parent_Node
);
3283 if Parent_Kind
= N_Qualified_Expression
then
3285 -- Check if we are in a unconstrained declaration because in this
3286 -- case the current delayed expansion mechanism doesn't work when
3287 -- the declared object size depend on the initializing expr.
3290 Parent_Node
:= Parent
(Parent_Node
);
3291 Parent_Kind
:= Nkind
(Parent_Node
);
3293 if Parent_Kind
= N_Object_Declaration
then
3295 not Is_Entity_Name
(Object_Definition
(Parent_Node
))
3296 or else Has_Discriminants
3297 (Entity
(Object_Definition
(Parent_Node
)))
3298 or else Is_Class_Wide_Type
3299 (Entity
(Object_Definition
(Parent_Node
)));
3304 -- Just set the Delay flag in the cases where the transformation will be
3305 -- done top down from above.
3309 -- Internal aggregate (transformed when expanding the parent)
3311 or else Parent_Kind
= N_Aggregate
3312 or else Parent_Kind
= N_Extension_Aggregate
3313 or else Parent_Kind
= N_Component_Association
3315 -- Allocator (see Convert_Aggr_In_Allocator)
3317 or else Parent_Kind
= N_Allocator
3319 -- Object declaration (see Convert_Aggr_In_Object_Decl)
3321 or else (Parent_Kind
= N_Object_Declaration
and then not Unc_Decl
)
3323 -- Safe assignment (see Convert_Aggr_Assignments). So far only the
3324 -- assignments in init procs are taken into account.
3326 or else (Parent_Kind
= N_Assignment_Statement
3327 and then Inside_Init_Proc
)
3329 -- (Ada 2005) An inherently limited type in a return statement,
3330 -- which will be handled in a build-in-place fashion, and may be
3331 -- rewritten as an extended return and have its own finalization
3332 -- machinery. In the case of a simple return, the aggregate needs
3333 -- to be delayed until the scope for the return statement has been
3334 -- created, so that any finalization chain will be associated with
3335 -- that scope. For extended returns, we delay expansion to avoid the
3336 -- creation of an unwanted transient scope that could result in
3337 -- premature finalization of the return object (which is built in
3338 -- in place within the caller's scope).
3341 (Is_Immutably_Limited_Type
(Typ
)
3343 (Nkind
(Parent
(Parent_Node
)) = N_Extended_Return_Statement
3344 or else Nkind
(Parent_Node
) = N_Simple_Return_Statement
))
3346 Set_Expansion_Delayed
(N
);
3350 if Requires_Transient_Scope
(Typ
) then
3351 Establish_Transient_Scope
3353 Is_Controlled
(Typ
) or else Has_Controlled_Component
(Typ
));
3356 -- If the aggregate is non-limited, create a temporary. If it is limited
3357 -- and the context is an assignment, this is a subaggregate for an
3358 -- enclosing aggregate being expanded. It must be built in place, so use
3359 -- the target of the current assignment.
3361 if Is_Limited_Type
(Typ
)
3362 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
3364 Target_Expr
:= New_Copy_Tree
(Name
(Parent
(N
)));
3365 Insert_Actions
(Parent
(N
),
3366 Build_Record_Aggr_Code
(N
, Typ
, Target_Expr
));
3367 Rewrite
(Parent
(N
), Make_Null_Statement
(Loc
));
3370 Temp
:= Make_Temporary
(Loc
, 'A', N
);
3372 -- If the type inherits unknown discriminants, use the view with
3373 -- known discriminants if available.
3375 if Has_Unknown_Discriminants
(Typ
)
3376 and then Present
(Underlying_Record_View
(Typ
))
3378 T
:= Underlying_Record_View
(Typ
);
3384 Make_Object_Declaration
(Loc
,
3385 Defining_Identifier
=> Temp
,
3386 Object_Definition
=> New_Occurrence_Of
(T
, Loc
));
3388 Set_No_Initialization
(Instr
);
3389 Insert_Action
(N
, Instr
);
3390 Initialize_Discriminants
(Instr
, T
);
3391 Target_Expr
:= New_Occurrence_Of
(Temp
, Loc
);
3392 Insert_Actions
(N
, Build_Record_Aggr_Code
(N
, T
, Target_Expr
));
3393 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3394 Analyze_And_Resolve
(N
, T
);
3396 end Convert_To_Assignments
;
3398 ---------------------------
3399 -- Convert_To_Positional --
3400 ---------------------------
3402 procedure Convert_To_Positional
3404 Max_Others_Replicate
: Nat
:= 5;
3405 Handle_Bit_Packed
: Boolean := False)
3407 Typ
: constant Entity_Id
:= Etype
(N
);
3409 Static_Components
: Boolean := True;
3411 procedure Check_Static_Components
;
3412 -- Check whether all components of the aggregate are compile-time known
3413 -- values, and can be passed as is to the back-end without further
3419 Ixb
: Node_Id
) return Boolean;
3420 -- Convert the aggregate into a purely positional form if possible. On
3421 -- entry the bounds of all dimensions are known to be static, and the
3422 -- total number of components is safe enough to expand.
3424 function Is_Flat
(N
: Node_Id
; Dims
: Int
) return Boolean;
3425 -- Return True iff the array N is flat (which is not trivial in the case
3426 -- of multidimensional aggregates).
3428 -----------------------------
3429 -- Check_Static_Components --
3430 -----------------------------
3432 procedure Check_Static_Components
is
3436 Static_Components
:= True;
3438 if Nkind
(N
) = N_String_Literal
then
3441 elsif Present
(Expressions
(N
)) then
3442 Expr
:= First
(Expressions
(N
));
3443 while Present
(Expr
) loop
3444 if Nkind
(Expr
) /= N_Aggregate
3445 or else not Compile_Time_Known_Aggregate
(Expr
)
3446 or else Expansion_Delayed
(Expr
)
3448 Static_Components
:= False;
3456 if Nkind
(N
) = N_Aggregate
3457 and then Present
(Component_Associations
(N
))
3459 Expr
:= First
(Component_Associations
(N
));
3460 while Present
(Expr
) loop
3461 if Nkind_In
(Expression
(Expr
), N_Integer_Literal
,
3466 elsif Is_Entity_Name
(Expression
(Expr
))
3467 and then Present
(Entity
(Expression
(Expr
)))
3468 and then Ekind
(Entity
(Expression
(Expr
))) =
3469 E_Enumeration_Literal
3473 elsif Nkind
(Expression
(Expr
)) /= N_Aggregate
3474 or else not Compile_Time_Known_Aggregate
(Expression
(Expr
))
3475 or else Expansion_Delayed
(Expression
(Expr
))
3477 Static_Components
:= False;
3484 end Check_Static_Components
;
3493 Ixb
: Node_Id
) return Boolean
3495 Loc
: constant Source_Ptr
:= Sloc
(N
);
3496 Blo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Ixb
));
3497 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Ix
));
3498 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Ix
));
3502 Others_Present
: Boolean := False;
3505 if Nkind
(Original_Node
(N
)) = N_String_Literal
then
3509 if not Compile_Time_Known_Value
(Lo
)
3510 or else not Compile_Time_Known_Value
(Hi
)
3515 Lov
:= Expr_Value
(Lo
);
3516 Hiv
:= Expr_Value
(Hi
);
3518 -- Check if there is an others choice
3520 if Present
(Component_Associations
(N
)) then
3526 Assoc
:= First
(Component_Associations
(N
));
3527 while Present
(Assoc
) loop
3529 -- If this is a box association, flattening is in general
3530 -- not possible because at this point we cannot tell if the
3531 -- default is static or even exists.
3533 if Box_Present
(Assoc
) then
3537 Choice
:= First
(Choices
(Assoc
));
3539 while Present
(Choice
) loop
3540 if Nkind
(Choice
) = N_Others_Choice
then
3541 Others_Present
:= True;
3552 -- If the low bound is not known at compile time and others is not
3553 -- present we can proceed since the bounds can be obtained from the
3556 -- Note: This case is required in VM platforms since their backends
3557 -- normalize array indexes in the range 0 .. N-1. Hence, if we do
3558 -- not flat an array whose bounds cannot be obtained from the type
3559 -- of the index the backend has no way to properly generate the code.
3560 -- See ACATS c460010 for an example.
3563 or else (not Compile_Time_Known_Value
(Blo
)
3564 and then Others_Present
)
3569 -- Determine if set of alternatives is suitable for conversion and
3570 -- build an array containing the values in sequence.
3573 Vals
: array (UI_To_Int
(Lov
) .. UI_To_Int
(Hiv
))
3574 of Node_Id
:= (others => Empty
);
3575 -- The values in the aggregate sorted appropriately
3578 -- Same data as Vals in list form
3581 -- Used to validate Max_Others_Replicate limit
3584 Num
: Int
:= UI_To_Int
(Lov
);
3590 if Present
(Expressions
(N
)) then
3591 Elmt
:= First
(Expressions
(N
));
3592 while Present
(Elmt
) loop
3593 if Nkind
(Elmt
) = N_Aggregate
3594 and then Present
(Next_Index
(Ix
))
3596 not Flatten
(Elmt
, Next_Index
(Ix
), Next_Index
(Ixb
))
3601 Vals
(Num
) := Relocate_Node
(Elmt
);
3608 if No
(Component_Associations
(N
)) then
3612 Elmt
:= First
(Component_Associations
(N
));
3614 if Nkind
(Expression
(Elmt
)) = N_Aggregate
then
3615 if Present
(Next_Index
(Ix
))
3618 (Expression
(Elmt
), Next_Index
(Ix
), Next_Index
(Ixb
))
3624 Component_Loop
: while Present
(Elmt
) loop
3625 Choice
:= First
(Choices
(Elmt
));
3626 Choice_Loop
: while Present
(Choice
) loop
3628 -- If we have an others choice, fill in the missing elements
3629 -- subject to the limit established by Max_Others_Replicate.
3631 if Nkind
(Choice
) = N_Others_Choice
then
3634 for J
in Vals
'Range loop
3635 if No
(Vals
(J
)) then
3636 Vals
(J
) := New_Copy_Tree
(Expression
(Elmt
));
3637 Rep_Count
:= Rep_Count
+ 1;
3639 -- Check for maximum others replication. Note that
3640 -- we skip this test if either of the restrictions
3641 -- No_Elaboration_Code or No_Implicit_Loops is
3642 -- active, if this is a preelaborable unit or
3643 -- a predefined unit, or if the unit must be
3644 -- placed in data memory. This also ensures that
3645 -- predefined units get the same level of constant
3646 -- folding in Ada 95 and Ada 2005, where their
3647 -- categorization has changed.
3650 P
: constant Entity_Id
:=
3651 Cunit_Entity
(Current_Sem_Unit
);
3654 -- Check if duplication OK and if so continue
3657 if Restriction_Active
(No_Elaboration_Code
)
3658 or else Restriction_Active
(No_Implicit_Loops
)
3660 (Ekind
(Current_Scope
) = E_Package
3662 Static_Elaboration_Desired
3664 or else Is_Preelaborated
(P
)
3665 or else (Ekind
(P
) = E_Package_Body
3667 Is_Preelaborated
(Spec_Entity
(P
)))
3669 Is_Predefined_File_Name
3670 (Unit_File_Name
(Get_Source_Unit
(P
)))
3674 -- If duplication not OK, then we return False
3675 -- if the replication count is too high
3677 elsif Rep_Count
> Max_Others_Replicate
then
3680 -- Continue on if duplication not OK, but the
3681 -- replication count is not excessive.
3690 exit Component_Loop
;
3692 -- Case of a subtype mark, identifier or expanded name
3694 elsif Is_Entity_Name
(Choice
)
3695 and then Is_Type
(Entity
(Choice
))
3697 Lo
:= Type_Low_Bound
(Etype
(Choice
));
3698 Hi
:= Type_High_Bound
(Etype
(Choice
));
3700 -- Case of subtype indication
3702 elsif Nkind
(Choice
) = N_Subtype_Indication
then
3703 Lo
:= Low_Bound
(Range_Expression
(Constraint
(Choice
)));
3704 Hi
:= High_Bound
(Range_Expression
(Constraint
(Choice
)));
3708 elsif Nkind
(Choice
) = N_Range
then
3709 Lo
:= Low_Bound
(Choice
);
3710 Hi
:= High_Bound
(Choice
);
3712 -- Normal subexpression case
3714 else pragma Assert
(Nkind
(Choice
) in N_Subexpr
);
3715 if not Compile_Time_Known_Value
(Choice
) then
3719 Choice_Index
:= UI_To_Int
(Expr_Value
(Choice
));
3720 if Choice_Index
in Vals
'Range then
3721 Vals
(Choice_Index
) :=
3722 New_Copy_Tree
(Expression
(Elmt
));
3726 -- Choice is statically out-of-range, will be
3727 -- rewritten to raise Constraint_Error.
3734 -- Range cases merge with Lo,Hi set
3736 if not Compile_Time_Known_Value
(Lo
)
3738 not Compile_Time_Known_Value
(Hi
)
3742 for J
in UI_To_Int
(Expr_Value
(Lo
)) ..
3743 UI_To_Int
(Expr_Value
(Hi
))
3745 Vals
(J
) := New_Copy_Tree
(Expression
(Elmt
));
3751 end loop Choice_Loop
;
3754 end loop Component_Loop
;
3756 -- If we get here the conversion is possible
3759 for J
in Vals
'Range loop
3760 Append
(Vals
(J
), Vlist
);
3763 Rewrite
(N
, Make_Aggregate
(Loc
, Expressions
=> Vlist
));
3764 Set_Aggregate_Bounds
(N
, Aggregate_Bounds
(Original_Node
(N
)));
3773 function Is_Flat
(N
: Node_Id
; Dims
: Int
) return Boolean is
3780 elsif Nkind
(N
) = N_Aggregate
then
3781 if Present
(Component_Associations
(N
)) then
3785 Elmt
:= First
(Expressions
(N
));
3786 while Present
(Elmt
) loop
3787 if not Is_Flat
(Elmt
, Dims
- 1) then
3801 -- Start of processing for Convert_To_Positional
3804 -- Ada 2005 (AI-287): Do not convert in case of default initialized
3805 -- components because in this case will need to call the corresponding
3808 if Has_Default_Init_Comps
(N
) then
3812 if Is_Flat
(N
, Number_Dimensions
(Typ
)) then
3816 if Is_Bit_Packed_Array
(Typ
)
3817 and then not Handle_Bit_Packed
3822 -- Do not convert to positional if controlled components are involved
3823 -- since these require special processing
3825 if Has_Controlled_Component
(Typ
) then
3829 Check_Static_Components
;
3831 -- If the size is known, or all the components are static, try to
3832 -- build a fully positional aggregate.
3834 -- The size of the type may not be known for an aggregate with
3835 -- discriminated array components, but if the components are static
3836 -- it is still possible to verify statically that the length is
3837 -- compatible with the upper bound of the type, and therefore it is
3838 -- worth flattening such aggregates as well.
3840 -- For now the back-end expands these aggregates into individual
3841 -- assignments to the target anyway, but it is conceivable that
3842 -- it will eventually be able to treat such aggregates statically???
3844 if Aggr_Size_OK
(N
, Typ
)
3845 and then Flatten
(N
, First_Index
(Typ
), First_Index
(Base_Type
(Typ
)))
3847 if Static_Components
then
3848 Set_Compile_Time_Known_Aggregate
(N
);
3849 Set_Expansion_Delayed
(N
, False);
3852 Analyze_And_Resolve
(N
, Typ
);
3855 -- Is Static_Eaboration_Desired has been specified, diagnose aggregates
3856 -- that will still require initialization code.
3858 if (Ekind
(Current_Scope
) = E_Package
3859 and then Static_Elaboration_Desired
(Current_Scope
))
3860 and then Nkind
(Parent
(N
)) = N_Object_Declaration
3866 if Nkind
(N
) = N_Aggregate
and then Present
(Expressions
(N
)) then
3867 Expr
:= First
(Expressions
(N
));
3868 while Present
(Expr
) loop
3869 if Nkind_In
(Expr
, N_Integer_Literal
, N_Real_Literal
)
3871 (Is_Entity_Name
(Expr
)
3872 and then Ekind
(Entity
(Expr
)) = E_Enumeration_Literal
)
3878 ("non-static object requires elaboration code??", N
);
3885 if Present
(Component_Associations
(N
)) then
3886 Error_Msg_N
("object requires elaboration code??", N
);
3891 end Convert_To_Positional
;
3893 ----------------------------
3894 -- Expand_Array_Aggregate --
3895 ----------------------------
3897 -- Array aggregate expansion proceeds as follows:
3899 -- 1. If requested we generate code to perform all the array aggregate
3900 -- bound checks, specifically
3902 -- (a) Check that the index range defined by aggregate bounds is
3903 -- compatible with corresponding index subtype.
3905 -- (b) If an others choice is present check that no aggregate
3906 -- index is outside the bounds of the index constraint.
3908 -- (c) For multidimensional arrays make sure that all subaggregates
3909 -- corresponding to the same dimension have the same bounds.
3911 -- 2. Check for packed array aggregate which can be converted to a
3912 -- constant so that the aggregate disappeares completely.
3914 -- 3. Check case of nested aggregate. Generally nested aggregates are
3915 -- handled during the processing of the parent aggregate.
3917 -- 4. Check if the aggregate can be statically processed. If this is the
3918 -- case pass it as is to Gigi. Note that a necessary condition for
3919 -- static processing is that the aggregate be fully positional.
3921 -- 5. If in place aggregate expansion is possible (i.e. no need to create
3922 -- a temporary) then mark the aggregate as such and return. Otherwise
3923 -- create a new temporary and generate the appropriate initialization
3926 procedure Expand_Array_Aggregate
(N
: Node_Id
) is
3927 Loc
: constant Source_Ptr
:= Sloc
(N
);
3929 Typ
: constant Entity_Id
:= Etype
(N
);
3930 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
3931 -- Typ is the correct constrained array subtype of the aggregate
3932 -- Ctyp is the corresponding component type.
3934 Aggr_Dimension
: constant Pos
:= Number_Dimensions
(Typ
);
3935 -- Number of aggregate index dimensions
3937 Aggr_Low
: array (1 .. Aggr_Dimension
) of Node_Id
;
3938 Aggr_High
: array (1 .. Aggr_Dimension
) of Node_Id
;
3939 -- Low and High bounds of the constraint for each aggregate index
3941 Aggr_Index_Typ
: array (1 .. Aggr_Dimension
) of Entity_Id
;
3942 -- The type of each index
3944 Maybe_In_Place_OK
: Boolean;
3945 -- If the type is neither controlled nor packed and the aggregate
3946 -- is the expression in an assignment, assignment in place may be
3947 -- possible, provided other conditions are met on the LHS.
3949 Others_Present
: array (1 .. Aggr_Dimension
) of Boolean :=
3951 -- If Others_Present (J) is True, then there is an others choice
3952 -- in one of the sub-aggregates of N at dimension J.
3954 procedure Build_Constrained_Type
(Positional
: Boolean);
3955 -- If the subtype is not static or unconstrained, build a constrained
3956 -- type using the computable sizes of the aggregate and its sub-
3959 procedure Check_Bounds
(Aggr_Bounds
: Node_Id
; Index_Bounds
: Node_Id
);
3960 -- Checks that the bounds of Aggr_Bounds are within the bounds defined
3963 procedure Check_Same_Aggr_Bounds
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3964 -- Checks that in a multi-dimensional array aggregate all subaggregates
3965 -- corresponding to the same dimension have the same bounds.
3966 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3967 -- corresponding to the sub-aggregate.
3969 procedure Compute_Others_Present
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3970 -- Computes the values of array Others_Present. Sub_Aggr is the
3971 -- array sub-aggregate we start the computation from. Dim is the
3972 -- dimension corresponding to the sub-aggregate.
3974 function In_Place_Assign_OK
return Boolean;
3975 -- Simple predicate to determine whether an aggregate assignment can
3976 -- be done in place, because none of the new values can depend on the
3977 -- components of the target of the assignment.
3979 procedure Others_Check
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3980 -- Checks that if an others choice is present in any sub-aggregate no
3981 -- aggregate index is outside the bounds of the index constraint.
3982 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3983 -- corresponding to the sub-aggregate.
3985 function Safe_Left_Hand_Side
(N
: Node_Id
) return Boolean;
3986 -- In addition to Maybe_In_Place_OK, in order for an aggregate to be
3987 -- built directly into the target of the assignment it must be free
3990 ----------------------------
3991 -- Build_Constrained_Type --
3992 ----------------------------
3994 procedure Build_Constrained_Type
(Positional
: Boolean) is
3995 Loc
: constant Source_Ptr
:= Sloc
(N
);
3996 Agg_Type
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
3999 Typ
: constant Entity_Id
:= Etype
(N
);
4000 Indexes
: constant List_Id
:= New_List
;
4005 -- If the aggregate is purely positional, all its subaggregates
4006 -- have the same size. We collect the dimensions from the first
4007 -- subaggregate at each level.
4012 for D
in 1 .. Number_Dimensions
(Typ
) loop
4013 Sub_Agg
:= First
(Expressions
(Sub_Agg
));
4017 while Present
(Comp
) loop
4024 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
4025 High_Bound
=> Make_Integer_Literal
(Loc
, Num
)));
4029 -- We know the aggregate type is unconstrained and the aggregate
4030 -- is not processable by the back end, therefore not necessarily
4031 -- positional. Retrieve each dimension bounds (computed earlier).
4033 for D
in 1 .. Number_Dimensions
(Typ
) loop
4036 Low_Bound
=> Aggr_Low
(D
),
4037 High_Bound
=> Aggr_High
(D
)),
4043 Make_Full_Type_Declaration
(Loc
,
4044 Defining_Identifier
=> Agg_Type
,
4046 Make_Constrained_Array_Definition
(Loc
,
4047 Discrete_Subtype_Definitions
=> Indexes
,
4048 Component_Definition
=>
4049 Make_Component_Definition
(Loc
,
4050 Aliased_Present
=> False,
4051 Subtype_Indication
=>
4052 New_Occurrence_Of
(Component_Type
(Typ
), Loc
))));
4054 Insert_Action
(N
, Decl
);
4056 Set_Etype
(N
, Agg_Type
);
4057 Set_Is_Itype
(Agg_Type
);
4058 Freeze_Itype
(Agg_Type
, N
);
4059 end Build_Constrained_Type
;
4065 procedure Check_Bounds
(Aggr_Bounds
: Node_Id
; Index_Bounds
: Node_Id
) is
4072 Cond
: Node_Id
:= Empty
;
4075 Get_Index_Bounds
(Aggr_Bounds
, Aggr_Lo
, Aggr_Hi
);
4076 Get_Index_Bounds
(Index_Bounds
, Ind_Lo
, Ind_Hi
);
4078 -- Generate the following test:
4080 -- [constraint_error when
4081 -- Aggr_Lo <= Aggr_Hi and then
4082 -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
4084 -- As an optimization try to see if some tests are trivially vacuous
4085 -- because we are comparing an expression against itself.
4087 if Aggr_Lo
= Ind_Lo
and then Aggr_Hi
= Ind_Hi
then
4090 elsif Aggr_Hi
= Ind_Hi
then
4093 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
4094 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Lo
));
4096 elsif Aggr_Lo
= Ind_Lo
then
4099 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
),
4100 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Hi
));
4107 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
4108 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Lo
)),
4112 Left_Opnd
=> Duplicate_Subexpr
(Aggr_Hi
),
4113 Right_Opnd
=> Duplicate_Subexpr
(Ind_Hi
)));
4116 if Present
(Cond
) then
4121 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
4122 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
)),
4124 Right_Opnd
=> Cond
);
4126 Set_Analyzed
(Left_Opnd
(Left_Opnd
(Cond
)), False);
4127 Set_Analyzed
(Right_Opnd
(Left_Opnd
(Cond
)), False);
4129 Make_Raise_Constraint_Error
(Loc
,
4131 Reason
=> CE_Length_Check_Failed
));
4135 ----------------------------
4136 -- Check_Same_Aggr_Bounds --
4137 ----------------------------
4139 procedure Check_Same_Aggr_Bounds
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
4140 Sub_Lo
: constant Node_Id
:= Low_Bound
(Aggregate_Bounds
(Sub_Aggr
));
4141 Sub_Hi
: constant Node_Id
:= High_Bound
(Aggregate_Bounds
(Sub_Aggr
));
4142 -- The bounds of this specific sub-aggregate
4144 Aggr_Lo
: constant Node_Id
:= Aggr_Low
(Dim
);
4145 Aggr_Hi
: constant Node_Id
:= Aggr_High
(Dim
);
4146 -- The bounds of the aggregate for this dimension
4148 Ind_Typ
: constant Entity_Id
:= Aggr_Index_Typ
(Dim
);
4149 -- The index type for this dimension.xxx
4151 Cond
: Node_Id
:= Empty
;
4156 -- If index checks are on generate the test
4158 -- [constraint_error when
4159 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
4161 -- As an optimization try to see if some tests are trivially vacuos
4162 -- because we are comparing an expression against itself. Also for
4163 -- the first dimension the test is trivially vacuous because there
4164 -- is just one aggregate for dimension 1.
4166 if Index_Checks_Suppressed
(Ind_Typ
) then
4170 or else (Aggr_Lo
= Sub_Lo
and then Aggr_Hi
= Sub_Hi
)
4174 elsif Aggr_Hi
= Sub_Hi
then
4177 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
4178 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Lo
));
4180 elsif Aggr_Lo
= Sub_Lo
then
4183 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
),
4184 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Hi
));
4191 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
4192 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Lo
)),
4196 Left_Opnd
=> Duplicate_Subexpr
(Aggr_Hi
),
4197 Right_Opnd
=> Duplicate_Subexpr
(Sub_Hi
)));
4200 if Present
(Cond
) then
4202 Make_Raise_Constraint_Error
(Loc
,
4204 Reason
=> CE_Length_Check_Failed
));
4207 -- Now look inside the sub-aggregate to see if there is more work
4209 if Dim
< Aggr_Dimension
then
4211 -- Process positional components
4213 if Present
(Expressions
(Sub_Aggr
)) then
4214 Expr
:= First
(Expressions
(Sub_Aggr
));
4215 while Present
(Expr
) loop
4216 Check_Same_Aggr_Bounds
(Expr
, Dim
+ 1);
4221 -- Process component associations
4223 if Present
(Component_Associations
(Sub_Aggr
)) then
4224 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4225 while Present
(Assoc
) loop
4226 Expr
:= Expression
(Assoc
);
4227 Check_Same_Aggr_Bounds
(Expr
, Dim
+ 1);
4232 end Check_Same_Aggr_Bounds
;
4234 ----------------------------
4235 -- Compute_Others_Present --
4236 ----------------------------
4238 procedure Compute_Others_Present
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
4243 if Present
(Component_Associations
(Sub_Aggr
)) then
4244 Assoc
:= Last
(Component_Associations
(Sub_Aggr
));
4246 if Nkind
(First
(Choices
(Assoc
))) = N_Others_Choice
then
4247 Others_Present
(Dim
) := True;
4251 -- Now look inside the sub-aggregate to see if there is more work
4253 if Dim
< Aggr_Dimension
then
4255 -- Process positional components
4257 if Present
(Expressions
(Sub_Aggr
)) then
4258 Expr
:= First
(Expressions
(Sub_Aggr
));
4259 while Present
(Expr
) loop
4260 Compute_Others_Present
(Expr
, Dim
+ 1);
4265 -- Process component associations
4267 if Present
(Component_Associations
(Sub_Aggr
)) then
4268 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4269 while Present
(Assoc
) loop
4270 Expr
:= Expression
(Assoc
);
4271 Compute_Others_Present
(Expr
, Dim
+ 1);
4276 end Compute_Others_Present
;
4278 ------------------------
4279 -- In_Place_Assign_OK --
4280 ------------------------
4282 function In_Place_Assign_OK
return Boolean is
4290 function Safe_Aggregate
(Aggr
: Node_Id
) return Boolean;
4291 -- Check recursively that each component of a (sub)aggregate does
4292 -- not depend on the variable being assigned to.
4294 function Safe_Component
(Expr
: Node_Id
) return Boolean;
4295 -- Verify that an expression cannot depend on the variable being
4296 -- assigned to. Room for improvement here (but less than before).
4298 --------------------
4299 -- Safe_Aggregate --
4300 --------------------
4302 function Safe_Aggregate
(Aggr
: Node_Id
) return Boolean is
4306 if Present
(Expressions
(Aggr
)) then
4307 Expr
:= First
(Expressions
(Aggr
));
4308 while Present
(Expr
) loop
4309 if Nkind
(Expr
) = N_Aggregate
then
4310 if not Safe_Aggregate
(Expr
) then
4314 elsif not Safe_Component
(Expr
) then
4322 if Present
(Component_Associations
(Aggr
)) then
4323 Expr
:= First
(Component_Associations
(Aggr
));
4324 while Present
(Expr
) loop
4325 if Nkind
(Expression
(Expr
)) = N_Aggregate
then
4326 if not Safe_Aggregate
(Expression
(Expr
)) then
4330 -- If association has a box, no way to determine yet
4331 -- whether default can be assigned in place.
4333 elsif Box_Present
(Expr
) then
4336 elsif not Safe_Component
(Expression
(Expr
)) then
4347 --------------------
4348 -- Safe_Component --
4349 --------------------
4351 function Safe_Component
(Expr
: Node_Id
) return Boolean is
4352 Comp
: Node_Id
:= Expr
;
4354 function Check_Component
(Comp
: Node_Id
) return Boolean;
4355 -- Do the recursive traversal, after copy
4357 ---------------------
4358 -- Check_Component --
4359 ---------------------
4361 function Check_Component
(Comp
: Node_Id
) return Boolean is
4363 if Is_Overloaded
(Comp
) then
4367 return Compile_Time_Known_Value
(Comp
)
4369 or else (Is_Entity_Name
(Comp
)
4370 and then Present
(Entity
(Comp
))
4371 and then No
(Renamed_Object
(Entity
(Comp
))))
4373 or else (Nkind
(Comp
) = N_Attribute_Reference
4374 and then Check_Component
(Prefix
(Comp
)))
4376 or else (Nkind
(Comp
) in N_Binary_Op
4377 and then Check_Component
(Left_Opnd
(Comp
))
4378 and then Check_Component
(Right_Opnd
(Comp
)))
4380 or else (Nkind
(Comp
) in N_Unary_Op
4381 and then Check_Component
(Right_Opnd
(Comp
)))
4383 or else (Nkind
(Comp
) = N_Selected_Component
4384 and then Check_Component
(Prefix
(Comp
)))
4386 or else (Nkind
(Comp
) = N_Unchecked_Type_Conversion
4387 and then Check_Component
(Expression
(Comp
)));
4388 end Check_Component
;
4390 -- Start of processing for Safe_Component
4393 -- If the component appears in an association that may
4394 -- correspond to more than one element, it is not analyzed
4395 -- before the expansion into assignments, to avoid side effects.
4396 -- We analyze, but do not resolve the copy, to obtain sufficient
4397 -- entity information for the checks that follow. If component is
4398 -- overloaded we assume an unsafe function call.
4400 if not Analyzed
(Comp
) then
4401 if Is_Overloaded
(Expr
) then
4404 elsif Nkind
(Expr
) = N_Aggregate
4405 and then not Is_Others_Aggregate
(Expr
)
4409 elsif Nkind
(Expr
) = N_Allocator
then
4411 -- For now, too complex to analyze
4416 Comp
:= New_Copy_Tree
(Expr
);
4417 Set_Parent
(Comp
, Parent
(Expr
));
4421 if Nkind
(Comp
) = N_Aggregate
then
4422 return Safe_Aggregate
(Comp
);
4424 return Check_Component
(Comp
);
4428 -- Start of processing for In_Place_Assign_OK
4431 if Present
(Component_Associations
(N
)) then
4433 -- On assignment, sliding can take place, so we cannot do the
4434 -- assignment in place unless the bounds of the aggregate are
4435 -- statically equal to those of the target.
4437 -- If the aggregate is given by an others choice, the bounds
4438 -- are derived from the left-hand side, and the assignment is
4439 -- safe if the expression is.
4441 if Is_Others_Aggregate
(N
) then
4444 (Expression
(First
(Component_Associations
(N
))));
4447 Aggr_In
:= First_Index
(Etype
(N
));
4449 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4450 Obj_In
:= First_Index
(Etype
(Name
(Parent
(N
))));
4453 -- Context is an allocator. Check bounds of aggregate
4454 -- against given type in qualified expression.
4456 pragma Assert
(Nkind
(Parent
(Parent
(N
))) = N_Allocator
);
4458 First_Index
(Etype
(Entity
(Subtype_Mark
(Parent
(N
)))));
4461 while Present
(Aggr_In
) loop
4462 Get_Index_Bounds
(Aggr_In
, Aggr_Lo
, Aggr_Hi
);
4463 Get_Index_Bounds
(Obj_In
, Obj_Lo
, Obj_Hi
);
4465 if not Compile_Time_Known_Value
(Aggr_Lo
)
4466 or else not Compile_Time_Known_Value
(Aggr_Hi
)
4467 or else not Compile_Time_Known_Value
(Obj_Lo
)
4468 or else not Compile_Time_Known_Value
(Obj_Hi
)
4469 or else Expr_Value
(Aggr_Lo
) /= Expr_Value
(Obj_Lo
)
4470 or else Expr_Value
(Aggr_Hi
) /= Expr_Value
(Obj_Hi
)
4475 Next_Index
(Aggr_In
);
4476 Next_Index
(Obj_In
);
4480 -- Now check the component values themselves
4482 return Safe_Aggregate
(N
);
4483 end In_Place_Assign_OK
;
4489 procedure Others_Check
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
4490 Aggr_Lo
: constant Node_Id
:= Aggr_Low
(Dim
);
4491 Aggr_Hi
: constant Node_Id
:= Aggr_High
(Dim
);
4492 -- The bounds of the aggregate for this dimension
4494 Ind_Typ
: constant Entity_Id
:= Aggr_Index_Typ
(Dim
);
4495 -- The index type for this dimension
4497 Need_To_Check
: Boolean := False;
4499 Choices_Lo
: Node_Id
:= Empty
;
4500 Choices_Hi
: Node_Id
:= Empty
;
4501 -- The lowest and highest discrete choices for a named sub-aggregate
4503 Nb_Choices
: Int
:= -1;
4504 -- The number of discrete non-others choices in this sub-aggregate
4506 Nb_Elements
: Uint
:= Uint_0
;
4507 -- The number of elements in a positional aggregate
4509 Cond
: Node_Id
:= Empty
;
4516 -- Check if we have an others choice. If we do make sure that this
4517 -- sub-aggregate contains at least one element in addition to the
4520 if Range_Checks_Suppressed
(Ind_Typ
) then
4521 Need_To_Check
:= False;
4523 elsif Present
(Expressions
(Sub_Aggr
))
4524 and then Present
(Component_Associations
(Sub_Aggr
))
4526 Need_To_Check
:= True;
4528 elsif Present
(Component_Associations
(Sub_Aggr
)) then
4529 Assoc
:= Last
(Component_Associations
(Sub_Aggr
));
4531 if Nkind
(First
(Choices
(Assoc
))) /= N_Others_Choice
then
4532 Need_To_Check
:= False;
4535 -- Count the number of discrete choices. Start with -1 because
4536 -- the others choice does not count.
4539 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4540 while Present
(Assoc
) loop
4541 Choice
:= First
(Choices
(Assoc
));
4542 while Present
(Choice
) loop
4543 Nb_Choices
:= Nb_Choices
+ 1;
4550 -- If there is only an others choice nothing to do
4552 Need_To_Check
:= (Nb_Choices
> 0);
4556 Need_To_Check
:= False;
4559 -- If we are dealing with a positional sub-aggregate with an others
4560 -- choice then compute the number or positional elements.
4562 if Need_To_Check
and then Present
(Expressions
(Sub_Aggr
)) then
4563 Expr
:= First
(Expressions
(Sub_Aggr
));
4564 Nb_Elements
:= Uint_0
;
4565 while Present
(Expr
) loop
4566 Nb_Elements
:= Nb_Elements
+ 1;
4570 -- If the aggregate contains discrete choices and an others choice
4571 -- compute the smallest and largest discrete choice values.
4573 elsif Need_To_Check
then
4574 Compute_Choices_Lo_And_Choices_Hi
: declare
4576 Table
: Case_Table_Type
(1 .. Nb_Choices
);
4577 -- Used to sort all the different choice values
4584 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4585 while Present
(Assoc
) loop
4586 Choice
:= First
(Choices
(Assoc
));
4587 while Present
(Choice
) loop
4588 if Nkind
(Choice
) = N_Others_Choice
then
4592 Get_Index_Bounds
(Choice
, Low
, High
);
4593 Table
(J
).Choice_Lo
:= Low
;
4594 Table
(J
).Choice_Hi
:= High
;
4603 -- Sort the discrete choices
4605 Sort_Case_Table
(Table
);
4607 Choices_Lo
:= Table
(1).Choice_Lo
;
4608 Choices_Hi
:= Table
(Nb_Choices
).Choice_Hi
;
4609 end Compute_Choices_Lo_And_Choices_Hi
;
4612 -- If no others choice in this sub-aggregate, or the aggregate
4613 -- comprises only an others choice, nothing to do.
4615 if not Need_To_Check
then
4618 -- If we are dealing with an aggregate containing an others choice
4619 -- and positional components, we generate the following test:
4621 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
4622 -- Ind_Typ'Pos (Aggr_Hi)
4624 -- raise Constraint_Error;
4627 elsif Nb_Elements
> Uint_0
then
4633 Make_Attribute_Reference
(Loc
,
4634 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
4635 Attribute_Name
=> Name_Pos
,
4638 (Duplicate_Subexpr_Move_Checks
(Aggr_Lo
))),
4639 Right_Opnd
=> Make_Integer_Literal
(Loc
, Nb_Elements
- 1)),
4642 Make_Attribute_Reference
(Loc
,
4643 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
4644 Attribute_Name
=> Name_Pos
,
4645 Expressions
=> New_List
(
4646 Duplicate_Subexpr_Move_Checks
(Aggr_Hi
))));
4648 -- If we are dealing with an aggregate containing an others choice
4649 -- and discrete choices we generate the following test:
4651 -- [constraint_error when
4652 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
4660 Duplicate_Subexpr_Move_Checks
(Choices_Lo
),
4662 Duplicate_Subexpr_Move_Checks
(Aggr_Lo
)),
4667 Duplicate_Subexpr
(Choices_Hi
),
4669 Duplicate_Subexpr
(Aggr_Hi
)));
4672 if Present
(Cond
) then
4674 Make_Raise_Constraint_Error
(Loc
,
4676 Reason
=> CE_Length_Check_Failed
));
4677 -- Questionable reason code, shouldn't that be a
4678 -- CE_Range_Check_Failed ???
4681 -- Now look inside the sub-aggregate to see if there is more work
4683 if Dim
< Aggr_Dimension
then
4685 -- Process positional components
4687 if Present
(Expressions
(Sub_Aggr
)) then
4688 Expr
:= First
(Expressions
(Sub_Aggr
));
4689 while Present
(Expr
) loop
4690 Others_Check
(Expr
, Dim
+ 1);
4695 -- Process component associations
4697 if Present
(Component_Associations
(Sub_Aggr
)) then
4698 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4699 while Present
(Assoc
) loop
4700 Expr
:= Expression
(Assoc
);
4701 Others_Check
(Expr
, Dim
+ 1);
4708 -------------------------
4709 -- Safe_Left_Hand_Side --
4710 -------------------------
4712 function Safe_Left_Hand_Side
(N
: Node_Id
) return Boolean is
4713 function Is_Safe_Index
(Indx
: Node_Id
) return Boolean;
4714 -- If the left-hand side includes an indexed component, check that
4715 -- the indexes are free of side-effect.
4721 function Is_Safe_Index
(Indx
: Node_Id
) return Boolean is
4723 if Is_Entity_Name
(Indx
) then
4726 elsif Nkind
(Indx
) = N_Integer_Literal
then
4729 elsif Nkind
(Indx
) = N_Function_Call
4730 and then Is_Entity_Name
(Name
(Indx
))
4732 Has_Pragma_Pure_Function
(Entity
(Name
(Indx
)))
4736 elsif Nkind
(Indx
) = N_Type_Conversion
4737 and then Is_Safe_Index
(Expression
(Indx
))
4746 -- Start of processing for Safe_Left_Hand_Side
4749 if Is_Entity_Name
(N
) then
4752 elsif Nkind_In
(N
, N_Explicit_Dereference
, N_Selected_Component
)
4753 and then Safe_Left_Hand_Side
(Prefix
(N
))
4757 elsif Nkind
(N
) = N_Indexed_Component
4758 and then Safe_Left_Hand_Side
(Prefix
(N
))
4760 Is_Safe_Index
(First
(Expressions
(N
)))
4764 elsif Nkind
(N
) = N_Unchecked_Type_Conversion
then
4765 return Safe_Left_Hand_Side
(Expression
(N
));
4770 end Safe_Left_Hand_Side
;
4775 -- Holds the temporary aggregate value
4778 -- Holds the declaration of Tmp
4780 Aggr_Code
: List_Id
;
4781 Parent_Node
: Node_Id
;
4782 Parent_Kind
: Node_Kind
;
4784 -- Start of processing for Expand_Array_Aggregate
4787 -- Do not touch the special aggregates of attributes used for Asm calls
4789 if Is_RTE
(Ctyp
, RE_Asm_Input_Operand
)
4790 or else Is_RTE
(Ctyp
, RE_Asm_Output_Operand
)
4794 -- Do not expand an aggregate for an array type which contains tasks if
4795 -- the aggregate is associated with an unexpanded return statement of a
4796 -- build-in-place function. The aggregate is expanded when the related
4797 -- return statement (rewritten into an extended return) is processed.
4798 -- This delay ensures that any temporaries and initialization code
4799 -- generated for the aggregate appear in the proper return block and
4800 -- use the correct _chain and _master.
4802 elsif Has_Task
(Base_Type
(Etype
(N
)))
4803 and then Nkind
(Parent
(N
)) = N_Simple_Return_Statement
4804 and then Is_Build_In_Place_Function
4805 (Return_Applies_To
(Return_Statement_Entity
(Parent
(N
))))
4810 -- If the semantic analyzer has determined that aggregate N will raise
4811 -- Constraint_Error at run time, then the aggregate node has been
4812 -- replaced with an N_Raise_Constraint_Error node and we should
4815 pragma Assert
(not Raises_Constraint_Error
(N
));
4819 -- Check that the index range defined by aggregate bounds is
4820 -- compatible with corresponding index subtype.
4822 Index_Compatibility_Check
: declare
4823 Aggr_Index_Range
: Node_Id
:= First_Index
(Typ
);
4824 -- The current aggregate index range
4826 Index_Constraint
: Node_Id
:= First_Index
(Etype
(Typ
));
4827 -- The corresponding index constraint against which we have to
4828 -- check the above aggregate index range.
4831 Compute_Others_Present
(N
, 1);
4833 for J
in 1 .. Aggr_Dimension
loop
4834 -- There is no need to emit a check if an others choice is
4835 -- present for this array aggregate dimension since in this
4836 -- case one of N's sub-aggregates has taken its bounds from the
4837 -- context and these bounds must have been checked already. In
4838 -- addition all sub-aggregates corresponding to the same
4839 -- dimension must all have the same bounds (checked in (c) below).
4841 if not Range_Checks_Suppressed
(Etype
(Index_Constraint
))
4842 and then not Others_Present
(J
)
4844 -- We don't use Checks.Apply_Range_Check here because it emits
4845 -- a spurious check. Namely it checks that the range defined by
4846 -- the aggregate bounds is non empty. But we know this already
4849 Check_Bounds
(Aggr_Index_Range
, Index_Constraint
);
4852 -- Save the low and high bounds of the aggregate index as well as
4853 -- the index type for later use in checks (b) and (c) below.
4855 Aggr_Low
(J
) := Low_Bound
(Aggr_Index_Range
);
4856 Aggr_High
(J
) := High_Bound
(Aggr_Index_Range
);
4858 Aggr_Index_Typ
(J
) := Etype
(Index_Constraint
);
4860 Next_Index
(Aggr_Index_Range
);
4861 Next_Index
(Index_Constraint
);
4863 end Index_Compatibility_Check
;
4867 -- If an others choice is present check that no aggregate index is
4868 -- outside the bounds of the index constraint.
4870 Others_Check
(N
, 1);
4874 -- For multidimensional arrays make sure that all subaggregates
4875 -- corresponding to the same dimension have the same bounds.
4877 if Aggr_Dimension
> 1 then
4878 Check_Same_Aggr_Bounds
(N
, 1);
4883 -- Here we test for is packed array aggregate that we can handle at
4884 -- compile time. If so, return with transformation done. Note that we do
4885 -- this even if the aggregate is nested, because once we have done this
4886 -- processing, there is no more nested aggregate!
4888 if Packed_Array_Aggregate_Handled
(N
) then
4892 -- At this point we try to convert to positional form
4894 if Ekind
(Current_Scope
) = E_Package
4895 and then Static_Elaboration_Desired
(Current_Scope
)
4897 Convert_To_Positional
(N
, Max_Others_Replicate
=> 100);
4899 Convert_To_Positional
(N
);
4902 -- if the result is no longer an aggregate (e.g. it may be a string
4903 -- literal, or a temporary which has the needed value), then we are
4904 -- done, since there is no longer a nested aggregate.
4906 if Nkind
(N
) /= N_Aggregate
then
4909 -- We are also done if the result is an analyzed aggregate, indicating
4910 -- that Convert_To_Positional succeeded and reanalyzed the rewritten
4914 and then N
/= Original_Node
(N
)
4919 -- If all aggregate components are compile-time known and the aggregate
4920 -- has been flattened, nothing left to do. The same occurs if the
4921 -- aggregate is used to initialize the components of an statically
4922 -- allocated dispatch table.
4924 if Compile_Time_Known_Aggregate
(N
)
4925 or else Is_Static_Dispatch_Table_Aggregate
(N
)
4927 Set_Expansion_Delayed
(N
, False);
4931 -- Now see if back end processing is possible
4933 if Backend_Processing_Possible
(N
) then
4935 -- If the aggregate is static but the constraints are not, build
4936 -- a static subtype for the aggregate, so that Gigi can place it
4937 -- in static memory. Perform an unchecked_conversion to the non-
4938 -- static type imposed by the context.
4941 Itype
: constant Entity_Id
:= Etype
(N
);
4943 Needs_Type
: Boolean := False;
4946 Index
:= First_Index
(Itype
);
4947 while Present
(Index
) loop
4948 if not Is_Static_Subtype
(Etype
(Index
)) then
4957 Build_Constrained_Type
(Positional
=> True);
4958 Rewrite
(N
, Unchecked_Convert_To
(Itype
, N
));
4968 -- Delay expansion for nested aggregates: it will be taken care of
4969 -- when the parent aggregate is expanded.
4971 Parent_Node
:= Parent
(N
);
4972 Parent_Kind
:= Nkind
(Parent_Node
);
4974 if Parent_Kind
= N_Qualified_Expression
then
4975 Parent_Node
:= Parent
(Parent_Node
);
4976 Parent_Kind
:= Nkind
(Parent_Node
);
4979 if Parent_Kind
= N_Aggregate
4980 or else Parent_Kind
= N_Extension_Aggregate
4981 or else Parent_Kind
= N_Component_Association
4982 or else (Parent_Kind
= N_Object_Declaration
4983 and then Needs_Finalization
(Typ
))
4984 or else (Parent_Kind
= N_Assignment_Statement
4985 and then Inside_Init_Proc
)
4987 if Static_Array_Aggregate
(N
)
4988 or else Compile_Time_Known_Aggregate
(N
)
4990 Set_Expansion_Delayed
(N
, False);
4993 Set_Expansion_Delayed
(N
);
5000 -- Look if in place aggregate expansion is possible
5002 -- For object declarations we build the aggregate in place, unless
5003 -- the array is bit-packed or the component is controlled.
5005 -- For assignments we do the assignment in place if all the component
5006 -- associations have compile-time known values. For other cases we
5007 -- create a temporary. The analysis for safety of on-line assignment
5008 -- is delicate, i.e. we don't know how to do it fully yet ???
5010 -- For allocators we assign to the designated object in place if the
5011 -- aggregate meets the same conditions as other in-place assignments.
5012 -- In this case the aggregate may not come from source but was created
5013 -- for default initialization, e.g. with Initialize_Scalars.
5015 if Requires_Transient_Scope
(Typ
) then
5016 Establish_Transient_Scope
5017 (N
, Sec_Stack
=> Has_Controlled_Component
(Typ
));
5020 if Has_Default_Init_Comps
(N
) then
5021 Maybe_In_Place_OK
:= False;
5023 elsif Is_Bit_Packed_Array
(Typ
)
5024 or else Has_Controlled_Component
(Typ
)
5026 Maybe_In_Place_OK
:= False;
5029 Maybe_In_Place_OK
:=
5030 (Nkind
(Parent
(N
)) = N_Assignment_Statement
5031 and then Comes_From_Source
(N
)
5032 and then In_Place_Assign_OK
)
5035 (Nkind
(Parent
(Parent
(N
))) = N_Allocator
5036 and then In_Place_Assign_OK
);
5039 -- If this is an array of tasks, it will be expanded into build-in-place
5040 -- assignments. Build an activation chain for the tasks now.
5042 if Has_Task
(Etype
(N
)) then
5043 Build_Activation_Chain_Entity
(N
);
5046 -- Perform in-place expansion of aggregate in an object declaration.
5047 -- Note: actions generated for the aggregate will be captured in an
5048 -- expression-with-actions statement so that they can be transferred
5049 -- to freeze actions later if there is an address clause for the
5050 -- object. (Note: we don't use a block statement because this would
5051 -- cause generated freeze nodes to be elaborated in the wrong scope).
5053 -- Should document these individual tests ???
5055 if not Has_Default_Init_Comps
(N
)
5056 and then Comes_From_Source
(Parent_Node
)
5057 and then Parent_Kind
= N_Object_Declaration
5059 Must_Slide
(Etype
(Defining_Identifier
(Parent_Node
)), Typ
)
5060 and then N
= Expression
(Parent_Node
)
5061 and then not Is_Bit_Packed_Array
(Typ
)
5062 and then not Has_Controlled_Component
(Typ
)
5064 Tmp
:= Defining_Identifier
(Parent
(N
));
5065 Set_No_Initialization
(Parent
(N
));
5066 Set_Expression
(Parent
(N
), Empty
);
5068 -- Set the type of the entity, for use in the analysis of the
5069 -- subsequent indexed assignments. If the nominal type is not
5070 -- constrained, build a subtype from the known bounds of the
5071 -- aggregate. If the declaration has a subtype mark, use it,
5072 -- otherwise use the itype of the aggregate.
5074 if not Is_Constrained
(Typ
) then
5075 Build_Constrained_Type
(Positional
=> False);
5076 elsif Is_Entity_Name
(Object_Definition
(Parent
(N
)))
5077 and then Is_Constrained
(Entity
(Object_Definition
(Parent
(N
))))
5079 Set_Etype
(Tmp
, Entity
(Object_Definition
(Parent
(N
))));
5081 Set_Size_Known_At_Compile_Time
(Typ
, False);
5082 Set_Etype
(Tmp
, Typ
);
5085 elsif Maybe_In_Place_OK
5086 and then Nkind
(Parent
(N
)) = N_Qualified_Expression
5087 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
5089 Set_Expansion_Delayed
(N
);
5092 -- In the remaining cases the aggregate is the RHS of an assignment
5094 elsif Maybe_In_Place_OK
5095 and then Safe_Left_Hand_Side
(Name
(Parent
(N
)))
5097 Tmp
:= Name
(Parent
(N
));
5099 if Etype
(Tmp
) /= Etype
(N
) then
5100 Apply_Length_Check
(N
, Etype
(Tmp
));
5102 if Nkind
(N
) = N_Raise_Constraint_Error
then
5104 -- Static error, nothing further to expand
5110 elsif Maybe_In_Place_OK
5111 and then Nkind
(Name
(Parent
(N
))) = N_Slice
5112 and then Safe_Slice_Assignment
(N
)
5114 -- Safe_Slice_Assignment rewrites assignment as a loop
5120 -- In place aggregate expansion is not possible
5123 Maybe_In_Place_OK
:= False;
5124 Tmp
:= Make_Temporary
(Loc
, 'A', N
);
5126 Make_Object_Declaration
5128 Defining_Identifier
=> Tmp
,
5129 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
5130 Set_No_Initialization
(Tmp_Decl
, True);
5132 -- If we are within a loop, the temporary will be pushed on the
5133 -- stack at each iteration. If the aggregate is the expression for an
5134 -- allocator, it will be immediately copied to the heap and can
5135 -- be reclaimed at once. We create a transient scope around the
5136 -- aggregate for this purpose.
5138 if Ekind
(Current_Scope
) = E_Loop
5139 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
5141 Establish_Transient_Scope
(N
, False);
5144 Insert_Action
(N
, Tmp_Decl
);
5147 -- Construct and insert the aggregate code. We can safely suppress index
5148 -- checks because this code is guaranteed not to raise CE on index
5149 -- checks. However we should *not* suppress all checks.
5155 if Nkind
(Tmp
) = N_Defining_Identifier
then
5156 Target
:= New_Reference_To
(Tmp
, Loc
);
5160 if Has_Default_Init_Comps
(N
) then
5162 -- Ada 2005 (AI-287): This case has not been analyzed???
5164 raise Program_Error
;
5167 -- Name in assignment is explicit dereference
5169 Target
:= New_Copy
(Tmp
);
5173 Build_Array_Aggr_Code
(N
,
5175 Index
=> First_Index
(Typ
),
5177 Scalar_Comp
=> Is_Scalar_Type
(Ctyp
));
5180 if Comes_From_Source
(Tmp
) then
5182 Node_After
: constant Node_Id
:= Next
(Parent_Node
);
5185 Insert_Actions_After
(Parent_Node
, Aggr_Code
);
5187 if Parent_Kind
= N_Object_Declaration
then
5188 Collect_Initialization_Statements
5189 (Obj
=> Tmp
, N
=> Parent_Node
, Node_After
=> Node_After
);
5194 Insert_Actions
(N
, Aggr_Code
);
5197 -- If the aggregate has been assigned in place, remove the original
5200 if Nkind
(Parent
(N
)) = N_Assignment_Statement
5201 and then Maybe_In_Place_OK
5203 Rewrite
(Parent
(N
), Make_Null_Statement
(Loc
));
5205 elsif Nkind
(Parent
(N
)) /= N_Object_Declaration
5206 or else Tmp
/= Defining_Identifier
(Parent
(N
))
5208 Rewrite
(N
, New_Occurrence_Of
(Tmp
, Loc
));
5209 Analyze_And_Resolve
(N
, Typ
);
5211 end Expand_Array_Aggregate
;
5213 ------------------------
5214 -- Expand_N_Aggregate --
5215 ------------------------
5217 procedure Expand_N_Aggregate
(N
: Node_Id
) is
5219 -- Record aggregate case
5221 if Is_Record_Type
(Etype
(N
)) then
5222 Expand_Record_Aggregate
(N
);
5224 -- Array aggregate case
5227 -- A special case, if we have a string subtype with bounds 1 .. N,
5228 -- where N is known at compile time, and the aggregate is of the
5229 -- form (others => 'x'), with a single choice and no expressions,
5230 -- and N is less than 80 (an arbitrary limit for now), then replace
5231 -- the aggregate by the equivalent string literal (but do not mark
5232 -- it as static since it is not!)
5234 -- Note: this entire circuit is redundant with respect to code in
5235 -- Expand_Array_Aggregate that collapses others choices to positional
5236 -- form, but there are two problems with that circuit:
5238 -- a) It is limited to very small cases due to ill-understood
5239 -- interations with bootstrapping. That limit is removed by
5240 -- use of the No_Implicit_Loops restriction.
5242 -- b) It erroneously ends up with the resulting expressions being
5243 -- considered static when they are not. For example, the
5244 -- following test should fail:
5246 -- pragma Restrictions (No_Implicit_Loops);
5247 -- package NonSOthers4 is
5248 -- B : constant String (1 .. 6) := (others => 'A');
5249 -- DH : constant String (1 .. 8) := B & "BB";
5251 -- pragma Export (C, X, Link_Name => DH);
5254 -- But it succeeds (DH looks static to pragma Export)
5256 -- To be sorted out! ???
5258 if Present
(Component_Associations
(N
)) then
5260 CA
: constant Node_Id
:= First
(Component_Associations
(N
));
5261 MX
: constant := 80;
5264 if Nkind
(First
(Choices
(CA
))) = N_Others_Choice
5265 and then Nkind
(Expression
(CA
)) = N_Character_Literal
5266 and then No
(Expressions
(N
))
5269 T
: constant Entity_Id
:= Etype
(N
);
5270 X
: constant Node_Id
:= First_Index
(T
);
5271 EC
: constant Node_Id
:= Expression
(CA
);
5272 CV
: constant Uint
:= Char_Literal_Value
(EC
);
5273 CC
: constant Int
:= UI_To_Int
(CV
);
5276 if Nkind
(X
) = N_Range
5277 and then Compile_Time_Known_Value
(Low_Bound
(X
))
5278 and then Expr_Value
(Low_Bound
(X
)) = 1
5279 and then Compile_Time_Known_Value
(High_Bound
(X
))
5282 Hi
: constant Uint
:= Expr_Value
(High_Bound
(X
));
5288 for J
in 1 .. UI_To_Int
(Hi
) loop
5289 Store_String_Char
(Char_Code
(CC
));
5293 Make_String_Literal
(Sloc
(N
),
5294 Strval
=> End_String
));
5296 if CC
>= Int
(2 ** 16) then
5297 Set_Has_Wide_Wide_Character
(N
);
5298 elsif CC
>= Int
(2 ** 8) then
5299 Set_Has_Wide_Character
(N
);
5302 Analyze_And_Resolve
(N
, T
);
5303 Set_Is_Static_Expression
(N
, False);
5313 -- Not that special case, so normal expansion of array aggregate
5315 Expand_Array_Aggregate
(N
);
5318 when RE_Not_Available
=>
5320 end Expand_N_Aggregate
;
5322 ----------------------------------
5323 -- Expand_N_Extension_Aggregate --
5324 ----------------------------------
5326 -- If the ancestor part is an expression, add a component association for
5327 -- the parent field. If the type of the ancestor part is not the direct
5328 -- parent of the expected type, build recursively the needed ancestors.
5329 -- If the ancestor part is a subtype_mark, replace aggregate with a decla-
5330 -- ration for a temporary of the expected type, followed by individual
5331 -- assignments to the given components.
5333 procedure Expand_N_Extension_Aggregate
(N
: Node_Id
) is
5334 Loc
: constant Source_Ptr
:= Sloc
(N
);
5335 A
: constant Node_Id
:= Ancestor_Part
(N
);
5336 Typ
: constant Entity_Id
:= Etype
(N
);
5339 -- If the ancestor is a subtype mark, an init proc must be called
5340 -- on the resulting object which thus has to be materialized in
5343 if Is_Entity_Name
(A
) and then Is_Type
(Entity
(A
)) then
5344 Convert_To_Assignments
(N
, Typ
);
5346 -- The extension aggregate is transformed into a record aggregate
5347 -- of the following form (c1 and c2 are inherited components)
5349 -- (Exp with c3 => a, c4 => b)
5350 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c3 => a, c4 => b)
5355 if Tagged_Type_Expansion
then
5356 Expand_Record_Aggregate
(N
,
5359 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
),
5362 -- No tag is needed in the case of a VM
5365 Expand_Record_Aggregate
(N
, Parent_Expr
=> A
);
5370 when RE_Not_Available
=>
5372 end Expand_N_Extension_Aggregate
;
5374 -----------------------------
5375 -- Expand_Record_Aggregate --
5376 -----------------------------
5378 procedure Expand_Record_Aggregate
5380 Orig_Tag
: Node_Id
:= Empty
;
5381 Parent_Expr
: Node_Id
:= Empty
)
5383 Loc
: constant Source_Ptr
:= Sloc
(N
);
5384 Comps
: constant List_Id
:= Component_Associations
(N
);
5385 Typ
: constant Entity_Id
:= Etype
(N
);
5386 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
5388 Static_Components
: Boolean := True;
5389 -- Flag to indicate whether all components are compile-time known,
5390 -- and the aggregate can be constructed statically and handled by
5393 function Compile_Time_Known_Composite_Value
(N
: Node_Id
) return Boolean;
5394 -- Returns true if N is an expression of composite type which can be
5395 -- fully evaluated at compile time without raising constraint error.
5396 -- Such expressions can be passed as is to Gigi without any expansion.
5398 -- This returns true for N_Aggregate with Compile_Time_Known_Aggregate
5399 -- set and constants whose expression is such an aggregate, recursively.
5401 function Component_Not_OK_For_Backend
return Boolean;
5402 -- Check for presence of component which makes it impossible for the
5403 -- backend to process the aggregate, thus requiring the use of a series
5404 -- of assignment statements. Cases checked for are a nested aggregate
5405 -- needing Late_Expansion, the presence of a tagged component which may
5406 -- need tag adjustment, and a bit unaligned component reference.
5408 -- We also force expansion into assignments if a component is of a
5409 -- mutable type (including a private type with discriminants) because
5410 -- in that case the size of the component to be copied may be smaller
5411 -- than the side of the target, and there is no simple way for gigi
5412 -- to compute the size of the object to be copied.
5414 -- NOTE: This is part of the ongoing work to define precisely the
5415 -- interface between front-end and back-end handling of aggregates.
5416 -- In general it is desirable to pass aggregates as they are to gigi,
5417 -- in order to minimize elaboration code. This is one case where the
5418 -- semantics of Ada complicate the analysis and lead to anomalies in
5419 -- the gcc back-end if the aggregate is not expanded into assignments.
5421 function Has_Visible_Private_Ancestor
(Id
: E
) return Boolean;
5422 -- If any ancestor of the current type is private, the aggregate
5423 -- cannot be built in place. We canot rely on Has_Private_Ancestor,
5424 -- because it will not be set when type and its parent are in the
5425 -- same scope, and the parent component needs expansion.
5427 function Top_Level_Aggregate
(N
: Node_Id
) return Node_Id
;
5428 -- For nested aggregates return the ultimate enclosing aggregate; for
5429 -- non-nested aggregates return N.
5431 ----------------------------------------
5432 -- Compile_Time_Known_Composite_Value --
5433 ----------------------------------------
5435 function Compile_Time_Known_Composite_Value
5436 (N
: Node_Id
) return Boolean
5439 -- If we have an entity name, then see if it is the name of a
5440 -- constant and if so, test the corresponding constant value.
5442 if Is_Entity_Name
(N
) then
5444 E
: constant Entity_Id
:= Entity
(N
);
5447 if Ekind
(E
) /= E_Constant
then
5450 V
:= Constant_Value
(E
);
5452 and then Compile_Time_Known_Composite_Value
(V
);
5456 -- We have a value, see if it is compile time known
5459 if Nkind
(N
) = N_Aggregate
then
5460 return Compile_Time_Known_Aggregate
(N
);
5463 -- All other types of values are not known at compile time
5468 end Compile_Time_Known_Composite_Value
;
5470 ----------------------------------
5471 -- Component_Not_OK_For_Backend --
5472 ----------------------------------
5474 function Component_Not_OK_For_Backend
return Boolean is
5484 while Present
(C
) loop
5486 -- If the component has box initialization, expansion is needed
5487 -- and component is not ready for backend.
5489 if Box_Present
(C
) then
5493 if Nkind
(Expression
(C
)) = N_Qualified_Expression
then
5494 Expr_Q
:= Expression
(Expression
(C
));
5496 Expr_Q
:= Expression
(C
);
5499 -- Return true if the aggregate has any associations for tagged
5500 -- components that may require tag adjustment.
5502 -- These are cases where the source expression may have a tag that
5503 -- could differ from the component tag (e.g., can occur for type
5504 -- conversions and formal parameters). (Tag adjustment not needed
5505 -- if VM_Target because object tags are implicit in the machine.)
5507 if Is_Tagged_Type
(Etype
(Expr_Q
))
5508 and then (Nkind
(Expr_Q
) = N_Type_Conversion
5509 or else (Is_Entity_Name
(Expr_Q
)
5511 Ekind
(Entity
(Expr_Q
)) in Formal_Kind
))
5512 and then Tagged_Type_Expansion
5514 Static_Components
:= False;
5517 elsif Is_Delayed_Aggregate
(Expr_Q
) then
5518 Static_Components
:= False;
5521 elsif Possible_Bit_Aligned_Component
(Expr_Q
) then
5522 Static_Components
:= False;
5526 if Is_Elementary_Type
(Etype
(Expr_Q
)) then
5527 if not Compile_Time_Known_Value
(Expr_Q
) then
5528 Static_Components
:= False;
5531 elsif not Compile_Time_Known_Composite_Value
(Expr_Q
) then
5532 Static_Components
:= False;
5534 if Is_Private_Type
(Etype
(Expr_Q
))
5535 and then Has_Discriminants
(Etype
(Expr_Q
))
5545 end Component_Not_OK_For_Backend
;
5547 -----------------------------------
5548 -- Has_Visible_Private_Ancestor --
5549 -----------------------------------
5551 function Has_Visible_Private_Ancestor
(Id
: E
) return Boolean is
5552 R
: constant Entity_Id
:= Root_Type
(Id
);
5553 T1
: Entity_Id
:= Id
;
5557 if Is_Private_Type
(T1
) then
5567 end Has_Visible_Private_Ancestor
;
5569 -------------------------
5570 -- Top_Level_Aggregate --
5571 -------------------------
5573 function Top_Level_Aggregate
(N
: Node_Id
) return Node_Id
is
5578 while Present
(Parent
(Aggr
))
5579 and then Nkind_In
(Parent
(Aggr
), N_Component_Association
,
5582 Aggr
:= Parent
(Aggr
);
5586 end Top_Level_Aggregate
;
5590 Top_Level_Aggr
: constant Node_Id
:= Top_Level_Aggregate
(N
);
5591 Tag_Value
: Node_Id
;
5595 -- Start of processing for Expand_Record_Aggregate
5598 -- If the aggregate is to be assigned to an atomic variable, we
5599 -- have to prevent a piecemeal assignment even if the aggregate
5600 -- is to be expanded. We create a temporary for the aggregate, and
5601 -- assign the temporary instead, so that the back end can generate
5602 -- an atomic move for it.
5605 and then Comes_From_Source
(Parent
(N
))
5606 and then Is_Atomic_Aggregate
(N
, Typ
)
5610 -- No special management required for aggregates used to initialize
5611 -- statically allocated dispatch tables
5613 elsif Is_Static_Dispatch_Table_Aggregate
(N
) then
5617 -- Ada 2005 (AI-318-2): We need to convert to assignments if components
5618 -- are build-in-place function calls. The assignments will each turn
5619 -- into a build-in-place function call. If components are all static,
5620 -- we can pass the aggregate to the backend regardless of limitedness.
5622 -- Extension aggregates, aggregates in extended return statements, and
5623 -- aggregates for C++ imported types must be expanded.
5625 if Ada_Version
>= Ada_2005
and then Is_Immutably_Limited_Type
(Typ
) then
5626 if not Nkind_In
(Parent
(N
), N_Object_Declaration
,
5627 N_Component_Association
)
5629 Convert_To_Assignments
(N
, Typ
);
5631 elsif Nkind
(N
) = N_Extension_Aggregate
5632 or else Convention
(Typ
) = Convention_CPP
5634 Convert_To_Assignments
(N
, Typ
);
5636 elsif not Size_Known_At_Compile_Time
(Typ
)
5637 or else Component_Not_OK_For_Backend
5638 or else not Static_Components
5640 Convert_To_Assignments
(N
, Typ
);
5643 Set_Compile_Time_Known_Aggregate
(N
);
5644 Set_Expansion_Delayed
(N
, False);
5647 -- Gigi doesn't properly handle temporaries of variable size so we
5648 -- generate it in the front-end
5650 elsif not Size_Known_At_Compile_Time
(Typ
)
5651 and then Tagged_Type_Expansion
5653 Convert_To_Assignments
(N
, Typ
);
5655 -- Temporaries for controlled aggregates need to be attached to a final
5656 -- chain in order to be properly finalized, so it has to be created in
5659 elsif Is_Controlled
(Typ
)
5660 or else Has_Controlled_Component
(Base_Type
(Typ
))
5662 Convert_To_Assignments
(N
, Typ
);
5664 -- Ada 2005 (AI-287): In case of default initialized components we
5665 -- convert the aggregate into assignments.
5667 elsif Has_Default_Init_Comps
(N
) then
5668 Convert_To_Assignments
(N
, Typ
);
5672 elsif Component_Not_OK_For_Backend
then
5673 Convert_To_Assignments
(N
, Typ
);
5675 -- If an ancestor is private, some components are not inherited and we
5676 -- cannot expand into a record aggregate.
5678 elsif Has_Visible_Private_Ancestor
(Typ
) then
5679 Convert_To_Assignments
(N
, Typ
);
5681 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
5682 -- is not able to handle the aggregate for Late_Request.
5684 elsif Is_Tagged_Type
(Typ
) and then Has_Discriminants
(Typ
) then
5685 Convert_To_Assignments
(N
, Typ
);
5687 -- If the tagged types covers interface types we need to initialize all
5688 -- hidden components containing pointers to secondary dispatch tables.
5690 elsif Is_Tagged_Type
(Typ
) and then Has_Interfaces
(Typ
) then
5691 Convert_To_Assignments
(N
, Typ
);
5693 -- If some components are mutable, the size of the aggregate component
5694 -- may be distinct from the default size of the type component, so
5695 -- we need to expand to insure that the back-end copies the proper
5696 -- size of the data. However, if the aggregate is the initial value of
5697 -- a constant, the target is immutable and might be built statically
5698 -- if components are appropriate.
5700 elsif Has_Mutable_Components
(Typ
)
5702 (Nkind
(Parent
(Top_Level_Aggr
)) /= N_Object_Declaration
5703 or else not Constant_Present
(Parent
(Top_Level_Aggr
))
5704 or else not Static_Components
)
5706 Convert_To_Assignments
(N
, Typ
);
5708 -- If the type involved has any non-bit aligned components, then we are
5709 -- not sure that the back end can handle this case correctly.
5711 elsif Type_May_Have_Bit_Aligned_Components
(Typ
) then
5712 Convert_To_Assignments
(N
, Typ
);
5714 -- In all other cases, build a proper aggregate handlable by gigi
5717 if Nkind
(N
) = N_Aggregate
then
5719 -- If the aggregate is static and can be handled by the back-end,
5720 -- nothing left to do.
5722 if Static_Components
then
5723 Set_Compile_Time_Known_Aggregate
(N
);
5724 Set_Expansion_Delayed
(N
, False);
5728 -- If no discriminants, nothing special to do
5730 if not Has_Discriminants
(Typ
) then
5733 -- Case of discriminants present
5735 elsif Is_Derived_Type
(Typ
) then
5737 -- For untagged types, non-stored discriminants are replaced
5738 -- with stored discriminants, which are the ones that gigi uses
5739 -- to describe the type and its components.
5741 Generate_Aggregate_For_Derived_Type
: declare
5742 Constraints
: constant List_Id
:= New_List
;
5743 First_Comp
: Node_Id
;
5744 Discriminant
: Entity_Id
;
5746 Num_Disc
: Int
:= 0;
5747 Num_Gird
: Int
:= 0;
5749 procedure Prepend_Stored_Values
(T
: Entity_Id
);
5750 -- Scan the list of stored discriminants of the type, and add
5751 -- their values to the aggregate being built.
5753 ---------------------------
5754 -- Prepend_Stored_Values --
5755 ---------------------------
5757 procedure Prepend_Stored_Values
(T
: Entity_Id
) is
5759 Discriminant
:= First_Stored_Discriminant
(T
);
5760 while Present
(Discriminant
) loop
5762 Make_Component_Association
(Loc
,
5764 New_List
(New_Occurrence_Of
(Discriminant
, Loc
)),
5768 Get_Discriminant_Value
(
5771 Discriminant_Constraint
(Typ
))));
5773 if No
(First_Comp
) then
5774 Prepend_To
(Component_Associations
(N
), New_Comp
);
5776 Insert_After
(First_Comp
, New_Comp
);
5779 First_Comp
:= New_Comp
;
5780 Next_Stored_Discriminant
(Discriminant
);
5782 end Prepend_Stored_Values
;
5784 -- Start of processing for Generate_Aggregate_For_Derived_Type
5787 -- Remove the associations for the discriminant of derived type
5789 First_Comp
:= First
(Component_Associations
(N
));
5790 while Present
(First_Comp
) loop
5795 (First
(Choices
(Comp
)))) = E_Discriminant
5798 Num_Disc
:= Num_Disc
+ 1;
5802 -- Insert stored discriminant associations in the correct
5803 -- order. If there are more stored discriminants than new
5804 -- discriminants, there is at least one new discriminant that
5805 -- constrains more than one of the stored discriminants. In
5806 -- this case we need to construct a proper subtype of the
5807 -- parent type, in order to supply values to all the
5808 -- components. Otherwise there is one-one correspondence
5809 -- between the constraints and the stored discriminants.
5811 First_Comp
:= Empty
;
5813 Discriminant
:= First_Stored_Discriminant
(Base_Type
(Typ
));
5814 while Present
(Discriminant
) loop
5815 Num_Gird
:= Num_Gird
+ 1;
5816 Next_Stored_Discriminant
(Discriminant
);
5819 -- Case of more stored discriminants than new discriminants
5821 if Num_Gird
> Num_Disc
then
5823 -- Create a proper subtype of the parent type, which is the
5824 -- proper implementation type for the aggregate, and convert
5825 -- it to the intended target type.
5827 Discriminant
:= First_Stored_Discriminant
(Base_Type
(Typ
));
5828 while Present
(Discriminant
) loop
5831 Get_Discriminant_Value
(
5834 Discriminant_Constraint
(Typ
)));
5835 Append
(New_Comp
, Constraints
);
5836 Next_Stored_Discriminant
(Discriminant
);
5840 Make_Subtype_Declaration
(Loc
,
5841 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
5842 Subtype_Indication
=>
5843 Make_Subtype_Indication
(Loc
,
5845 New_Occurrence_Of
(Etype
(Base_Type
(Typ
)), Loc
),
5847 Make_Index_Or_Discriminant_Constraint
5848 (Loc
, Constraints
)));
5850 Insert_Action
(N
, Decl
);
5851 Prepend_Stored_Values
(Base_Type
(Typ
));
5853 Set_Etype
(N
, Defining_Identifier
(Decl
));
5856 Rewrite
(N
, Unchecked_Convert_To
(Typ
, N
));
5859 -- Case where we do not have fewer new discriminants than
5860 -- stored discriminants, so in this case we can simply use the
5861 -- stored discriminants of the subtype.
5864 Prepend_Stored_Values
(Typ
);
5866 end Generate_Aggregate_For_Derived_Type
;
5869 if Is_Tagged_Type
(Typ
) then
5871 -- In the tagged case, _parent and _tag component must be created
5873 -- Reset Null_Present unconditionally. Tagged records always have
5874 -- at least one field (the tag or the parent).
5876 Set_Null_Record_Present
(N
, False);
5878 -- When the current aggregate comes from the expansion of an
5879 -- extension aggregate, the parent expr is replaced by an
5880 -- aggregate formed by selected components of this expr.
5882 if Present
(Parent_Expr
)
5883 and then Is_Empty_List
(Comps
)
5885 Comp
:= First_Component_Or_Discriminant
(Typ
);
5886 while Present
(Comp
) loop
5888 -- Skip all expander-generated components
5891 not Comes_From_Source
(Original_Record_Component
(Comp
))
5897 Make_Selected_Component
(Loc
,
5899 Unchecked_Convert_To
(Typ
,
5900 Duplicate_Subexpr
(Parent_Expr
, True)),
5902 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
5905 Make_Component_Association
(Loc
,
5907 New_List
(New_Occurrence_Of
(Comp
, Loc
)),
5911 Analyze_And_Resolve
(New_Comp
, Etype
(Comp
));
5914 Next_Component_Or_Discriminant
(Comp
);
5918 -- Compute the value for the Tag now, if the type is a root it
5919 -- will be included in the aggregate right away, otherwise it will
5920 -- be propagated to the parent aggregate.
5922 if Present
(Orig_Tag
) then
5923 Tag_Value
:= Orig_Tag
;
5924 elsif not Tagged_Type_Expansion
then
5929 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
5932 -- For a derived type, an aggregate for the parent is formed with
5933 -- all the inherited components.
5935 if Is_Derived_Type
(Typ
) then
5938 First_Comp
: Node_Id
;
5939 Parent_Comps
: List_Id
;
5940 Parent_Aggr
: Node_Id
;
5941 Parent_Name
: Node_Id
;
5944 -- Remove the inherited component association from the
5945 -- aggregate and store them in the parent aggregate
5947 First_Comp
:= First
(Component_Associations
(N
));
5948 Parent_Comps
:= New_List
;
5949 while Present
(First_Comp
)
5950 and then Scope
(Original_Record_Component
(
5951 Entity
(First
(Choices
(First_Comp
))))) /= Base_Typ
5956 Append
(Comp
, Parent_Comps
);
5959 Parent_Aggr
:= Make_Aggregate
(Loc
,
5960 Component_Associations
=> Parent_Comps
);
5961 Set_Etype
(Parent_Aggr
, Etype
(Base_Type
(Typ
)));
5963 -- Find the _parent component
5965 Comp
:= First_Component
(Typ
);
5966 while Chars
(Comp
) /= Name_uParent
loop
5967 Comp
:= Next_Component
(Comp
);
5970 Parent_Name
:= New_Occurrence_Of
(Comp
, Loc
);
5972 -- Insert the parent aggregate
5974 Prepend_To
(Component_Associations
(N
),
5975 Make_Component_Association
(Loc
,
5976 Choices
=> New_List
(Parent_Name
),
5977 Expression
=> Parent_Aggr
));
5979 -- Expand recursively the parent propagating the right Tag
5981 Expand_Record_Aggregate
5982 (Parent_Aggr
, Tag_Value
, Parent_Expr
);
5984 -- The ancestor part may be a nested aggregate that has
5985 -- delayed expansion: recheck now.
5987 if Component_Not_OK_For_Backend
then
5988 Convert_To_Assignments
(N
, Typ
);
5992 -- For a root type, the tag component is added (unless compiling
5993 -- for the VMs, where tags are implicit).
5995 elsif Tagged_Type_Expansion
then
5997 Tag_Name
: constant Node_Id
:=
5998 New_Occurrence_Of
(First_Tag_Component
(Typ
), Loc
);
5999 Typ_Tag
: constant Entity_Id
:= RTE
(RE_Tag
);
6000 Conv_Node
: constant Node_Id
:=
6001 Unchecked_Convert_To
(Typ_Tag
, Tag_Value
);
6004 Set_Etype
(Conv_Node
, Typ_Tag
);
6005 Prepend_To
(Component_Associations
(N
),
6006 Make_Component_Association
(Loc
,
6007 Choices
=> New_List
(Tag_Name
),
6008 Expression
=> Conv_Node
));
6014 end Expand_Record_Aggregate
;
6016 ----------------------------
6017 -- Has_Default_Init_Comps --
6018 ----------------------------
6020 function Has_Default_Init_Comps
(N
: Node_Id
) return Boolean is
6021 Comps
: constant List_Id
:= Component_Associations
(N
);
6025 pragma Assert
(Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
));
6031 if Has_Self_Reference
(N
) then
6035 -- Check if any direct component has default initialized components
6038 while Present
(C
) loop
6039 if Box_Present
(C
) then
6046 -- Recursive call in case of aggregate expression
6049 while Present
(C
) loop
6050 Expr
:= Expression
(C
);
6054 Nkind_In
(Expr
, N_Aggregate
, N_Extension_Aggregate
)
6055 and then Has_Default_Init_Comps
(Expr
)
6064 end Has_Default_Init_Comps
;
6066 --------------------------
6067 -- Is_Delayed_Aggregate --
6068 --------------------------
6070 function Is_Delayed_Aggregate
(N
: Node_Id
) return Boolean is
6071 Node
: Node_Id
:= N
;
6072 Kind
: Node_Kind
:= Nkind
(Node
);
6075 if Kind
= N_Qualified_Expression
then
6076 Node
:= Expression
(Node
);
6077 Kind
:= Nkind
(Node
);
6080 if Kind
/= N_Aggregate
and then Kind
/= N_Extension_Aggregate
then
6083 return Expansion_Delayed
(Node
);
6085 end Is_Delayed_Aggregate
;
6087 ----------------------------------------
6088 -- Is_Static_Dispatch_Table_Aggregate --
6089 ----------------------------------------
6091 function Is_Static_Dispatch_Table_Aggregate
(N
: Node_Id
) return Boolean is
6092 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6095 return Static_Dispatch_Tables
6096 and then Tagged_Type_Expansion
6097 and then RTU_Loaded
(Ada_Tags
)
6099 -- Avoid circularity when rebuilding the compiler
6101 and then Cunit_Entity
(Get_Source_Unit
(N
)) /= RTU_Entity
(Ada_Tags
)
6102 and then (Typ
= RTE
(RE_Dispatch_Table_Wrapper
)
6104 Typ
= RTE
(RE_Address_Array
)
6106 Typ
= RTE
(RE_Type_Specific_Data
)
6108 Typ
= RTE
(RE_Tag_Table
)
6110 (RTE_Available
(RE_Interface_Data
)
6111 and then Typ
= RTE
(RE_Interface_Data
))
6113 (RTE_Available
(RE_Interfaces_Array
)
6114 and then Typ
= RTE
(RE_Interfaces_Array
))
6116 (RTE_Available
(RE_Interface_Data_Element
)
6117 and then Typ
= RTE
(RE_Interface_Data_Element
)));
6118 end Is_Static_Dispatch_Table_Aggregate
;
6120 -----------------------------
6121 -- Is_Two_Dim_Packed_Array --
6122 -----------------------------
6124 function Is_Two_Dim_Packed_Array
(Typ
: Entity_Id
) return Boolean is
6125 C
: constant Int
:= UI_To_Int
(Component_Size
(Typ
));
6127 return Number_Dimensions
(Typ
) = 2
6128 and then Is_Bit_Packed_Array
(Typ
)
6129 and then (C
= 1 or else C
= 2 or else C
= 4);
6130 end Is_Two_Dim_Packed_Array
;
6132 --------------------
6133 -- Late_Expansion --
6134 --------------------
6136 function Late_Expansion
6139 Target
: Node_Id
) return List_Id
6142 if Is_Record_Type
(Etype
(N
)) then
6143 return Build_Record_Aggr_Code
(N
, Typ
, Target
);
6145 else pragma Assert
(Is_Array_Type
(Etype
(N
)));
6147 Build_Array_Aggr_Code
6149 Ctype
=> Component_Type
(Etype
(N
)),
6150 Index
=> First_Index
(Typ
),
6152 Scalar_Comp
=> Is_Scalar_Type
(Component_Type
(Typ
)),
6153 Indexes
=> No_List
);
6157 ----------------------------------
6158 -- Make_OK_Assignment_Statement --
6159 ----------------------------------
6161 function Make_OK_Assignment_Statement
6164 Expression
: Node_Id
) return Node_Id
6167 Set_Assignment_OK
(Name
);
6169 return Make_Assignment_Statement
(Sloc
, Name
, Expression
);
6170 end Make_OK_Assignment_Statement
;
6172 -----------------------
6173 -- Number_Of_Choices --
6174 -----------------------
6176 function Number_Of_Choices
(N
: Node_Id
) return Nat
is
6180 Nb_Choices
: Nat
:= 0;
6183 if Present
(Expressions
(N
)) then
6187 Assoc
:= First
(Component_Associations
(N
));
6188 while Present
(Assoc
) loop
6189 Choice
:= First
(Choices
(Assoc
));
6190 while Present
(Choice
) loop
6191 if Nkind
(Choice
) /= N_Others_Choice
then
6192 Nb_Choices
:= Nb_Choices
+ 1;
6202 end Number_Of_Choices
;
6204 ------------------------------------
6205 -- Packed_Array_Aggregate_Handled --
6206 ------------------------------------
6208 -- The current version of this procedure will handle at compile time
6209 -- any array aggregate that meets these conditions:
6211 -- One and two dimensional, bit packed
6212 -- Underlying packed type is modular type
6213 -- Bounds are within 32-bit Int range
6214 -- All bounds and values are static
6216 -- Note: for now, in the 2-D case, we only handle component sizes of
6217 -- 1, 2, 4 (cases where an integral number of elements occupies a byte).
6219 function Packed_Array_Aggregate_Handled
(N
: Node_Id
) return Boolean is
6220 Loc
: constant Source_Ptr
:= Sloc
(N
);
6221 Typ
: constant Entity_Id
:= Etype
(N
);
6222 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
6224 Not_Handled
: exception;
6225 -- Exception raised if this aggregate cannot be handled
6228 -- Handle one- or two dimensional bit packed array
6230 if not Is_Bit_Packed_Array
(Typ
)
6231 or else Number_Dimensions
(Typ
) > 2
6236 -- If two-dimensional, check whether it can be folded, and transformed
6237 -- into a one-dimensional aggregate for the Packed_Array_Type of the
6240 if Number_Dimensions
(Typ
) = 2 then
6241 return Two_Dim_Packed_Array_Handled
(N
);
6244 if not Is_Modular_Integer_Type
(Packed_Array_Type
(Typ
)) then
6248 if not Is_Scalar_Type
(Component_Type
(Typ
))
6249 and then Has_Non_Standard_Rep
(Component_Type
(Typ
))
6255 Csiz
: constant Nat
:= UI_To_Int
(Component_Size
(Typ
));
6259 -- Bounds of index type
6263 -- Values of bounds if compile time known
6265 function Get_Component_Val
(N
: Node_Id
) return Uint
;
6266 -- Given a expression value N of the component type Ctyp, returns a
6267 -- value of Csiz (component size) bits representing this value. If
6268 -- the value is non-static or any other reason exists why the value
6269 -- cannot be returned, then Not_Handled is raised.
6271 -----------------------
6272 -- Get_Component_Val --
6273 -----------------------
6275 function Get_Component_Val
(N
: Node_Id
) return Uint
is
6279 -- We have to analyze the expression here before doing any further
6280 -- processing here. The analysis of such expressions is deferred
6281 -- till expansion to prevent some problems of premature analysis.
6283 Analyze_And_Resolve
(N
, Ctyp
);
6285 -- Must have a compile time value. String literals have to be
6286 -- converted into temporaries as well, because they cannot easily
6287 -- be converted into their bit representation.
6289 if not Compile_Time_Known_Value
(N
)
6290 or else Nkind
(N
) = N_String_Literal
6295 Val
:= Expr_Rep_Value
(N
);
6297 -- Adjust for bias, and strip proper number of bits
6299 if Has_Biased_Representation
(Ctyp
) then
6300 Val
:= Val
- Expr_Value
(Type_Low_Bound
(Ctyp
));
6303 return Val
mod Uint_2
** Csiz
;
6304 end Get_Component_Val
;
6306 -- Here we know we have a one dimensional bit packed array
6309 Get_Index_Bounds
(First_Index
(Typ
), Lo
, Hi
);
6311 -- Cannot do anything if bounds are dynamic
6313 if not Compile_Time_Known_Value
(Lo
)
6315 not Compile_Time_Known_Value
(Hi
)
6320 -- Or are silly out of range of int bounds
6322 Lob
:= Expr_Value
(Lo
);
6323 Hib
:= Expr_Value
(Hi
);
6325 if not UI_Is_In_Int_Range
(Lob
)
6327 not UI_Is_In_Int_Range
(Hib
)
6332 -- At this stage we have a suitable aggregate for handling at compile
6333 -- time. The only remaining checks are that the values of expressions
6334 -- in the aggregate are compile-time known (checks are performed by
6335 -- Get_Component_Val, and that any subtypes or ranges are statically
6338 -- If the aggregate is not fully positional at this stage, then
6339 -- convert it to positional form. Either this will fail, in which
6340 -- case we can do nothing, or it will succeed, in which case we have
6341 -- succeeded in handling the aggregate and transforming it into a
6342 -- modular value, or it will stay an aggregate, in which case we
6343 -- have failed to create a packed value for it.
6345 if Present
(Component_Associations
(N
)) then
6346 Convert_To_Positional
6347 (N
, Max_Others_Replicate
=> 64, Handle_Bit_Packed
=> True);
6348 return Nkind
(N
) /= N_Aggregate
;
6351 -- Otherwise we are all positional, so convert to proper value
6354 Lov
: constant Int
:= UI_To_Int
(Lob
);
6355 Hiv
: constant Int
:= UI_To_Int
(Hib
);
6357 Len
: constant Nat
:= Int
'Max (0, Hiv
- Lov
+ 1);
6358 -- The length of the array (number of elements)
6360 Aggregate_Val
: Uint
;
6361 -- Value of aggregate. The value is set in the low order bits of
6362 -- this value. For the little-endian case, the values are stored
6363 -- from low-order to high-order and for the big-endian case the
6364 -- values are stored from high-order to low-order. Note that gigi
6365 -- will take care of the conversions to left justify the value in
6366 -- the big endian case (because of left justified modular type
6367 -- processing), so we do not have to worry about that here.
6370 -- Integer literal for resulting constructed value
6373 -- Shift count from low order for next value
6376 -- Shift increment for loop
6379 -- Next expression from positional parameters of aggregate
6381 Left_Justified
: Boolean;
6382 -- Set True if we are filling the high order bits of the target
6383 -- value (i.e. the value is left justified).
6386 -- For little endian, we fill up the low order bits of the target
6387 -- value. For big endian we fill up the high order bits of the
6388 -- target value (which is a left justified modular value).
6390 Left_Justified
:= Bytes_Big_Endian
;
6392 -- Switch justification if using -gnatd8
6394 if Debug_Flag_8
then
6395 Left_Justified
:= not Left_Justified
;
6398 -- Switch justfification if reverse storage order
6400 if Reverse_Storage_Order
(Base_Type
(Typ
)) then
6401 Left_Justified
:= not Left_Justified
;
6404 if Left_Justified
then
6405 Shift
:= Csiz
* (Len
- 1);
6412 -- Loop to set the values
6415 Aggregate_Val
:= Uint_0
;
6417 Expr
:= First
(Expressions
(N
));
6418 Aggregate_Val
:= Get_Component_Val
(Expr
) * Uint_2
** Shift
;
6420 for J
in 2 .. Len
loop
6421 Shift
:= Shift
+ Incr
;
6424 Aggregate_Val
+ Get_Component_Val
(Expr
) * Uint_2
** Shift
;
6428 -- Now we can rewrite with the proper value
6430 Lit
:= Make_Integer_Literal
(Loc
, Intval
=> Aggregate_Val
);
6431 Set_Print_In_Hex
(Lit
);
6433 -- Construct the expression using this literal. Note that it is
6434 -- important to qualify the literal with its proper modular type
6435 -- since universal integer does not have the required range and
6436 -- also this is a left justified modular type, which is important
6437 -- in the big-endian case.
6440 Unchecked_Convert_To
(Typ
,
6441 Make_Qualified_Expression
(Loc
,
6443 New_Occurrence_Of
(Packed_Array_Type
(Typ
), Loc
),
6444 Expression
=> Lit
)));
6446 Analyze_And_Resolve
(N
, Typ
);
6454 end Packed_Array_Aggregate_Handled
;
6456 ----------------------------
6457 -- Has_Mutable_Components --
6458 ----------------------------
6460 function Has_Mutable_Components
(Typ
: Entity_Id
) return Boolean is
6464 Comp
:= First_Component
(Typ
);
6465 while Present
(Comp
) loop
6466 if Is_Record_Type
(Etype
(Comp
))
6467 and then Has_Discriminants
(Etype
(Comp
))
6468 and then not Is_Constrained
(Etype
(Comp
))
6473 Next_Component
(Comp
);
6477 end Has_Mutable_Components
;
6479 ------------------------------
6480 -- Initialize_Discriminants --
6481 ------------------------------
6483 procedure Initialize_Discriminants
(N
: Node_Id
; Typ
: Entity_Id
) is
6484 Loc
: constant Source_Ptr
:= Sloc
(N
);
6485 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
6486 Par
: constant Entity_Id
:= Etype
(Bas
);
6487 Decl
: constant Node_Id
:= Parent
(Par
);
6491 if Is_Tagged_Type
(Bas
)
6492 and then Is_Derived_Type
(Bas
)
6493 and then Has_Discriminants
(Par
)
6494 and then Has_Discriminants
(Bas
)
6495 and then Number_Discriminants
(Bas
) /= Number_Discriminants
(Par
)
6496 and then Nkind
(Decl
) = N_Full_Type_Declaration
6497 and then Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
6499 (Variant_Part
(Component_List
(Type_Definition
(Decl
))))
6500 and then Nkind
(N
) /= N_Extension_Aggregate
6503 -- Call init proc to set discriminants.
6504 -- There should eventually be a special procedure for this ???
6506 Ref
:= New_Reference_To
(Defining_Identifier
(N
), Loc
);
6507 Insert_Actions_After
(N
,
6508 Build_Initialization_Call
(Sloc
(N
), Ref
, Typ
));
6510 end Initialize_Discriminants
;
6517 (Obj_Type
: Entity_Id
;
6518 Typ
: Entity_Id
) return Boolean
6520 L1
, L2
, H1
, H2
: Node_Id
;
6522 -- No sliding if the type of the object is not established yet, if it is
6523 -- an unconstrained type whose actual subtype comes from the aggregate,
6524 -- or if the two types are identical.
6526 if not Is_Array_Type
(Obj_Type
) then
6529 elsif not Is_Constrained
(Obj_Type
) then
6532 elsif Typ
= Obj_Type
then
6536 -- Sliding can only occur along the first dimension
6538 Get_Index_Bounds
(First_Index
(Typ
), L1
, H1
);
6539 Get_Index_Bounds
(First_Index
(Obj_Type
), L2
, H2
);
6541 if not Is_Static_Expression
(L1
)
6542 or else not Is_Static_Expression
(L2
)
6543 or else not Is_Static_Expression
(H1
)
6544 or else not Is_Static_Expression
(H2
)
6548 return Expr_Value
(L1
) /= Expr_Value
(L2
)
6550 Expr_Value
(H1
) /= Expr_Value
(H2
);
6555 ---------------------------
6556 -- Safe_Slice_Assignment --
6557 ---------------------------
6559 function Safe_Slice_Assignment
(N
: Node_Id
) return Boolean is
6560 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
6561 Pref
: constant Node_Id
:= Prefix
(Name
(Parent
(N
)));
6562 Range_Node
: constant Node_Id
:= Discrete_Range
(Name
(Parent
(N
)));
6570 -- Generate: for J in Range loop Pref (J) := Expr; end loop;
6572 if Comes_From_Source
(N
)
6573 and then No
(Expressions
(N
))
6574 and then Nkind
(First
(Choices
(First
(Component_Associations
(N
)))))
6577 Expr
:= Expression
(First
(Component_Associations
(N
)));
6578 L_J
:= Make_Temporary
(Loc
, 'J');
6581 Make_Iteration_Scheme
(Loc
,
6582 Loop_Parameter_Specification
=>
6583 Make_Loop_Parameter_Specification
6585 Defining_Identifier
=> L_J
,
6586 Discrete_Subtype_Definition
=> Relocate_Node
(Range_Node
)));
6589 Make_Assignment_Statement
(Loc
,
6591 Make_Indexed_Component
(Loc
,
6592 Prefix
=> Relocate_Node
(Pref
),
6593 Expressions
=> New_List
(New_Occurrence_Of
(L_J
, Loc
))),
6594 Expression
=> Relocate_Node
(Expr
));
6596 -- Construct the final loop
6599 Make_Implicit_Loop_Statement
6600 (Node
=> Parent
(N
),
6601 Identifier
=> Empty
,
6602 Iteration_Scheme
=> L_Iter
,
6603 Statements
=> New_List
(L_Body
));
6605 -- Set type of aggregate to be type of lhs in assignment,
6606 -- to suppress redundant length checks.
6608 Set_Etype
(N
, Etype
(Name
(Parent
(N
))));
6610 Rewrite
(Parent
(N
), Stat
);
6611 Analyze
(Parent
(N
));
6617 end Safe_Slice_Assignment
;
6619 ----------------------------------
6620 -- Two_Dim_Packed_Array_Handled --
6621 ----------------------------------
6623 function Two_Dim_Packed_Array_Handled
(N
: Node_Id
) return Boolean is
6624 Loc
: constant Source_Ptr
:= Sloc
(N
);
6625 Typ
: constant Entity_Id
:= Etype
(N
);
6626 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
6627 Comp_Size
: constant Int
:= UI_To_Int
(Component_Size
(Typ
));
6628 Packed_Array
: constant Entity_Id
:= Packed_Array_Type
(Base_Type
(Typ
));
6631 -- Expression in original aggregate
6634 -- One-dimensional subaggregate
6638 -- For now, only deal with cases where an integral number of elements
6639 -- fit in a single byte. This includes the most common boolean case.
6641 if not (Comp_Size
= 1 or else
6642 Comp_Size
= 2 or else
6648 Convert_To_Positional
6649 (N
, Max_Others_Replicate
=> 64, Handle_Bit_Packed
=> True);
6651 -- Verify that all components are static
6653 if Nkind
(N
) = N_Aggregate
6654 and then Compile_Time_Known_Aggregate
(N
)
6658 -- The aggregate may have been re-analyzed and converted already
6660 elsif Nkind
(N
) /= N_Aggregate
then
6663 -- If component associations remain, the aggregate is not static
6665 elsif Present
(Component_Associations
(N
)) then
6669 One_Dim
:= First
(Expressions
(N
));
6670 while Present
(One_Dim
) loop
6671 if Present
(Component_Associations
(One_Dim
)) then
6675 One_Comp
:= First
(Expressions
(One_Dim
));
6676 while Present
(One_Comp
) loop
6677 if not Is_OK_Static_Expression
(One_Comp
) then
6688 -- Two-dimensional aggregate is now fully positional so pack one
6689 -- dimension to create a static one-dimensional array, and rewrite
6690 -- as an unchecked conversion to the original type.
6693 Byte_Size
: constant Int
:= UI_To_Int
(Component_Size
(Packed_Array
));
6694 -- The packed array type is a byte array
6697 -- Number of components accumulated in current byte
6700 -- Assembled list of packed values for equivalent aggregate
6703 -- integer value of component
6706 -- Step size for packing
6709 -- Endian-dependent start position for packing
6712 -- Current insertion position
6715 -- Component of packed array being assembled.
6722 -- Account for endianness. See corresponding comment in
6723 -- Packed_Array_Aggregate_Handled concerning the following.
6727 xor Reverse_Storage_Order
(Base_Type
(Typ
))
6729 Init_Shift
:= Byte_Size
- Comp_Size
;
6736 Shift
:= Init_Shift
;
6737 One_Dim
:= First
(Expressions
(N
));
6739 -- Iterate over each subaggregate
6741 while Present
(One_Dim
) loop
6742 One_Comp
:= First
(Expressions
(One_Dim
));
6744 while Present
(One_Comp
) loop
6745 if Packed_Num
= Byte_Size
/ Comp_Size
then
6747 -- Byte is complete, add to list of expressions
6749 Append
(Make_Integer_Literal
(Sloc
(One_Dim
), Val
), Comps
);
6751 Shift
:= Init_Shift
;
6755 Comp_Val
:= Expr_Rep_Value
(One_Comp
);
6757 -- Adjust for bias, and strip proper number of bits
6759 if Has_Biased_Representation
(Ctyp
) then
6760 Comp_Val
:= Comp_Val
- Expr_Value
(Type_Low_Bound
(Ctyp
));
6763 Comp_Val
:= Comp_Val
mod Uint_2
** Comp_Size
;
6764 Val
:= UI_To_Int
(Val
+ Comp_Val
* Uint_2
** Shift
);
6765 Shift
:= Shift
+ Incr
;
6766 One_Comp
:= Next
(One_Comp
);
6767 Packed_Num
:= Packed_Num
+ 1;
6771 One_Dim
:= Next
(One_Dim
);
6774 if Packed_Num
> 0 then
6776 -- Add final incomplete byte if present
6778 Append
(Make_Integer_Literal
(Sloc
(One_Dim
), Val
), Comps
);
6782 Unchecked_Convert_To
(Typ
,
6783 Make_Qualified_Expression
(Loc
,
6784 Subtype_Mark
=> New_Occurrence_Of
(Packed_Array
, Loc
),
6786 Make_Aggregate
(Loc
, Expressions
=> Comps
))));
6787 Analyze_And_Resolve
(N
);
6790 end Two_Dim_Packed_Array_Handled
;
6792 ---------------------
6793 -- Sort_Case_Table --
6794 ---------------------
6796 procedure Sort_Case_Table
(Case_Table
: in out Case_Table_Type
) is
6797 L
: constant Int
:= Case_Table
'First;
6798 U
: constant Int
:= Case_Table
'Last;
6806 T
:= Case_Table
(K
+ 1);
6810 and then Expr_Value
(Case_Table
(J
- 1).Choice_Lo
) >
6811 Expr_Value
(T
.Choice_Lo
)
6813 Case_Table
(J
) := Case_Table
(J
- 1);
6817 Case_Table
(J
) := T
;
6820 end Sort_Case_Table
;
6822 ----------------------------
6823 -- Static_Array_Aggregate --
6824 ----------------------------
6826 function Static_Array_Aggregate
(N
: Node_Id
) return Boolean is
6827 Bounds
: constant Node_Id
:= Aggregate_Bounds
(N
);
6829 Typ
: constant Entity_Id
:= Etype
(N
);
6830 Comp_Type
: constant Entity_Id
:= Component_Type
(Typ
);
6837 if Is_Tagged_Type
(Typ
)
6838 or else Is_Controlled
(Typ
)
6839 or else Is_Packed
(Typ
)
6845 and then Nkind
(Bounds
) = N_Range
6846 and then Nkind
(Low_Bound
(Bounds
)) = N_Integer_Literal
6847 and then Nkind
(High_Bound
(Bounds
)) = N_Integer_Literal
6849 Lo
:= Low_Bound
(Bounds
);
6850 Hi
:= High_Bound
(Bounds
);
6852 if No
(Component_Associations
(N
)) then
6854 -- Verify that all components are static integers
6856 Expr
:= First
(Expressions
(N
));
6857 while Present
(Expr
) loop
6858 if Nkind
(Expr
) /= N_Integer_Literal
then
6868 -- We allow only a single named association, either a static
6869 -- range or an others_clause, with a static expression.
6871 Expr
:= First
(Component_Associations
(N
));
6873 if Present
(Expressions
(N
)) then
6876 elsif Present
(Next
(Expr
)) then
6879 elsif Present
(Next
(First
(Choices
(Expr
)))) then
6883 -- The aggregate is static if all components are literals,
6884 -- or else all its components are static aggregates for the
6885 -- component type. We also limit the size of a static aggregate
6886 -- to prevent runaway static expressions.
6888 if Is_Array_Type
(Comp_Type
)
6889 or else Is_Record_Type
(Comp_Type
)
6891 if Nkind
(Expression
(Expr
)) /= N_Aggregate
6893 not Compile_Time_Known_Aggregate
(Expression
(Expr
))
6898 elsif Nkind
(Expression
(Expr
)) /= N_Integer_Literal
then
6902 if not Aggr_Size_OK
(N
, Typ
) then
6906 -- Create a positional aggregate with the right number of
6907 -- copies of the expression.
6909 Agg
:= Make_Aggregate
(Sloc
(N
), New_List
, No_List
);
6911 for I
in UI_To_Int
(Intval
(Lo
)) .. UI_To_Int
(Intval
(Hi
))
6914 (Expressions
(Agg
), New_Copy
(Expression
(Expr
)));
6916 -- The copied expression must be analyzed and resolved.
6917 -- Besides setting the type, this ensures that static
6918 -- expressions are appropriately marked as such.
6921 (Last
(Expressions
(Agg
)), Component_Type
(Typ
));
6924 Set_Aggregate_Bounds
(Agg
, Bounds
);
6925 Set_Etype
(Agg
, Typ
);
6928 Set_Compile_Time_Known_Aggregate
(N
);
6937 end Static_Array_Aggregate
;