1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Elists
; use Elists
;
32 with Expander
; use Expander
;
33 with Exp_Util
; use Exp_Util
;
34 with Exp_Ch3
; use Exp_Ch3
;
35 with Exp_Ch7
; use Exp_Ch7
;
36 with Exp_Ch9
; use Exp_Ch9
;
37 with Exp_Tss
; use Exp_Tss
;
38 with Freeze
; use Freeze
;
39 with Hostparm
; use Hostparm
;
40 with Itypes
; use Itypes
;
42 with Nmake
; use Nmake
;
43 with Nlists
; use Nlists
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
47 with Rtsfind
; use Rtsfind
;
48 with Ttypes
; use Ttypes
;
50 with Sem_Ch3
; use Sem_Ch3
;
51 with Sem_Eval
; use Sem_Eval
;
52 with Sem_Res
; use Sem_Res
;
53 with Sem_Util
; use Sem_Util
;
54 with Sinfo
; use Sinfo
;
55 with Snames
; use Snames
;
56 with Stand
; use Stand
;
57 with Tbuild
; use Tbuild
;
58 with Uintp
; use Uintp
;
60 package body Exp_Aggr
is
62 type Case_Bounds
is record
65 Choice_Node
: Node_Id
;
68 type Case_Table_Type
is array (Nat
range <>) of Case_Bounds
;
69 -- Table type used by Check_Case_Choices procedure
72 (Obj_Type
: Entity_Id
;
73 Typ
: Entity_Id
) return Boolean;
74 -- A static array aggregate in an object declaration can in most cases be
75 -- expanded in place. The one exception is when the aggregate is given
76 -- with component associations that specify different bounds from those of
77 -- the type definition in the object declaration. In this pathological
78 -- case the aggregate must slide, and we must introduce an intermediate
79 -- temporary to hold it.
81 -- The same holds in an assignment to one-dimensional array of arrays,
82 -- when a component may be given with bounds that differ from those of the
85 procedure Sort_Case_Table
(Case_Table
: in out Case_Table_Type
);
86 -- Sort the Case Table using the Lower Bound of each Choice as the key.
87 -- A simple insertion sort is used since the number of choices in a case
88 -- statement of variant part will usually be small and probably in near
91 function Has_Default_Init_Comps
(N
: Node_Id
) return Boolean;
92 -- N is an aggregate (record or array). Checks the presence of default
93 -- initialization (<>) in any component (Ada 2005: AI-287)
95 ------------------------------------------------------
96 -- Local subprograms for Record Aggregate Expansion --
97 ------------------------------------------------------
99 procedure Expand_Record_Aggregate
101 Orig_Tag
: Node_Id
:= Empty
;
102 Parent_Expr
: Node_Id
:= Empty
);
103 -- This is the top level procedure for record aggregate expansion.
104 -- Expansion for record aggregates needs expand aggregates for tagged
105 -- record types. Specifically Expand_Record_Aggregate adds the Tag
106 -- field in front of the Component_Association list that was created
107 -- during resolution by Resolve_Record_Aggregate.
109 -- N is the record aggregate node.
110 -- Orig_Tag is the value of the Tag that has to be provided for this
111 -- specific aggregate. It carries the tag corresponding to the type
112 -- of the outermost aggregate during the recursive expansion
113 -- Parent_Expr is the ancestor part of the original extension
116 procedure Convert_To_Assignments
(N
: Node_Id
; Typ
: Entity_Id
);
117 -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of
118 -- the aggregate. Transform the given aggregate into a sequence of
119 -- assignments component per component.
121 function Build_Record_Aggr_Code
125 Flist
: Node_Id
:= Empty
;
126 Obj
: Entity_Id
:= Empty
;
127 Is_Limited_Ancestor_Expansion
: Boolean := False) return List_Id
;
128 -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
129 -- aggregate. Target is an expression containing the location on which the
130 -- component by component assignments will take place. Returns the list of
131 -- assignments plus all other adjustments needed for tagged and controlled
132 -- types. Flist is an expression representing the finalization list on
133 -- which to attach the controlled components if any. Obj is present in the
134 -- object declaration and dynamic allocation cases, it contains an entity
135 -- that allows to know if the value being created needs to be attached to
136 -- the final list in case of pragma finalize_Storage_Only.
138 -- Is_Limited_Ancestor_Expansion indicates that the function has been
139 -- called recursively to expand the limited ancestor to avoid copying it.
141 function Has_Mutable_Components
(Typ
: Entity_Id
) return Boolean;
142 -- Return true if one of the component is of a discriminated type with
143 -- defaults. An aggregate for a type with mutable components must be
144 -- expanded into individual assignments.
146 procedure Initialize_Discriminants
(N
: Node_Id
; Typ
: Entity_Id
);
147 -- If the type of the aggregate is a type extension with renamed discrimi-
148 -- nants, we must initialize the hidden discriminants of the parent.
149 -- Otherwise, the target object must not be initialized. The discriminants
150 -- are initialized by calling the initialization procedure for the type.
151 -- This is incorrect if the initialization of other components has any
152 -- side effects. We restrict this call to the case where the parent type
153 -- has a variant part, because this is the only case where the hidden
154 -- discriminants are accessed, namely when calling discriminant checking
155 -- functions of the parent type, and when applying a stream attribute to
156 -- an object of the derived type.
158 -----------------------------------------------------
159 -- Local Subprograms for Array Aggregate Expansion --
160 -----------------------------------------------------
162 function Aggr_Size_OK
(Typ
: Entity_Id
) return Boolean;
163 -- Very large static aggregates present problems to the back-end, and
164 -- are transformed into assignments and loops. This function verifies
165 -- that the total number of components of an aggregate is acceptable
166 -- for transformation into a purely positional static form. It is called
167 -- prior to calling Flatten.
169 procedure Convert_Array_Aggr_In_Allocator
173 -- If the aggregate appears within an allocator and can be expanded in
174 -- place, this routine generates the individual assignments to components
175 -- of the designated object. This is an optimization over the general
176 -- case, where a temporary is first created on the stack and then used to
177 -- construct the allocated object on the heap.
179 procedure Convert_To_Positional
181 Max_Others_Replicate
: Nat
:= 5;
182 Handle_Bit_Packed
: Boolean := False);
183 -- If possible, convert named notation to positional notation. This
184 -- conversion is possible only in some static cases. If the conversion is
185 -- possible, then N is rewritten with the analyzed converted aggregate.
186 -- The parameter Max_Others_Replicate controls the maximum number of
187 -- values corresponding to an others choice that will be converted to
188 -- positional notation (the default of 5 is the normal limit, and reflects
189 -- the fact that normally the loop is better than a lot of separate
190 -- assignments). Note that this limit gets overridden in any case if
191 -- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
192 -- set. The parameter Handle_Bit_Packed is usually set False (since we do
193 -- not expect the back end to handle bit packed arrays, so the normal case
194 -- of conversion is pointless), but in the special case of a call from
195 -- Packed_Array_Aggregate_Handled, we set this parameter to True, since
196 -- these are cases we handle in there.
198 procedure Expand_Array_Aggregate
(N
: Node_Id
);
199 -- This is the top-level routine to perform array aggregate expansion.
200 -- N is the N_Aggregate node to be expanded.
202 function Backend_Processing_Possible
(N
: Node_Id
) return Boolean;
203 -- This function checks if array aggregate N can be processed directly
204 -- by Gigi. If this is the case True is returned.
206 function Build_Array_Aggr_Code
211 Scalar_Comp
: Boolean;
212 Indices
: List_Id
:= No_List
;
213 Flist
: Node_Id
:= Empty
) return List_Id
;
214 -- This recursive routine returns a list of statements containing the
215 -- loops and assignments that are needed for the expansion of the array
218 -- N is the (sub-)aggregate node to be expanded into code. This node
219 -- has been fully analyzed, and its Etype is properly set.
221 -- Index is the index node corresponding to the array sub-aggregate N.
223 -- Into is the target expression into which we are copying the aggregate.
224 -- Note that this node may not have been analyzed yet, and so the Etype
225 -- field may not be set.
227 -- Scalar_Comp is True if the component type of the aggregate is scalar.
229 -- Indices is the current list of expressions used to index the
230 -- object we are writing into.
232 -- Flist is an expression representing the finalization list on which
233 -- to attach the controlled components if any.
235 function Number_Of_Choices
(N
: Node_Id
) return Nat
;
236 -- Returns the number of discrete choices (not including the others choice
237 -- if present) contained in (sub-)aggregate N.
239 function Late_Expansion
243 Flist
: Node_Id
:= Empty
;
244 Obj
: Entity_Id
:= Empty
) return List_Id
;
245 -- N is a nested (record or array) aggregate that has been marked with
246 -- 'Delay_Expansion'. Typ is the expected type of the aggregate and Target
247 -- is a (duplicable) expression that will hold the result of the aggregate
248 -- expansion. Flist is the finalization list to be used to attach
249 -- controlled components. 'Obj' when non empty, carries the original
250 -- object being initialized in order to know if it needs to be attached to
251 -- the previous parameter which may not be the case in the case where
252 -- Finalize_Storage_Only is set. Basically this procedure is used to
253 -- implement top-down expansions of nested aggregates. This is necessary
254 -- for avoiding temporaries at each level as well as for propagating the
255 -- right internal finalization list.
257 function Make_OK_Assignment_Statement
260 Expression
: Node_Id
;
261 Self_Ref
: Boolean := False) return Node_Id
;
262 -- This is like Make_Assignment_Statement, except that Assignment_OK
263 -- is set in the left operand. All assignments built by this unit
264 -- use this routine. This is needed to deal with assignments to
265 -- initialized constants that are done in place.
266 -- If Self_Ref is true, the aggregate contains an access reference to the
267 -- enclosing type, obtained from a default initialization. The reference
268 -- as to be expanded into a reference to the enclosing object, which is
269 -- obtained from the Name in the assignment. The value of Self_Ref is
270 -- inherited from the aggregate itself.
272 function Packed_Array_Aggregate_Handled
(N
: Node_Id
) return Boolean;
273 -- Given an array aggregate, this function handles the case of a packed
274 -- array aggregate with all constant values, where the aggregate can be
275 -- evaluated at compile time. If this is possible, then N is rewritten
276 -- to be its proper compile time value with all the components properly
277 -- assembled. The expression is analyzed and resolved and True is
278 -- returned. If this transformation is not possible, N is unchanged
279 -- and False is returned
281 function Safe_Slice_Assignment
(N
: Node_Id
) return Boolean;
282 -- If a slice assignment has an aggregate with a single others_choice,
283 -- the assignment can be done in place even if bounds are not static,
284 -- by converting it into a loop over the discrete range of the slice.
290 function Aggr_Size_OK
(Typ
: Entity_Id
) return Boolean is
298 -- The following constant determines the maximum size of an
299 -- aggregate produced by converting named to positional
300 -- notation (e.g. from others clauses). This avoids running
301 -- away with attempts to convert huge aggregates, which hit
302 -- memory limits in the backend.
304 -- The normal limit is 5000, but we increase this limit to
305 -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code)
306 -- or Restrictions (No_Implicit_Loops) is specified, since in
307 -- either case, we are at risk of declaring the program illegal
308 -- because of this limit.
310 Max_Aggr_Size
: constant Nat
:=
311 5000 + (2 ** 24 - 5000) *
313 (Restriction_Active
(No_Elaboration_Code
)
315 Restriction_Active
(No_Implicit_Loops
));
317 function Component_Count
(T
: Entity_Id
) return Int
;
318 -- The limit is applied to the total number of components that the
319 -- aggregate will have, which is the number of static expressions
320 -- that will appear in the flattened array. This requires a recursive
321 -- computation of the the number of scalar components of the structure.
323 ---------------------
324 -- Component_Count --
325 ---------------------
327 function Component_Count
(T
: Entity_Id
) return Int
is
332 if Is_Scalar_Type
(T
) then
335 elsif Is_Record_Type
(T
) then
336 Comp
:= First_Component
(T
);
337 while Present
(Comp
) loop
338 Res
:= Res
+ Component_Count
(Etype
(Comp
));
339 Next_Component
(Comp
);
344 elsif Is_Array_Type
(T
) then
346 Lo
: constant Node_Id
:=
347 Type_Low_Bound
(Etype
(First_Index
(T
)));
348 Hi
: constant Node_Id
:=
349 Type_High_Bound
(Etype
(First_Index
(T
)));
351 Siz
: constant Int
:= Component_Count
(Component_Type
(T
));
354 if not Compile_Time_Known_Value
(Lo
)
355 or else not Compile_Time_Known_Value
(Hi
)
360 Siz
* UI_To_Int
(Expr_Value
(Hi
) - Expr_Value
(Lo
) + 1);
365 -- Can only be a null for an access type
371 -- Start of processing for Aggr_Size_OK
374 Siz
:= Component_Count
(Component_Type
(Typ
));
375 Indx
:= First_Index
(Typ
);
377 while Present
(Indx
) loop
378 Lo
:= Type_Low_Bound
(Etype
(Indx
));
379 Hi
:= Type_High_Bound
(Etype
(Indx
));
381 -- Bounds need to be known at compile time
383 if not Compile_Time_Known_Value
(Lo
)
384 or else not Compile_Time_Known_Value
(Hi
)
389 Lov
:= Expr_Value
(Lo
);
390 Hiv
:= Expr_Value
(Hi
);
392 -- A flat array is always safe
399 Rng
: constant Uint
:= Hiv
- Lov
+ 1;
402 -- Check if size is too large
404 if not UI_Is_In_Int_Range
(Rng
) then
408 Siz
:= Siz
* UI_To_Int
(Rng
);
412 or else Siz
> Max_Aggr_Size
417 -- Bounds must be in integer range, for later array construction
419 if not UI_Is_In_Int_Range
(Lov
)
421 not UI_Is_In_Int_Range
(Hiv
)
432 ---------------------------------
433 -- Backend_Processing_Possible --
434 ---------------------------------
436 -- Backend processing by Gigi/gcc is possible only if all the following
437 -- conditions are met:
439 -- 1. N is fully positional
441 -- 2. N is not a bit-packed array aggregate;
443 -- 3. The size of N's array type must be known at compile time. Note
444 -- that this implies that the component size is also known
446 -- 4. The array type of N does not follow the Fortran layout convention
447 -- or if it does it must be 1 dimensional.
449 -- 5. The array component type is tagged, which may necessitate
450 -- reassignment of proper tags.
452 -- 6. The array component type might have unaligned bit components
454 function Backend_Processing_Possible
(N
: Node_Id
) return Boolean is
455 Typ
: constant Entity_Id
:= Etype
(N
);
456 -- Typ is the correct constrained array subtype of the aggregate
458 function Static_Check
(N
: Node_Id
; Index
: Node_Id
) return Boolean;
459 -- Recursively checks that N is fully positional, returns true if so
465 function Static_Check
(N
: Node_Id
; Index
: Node_Id
) return Boolean is
469 -- Check for component associations
471 if Present
(Component_Associations
(N
)) then
475 -- Recurse to check subaggregates, which may appear in qualified
476 -- expressions. If delayed, the front-end will have to expand.
478 Expr
:= First
(Expressions
(N
));
480 while Present
(Expr
) loop
482 if Is_Delayed_Aggregate
(Expr
) then
486 if Present
(Next_Index
(Index
))
487 and then not Static_Check
(Expr
, Next_Index
(Index
))
498 -- Start of processing for Backend_Processing_Possible
501 -- Checks 2 (array must not be bit packed)
503 if Is_Bit_Packed_Array
(Typ
) then
507 -- Checks 4 (array must not be multi-dimensional Fortran case)
509 if Convention
(Typ
) = Convention_Fortran
510 and then Number_Dimensions
(Typ
) > 1
515 -- Checks 3 (size of array must be known at compile time)
517 if not Size_Known_At_Compile_Time
(Typ
) then
521 -- Checks 1 (aggregate must be fully positional)
523 if not Static_Check
(N
, First_Index
(Typ
)) then
527 -- Checks 5 (if the component type is tagged, then we may need
528 -- to do tag adjustments; perhaps this should be refined to check for
529 -- any component associations that actually need tag adjustment,
530 -- along the lines of the test that is carried out in
531 -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps for record aggregates
532 -- with tagged components, but not clear whether it's worthwhile ???;
533 -- in the case of the JVM, object tags are handled implicitly)
535 if Is_Tagged_Type
(Component_Type
(Typ
)) and then not Java_VM
then
539 -- Checks 6 (component type must not have bit aligned components)
541 if Type_May_Have_Bit_Aligned_Components
(Component_Type
(Typ
)) then
545 -- Backend processing is possible
547 Set_Compile_Time_Known_Aggregate
(N
, True);
548 Set_Size_Known_At_Compile_Time
(Etype
(N
), True);
550 end Backend_Processing_Possible
;
552 ---------------------------
553 -- Build_Array_Aggr_Code --
554 ---------------------------
556 -- The code that we generate from a one dimensional aggregate is
558 -- 1. If the sub-aggregate contains discrete choices we
560 -- (a) Sort the discrete choices
562 -- (b) Otherwise for each discrete choice that specifies a range we
563 -- emit a loop. If a range specifies a maximum of three values, or
564 -- we are dealing with an expression we emit a sequence of
565 -- assignments instead of a loop.
567 -- (c) Generate the remaining loops to cover the others choice if any
569 -- 2. If the aggregate contains positional elements we
571 -- (a) translate the positional elements in a series of assignments
573 -- (b) Generate a final loop to cover the others choice if any.
574 -- Note that this final loop has to be a while loop since the case
576 -- L : Integer := Integer'Last;
577 -- H : Integer := Integer'Last;
578 -- A : array (L .. H) := (1, others =>0);
580 -- cannot be handled by a for loop. Thus for the following
582 -- array (L .. H) := (.. positional elements.., others =>E);
584 -- we always generate something like:
586 -- J : Index_Type := Index_Of_Last_Positional_Element;
588 -- J := Index_Base'Succ (J)
592 function Build_Array_Aggr_Code
597 Scalar_Comp
: Boolean;
598 Indices
: List_Id
:= No_List
;
599 Flist
: Node_Id
:= Empty
) return List_Id
601 Loc
: constant Source_Ptr
:= Sloc
(N
);
602 Index_Base
: constant Entity_Id
:= Base_Type
(Etype
(Index
));
603 Index_Base_L
: constant Node_Id
:= Type_Low_Bound
(Index_Base
);
604 Index_Base_H
: constant Node_Id
:= Type_High_Bound
(Index_Base
);
606 function Add
(Val
: Int
; To
: Node_Id
) return Node_Id
;
607 -- Returns an expression where Val is added to expression To, unless
608 -- To+Val is provably out of To's base type range. To must be an
609 -- already analyzed expression.
611 function Empty_Range
(L
, H
: Node_Id
) return Boolean;
612 -- Returns True if the range defined by L .. H is certainly empty
614 function Equal
(L
, H
: Node_Id
) return Boolean;
615 -- Returns True if L = H for sure
617 function Index_Base_Name
return Node_Id
;
618 -- Returns a new reference to the index type name
620 function Gen_Assign
(Ind
: Node_Id
; Expr
: Node_Id
) return List_Id
;
621 -- Ind must be a side-effect free expression. If the input aggregate
622 -- N to Build_Loop contains no sub-aggregates, then this function
623 -- returns the assignment statement:
625 -- Into (Indices, Ind) := Expr;
627 -- Otherwise we call Build_Code recursively
629 -- Ada 2005 (AI-287): In case of default initialized component, Expr
630 -- is empty and we generate a call to the corresponding IP subprogram.
632 function Gen_Loop
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
;
633 -- Nodes L and H must be side-effect free expressions.
634 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
635 -- This routine returns the for loop statement
637 -- for J in Index_Base'(L) .. Index_Base'(H) loop
638 -- Into (Indices, J) := Expr;
641 -- Otherwise we call Build_Code recursively.
642 -- As an optimization if the loop covers 3 or less scalar elements we
643 -- generate a sequence of assignments.
645 function Gen_While
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
;
646 -- Nodes L and H must be side-effect free expressions.
647 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
648 -- This routine returns the while loop statement
650 -- J : Index_Base := L;
652 -- J := Index_Base'Succ (J);
653 -- Into (Indices, J) := Expr;
656 -- Otherwise we call Build_Code recursively
658 function Local_Compile_Time_Known_Value
(E
: Node_Id
) return Boolean;
659 function Local_Expr_Value
(E
: Node_Id
) return Uint
;
660 -- These two Local routines are used to replace the corresponding ones
661 -- in sem_eval because while processing the bounds of an aggregate with
662 -- discrete choices whose index type is an enumeration, we build static
663 -- expressions not recognized by Compile_Time_Known_Value as such since
664 -- they have not yet been analyzed and resolved. All the expressions in
665 -- question are things like Index_Base_Name'Val (Const) which we can
666 -- easily recognize as being constant.
672 function Add
(Val
: Int
; To
: Node_Id
) return Node_Id
is
677 U_Val
: constant Uint
:= UI_From_Int
(Val
);
680 -- Note: do not try to optimize the case of Val = 0, because
681 -- we need to build a new node with the proper Sloc value anyway.
683 -- First test if we can do constant folding
685 if Local_Compile_Time_Known_Value
(To
) then
686 U_To
:= Local_Expr_Value
(To
) + Val
;
688 -- Determine if our constant is outside the range of the index.
689 -- If so return an Empty node. This empty node will be caught
690 -- by Empty_Range below.
692 if Compile_Time_Known_Value
(Index_Base_L
)
693 and then U_To
< Expr_Value
(Index_Base_L
)
697 elsif Compile_Time_Known_Value
(Index_Base_H
)
698 and then U_To
> Expr_Value
(Index_Base_H
)
703 Expr_Pos
:= Make_Integer_Literal
(Loc
, U_To
);
704 Set_Is_Static_Expression
(Expr_Pos
);
706 if not Is_Enumeration_Type
(Index_Base
) then
709 -- If we are dealing with enumeration return
710 -- Index_Base'Val (Expr_Pos)
714 Make_Attribute_Reference
716 Prefix
=> Index_Base_Name
,
717 Attribute_Name
=> Name_Val
,
718 Expressions
=> New_List
(Expr_Pos
));
724 -- If we are here no constant folding possible
726 if not Is_Enumeration_Type
(Index_Base
) then
729 Left_Opnd
=> Duplicate_Subexpr
(To
),
730 Right_Opnd
=> Make_Integer_Literal
(Loc
, U_Val
));
732 -- If we are dealing with enumeration return
733 -- Index_Base'Val (Index_Base'Pos (To) + Val)
737 Make_Attribute_Reference
739 Prefix
=> Index_Base_Name
,
740 Attribute_Name
=> Name_Pos
,
741 Expressions
=> New_List
(Duplicate_Subexpr
(To
)));
746 Right_Opnd
=> Make_Integer_Literal
(Loc
, U_Val
));
749 Make_Attribute_Reference
751 Prefix
=> Index_Base_Name
,
752 Attribute_Name
=> Name_Val
,
753 Expressions
=> New_List
(Expr_Pos
));
763 function Empty_Range
(L
, H
: Node_Id
) return Boolean is
764 Is_Empty
: Boolean := False;
769 -- First check if L or H were already detected as overflowing the
770 -- index base range type by function Add above. If this is so Add
771 -- returns the empty node.
773 if No
(L
) or else No
(H
) then
780 -- L > H range is empty
786 -- B_L > H range must be empty
792 -- L > B_H range must be empty
796 High
:= Index_Base_H
;
799 if Local_Compile_Time_Known_Value
(Low
)
800 and then Local_Compile_Time_Known_Value
(High
)
803 UI_Gt
(Local_Expr_Value
(Low
), Local_Expr_Value
(High
));
816 function Equal
(L
, H
: Node_Id
) return Boolean is
821 elsif Local_Compile_Time_Known_Value
(L
)
822 and then Local_Compile_Time_Known_Value
(H
)
824 return UI_Eq
(Local_Expr_Value
(L
), Local_Expr_Value
(H
));
834 function Gen_Assign
(Ind
: Node_Id
; Expr
: Node_Id
) return List_Id
is
835 L
: constant List_Id
:= New_List
;
839 New_Indices
: List_Id
;
840 Indexed_Comp
: Node_Id
;
842 Comp_Type
: Entity_Id
:= Empty
;
844 function Add_Loop_Actions
(Lis
: List_Id
) return List_Id
;
845 -- Collect insert_actions generated in the construction of a
846 -- loop, and prepend them to the sequence of assignments to
847 -- complete the eventual body of the loop.
849 ----------------------
850 -- Add_Loop_Actions --
851 ----------------------
853 function Add_Loop_Actions
(Lis
: List_Id
) return List_Id
is
857 -- Ada 2005 (AI-287): Do nothing else in case of default
858 -- initialized component.
863 elsif Nkind
(Parent
(Expr
)) = N_Component_Association
864 and then Present
(Loop_Actions
(Parent
(Expr
)))
866 Append_List
(Lis
, Loop_Actions
(Parent
(Expr
)));
867 Res
:= Loop_Actions
(Parent
(Expr
));
868 Set_Loop_Actions
(Parent
(Expr
), No_List
);
874 end Add_Loop_Actions
;
876 -- Start of processing for Gen_Assign
880 New_Indices
:= New_List
;
882 New_Indices
:= New_Copy_List_Tree
(Indices
);
885 Append_To
(New_Indices
, Ind
);
887 if Present
(Flist
) then
888 F
:= New_Copy_Tree
(Flist
);
890 elsif Present
(Etype
(N
)) and then Controlled_Type
(Etype
(N
)) then
891 if Is_Entity_Name
(Into
)
892 and then Present
(Scope
(Entity
(Into
)))
894 F
:= Find_Final_List
(Scope
(Entity
(Into
)));
896 F
:= Find_Final_List
(Current_Scope
);
902 if Present
(Next_Index
(Index
)) then
905 Build_Array_Aggr_Code
908 Index
=> Next_Index
(Index
),
910 Scalar_Comp
=> Scalar_Comp
,
911 Indices
=> New_Indices
,
915 -- If we get here then we are at a bottom-level (sub-)aggregate
919 (Make_Indexed_Component
(Loc
,
920 Prefix
=> New_Copy_Tree
(Into
),
921 Expressions
=> New_Indices
));
923 Set_Assignment_OK
(Indexed_Comp
);
925 -- Ada 2005 (AI-287): In case of default initialized component, Expr
926 -- is not present (and therefore we also initialize Expr_Q to empty).
930 elsif Nkind
(Expr
) = N_Qualified_Expression
then
931 Expr_Q
:= Expression
(Expr
);
936 if Present
(Etype
(N
))
937 and then Etype
(N
) /= Any_Composite
939 Comp_Type
:= Component_Type
(Etype
(N
));
940 pragma Assert
(Comp_Type
= Ctype
); -- AI-287
942 elsif Present
(Next
(First
(New_Indices
))) then
944 -- Ada 2005 (AI-287): Do nothing in case of default initialized
945 -- component because we have received the component type in
946 -- the formal parameter Ctype.
948 -- ??? Some assert pragmas have been added to check if this new
949 -- formal can be used to replace this code in all cases.
951 if Present
(Expr
) then
953 -- This is a multidimensional array. Recover the component
954 -- type from the outermost aggregate, because subaggregates
955 -- do not have an assigned type.
958 P
: Node_Id
:= Parent
(Expr
);
961 while Present
(P
) loop
962 if Nkind
(P
) = N_Aggregate
963 and then Present
(Etype
(P
))
965 Comp_Type
:= Component_Type
(Etype
(P
));
973 pragma Assert
(Comp_Type
= Ctype
); -- AI-287
978 -- Ada 2005 (AI-287): We only analyze the expression in case of non-
979 -- default initialized components (otherwise Expr_Q is not present).
982 and then (Nkind
(Expr_Q
) = N_Aggregate
983 or else Nkind
(Expr_Q
) = N_Extension_Aggregate
)
985 -- At this stage the Expression may not have been
986 -- analyzed yet because the array aggregate code has not
987 -- been updated to use the Expansion_Delayed flag and
988 -- avoid analysis altogether to solve the same problem
989 -- (see Resolve_Aggr_Expr). So let us do the analysis of
990 -- non-array aggregates now in order to get the value of
991 -- Expansion_Delayed flag for the inner aggregate ???
993 if Present
(Comp_Type
) and then not Is_Array_Type
(Comp_Type
) then
994 Analyze_And_Resolve
(Expr_Q
, Comp_Type
);
997 if Is_Delayed_Aggregate
(Expr_Q
) then
999 -- This is either a subaggregate of a multidimentional array,
1000 -- or a component of an array type whose component type is
1001 -- also an array. In the latter case, the expression may have
1002 -- component associations that provide different bounds from
1003 -- those of the component type, and sliding must occur. Instead
1004 -- of decomposing the current aggregate assignment, force the
1005 -- re-analysis of the assignment, so that a temporary will be
1006 -- generated in the usual fashion, and sliding will take place.
1008 if Nkind
(Parent
(N
)) = N_Assignment_Statement
1009 and then Is_Array_Type
(Comp_Type
)
1010 and then Present
(Component_Associations
(Expr_Q
))
1011 and then Must_Slide
(Comp_Type
, Etype
(Expr_Q
))
1013 Set_Expansion_Delayed
(Expr_Q
, False);
1014 Set_Analyzed
(Expr_Q
, False);
1020 Expr_Q
, Etype
(Expr_Q
), Indexed_Comp
, F
));
1025 -- Ada 2005 (AI-287): In case of default initialized component, call
1026 -- the initialization subprogram associated with the component type.
1029 if Present
(Base_Init_Proc
(Etype
(Ctype
)))
1030 or else Has_Task
(Base_Type
(Ctype
))
1033 Build_Initialization_Call
(Loc
,
1034 Id_Ref
=> Indexed_Comp
,
1036 With_Default_Init
=> True));
1040 -- Now generate the assignment with no associated controlled
1041 -- actions since the target of the assignment may not have
1042 -- been initialized, it is not possible to Finalize it as
1043 -- expected by normal controlled assignment. The rest of the
1044 -- controlled actions are done manually with the proper
1045 -- finalization list coming from the context.
1048 Make_OK_Assignment_Statement
(Loc
,
1049 Name
=> Indexed_Comp
,
1050 Expression
=> New_Copy_Tree
(Expr
));
1052 if Present
(Comp_Type
) and then Controlled_Type
(Comp_Type
) then
1053 Set_No_Ctrl_Actions
(A
);
1055 -- If this is an aggregate for an array of arrays, each
1056 -- subaggregate will be expanded as well, and even with
1057 -- No_Ctrl_Actions the assignments of inner components will
1058 -- require attachment in their assignments to temporaries.
1059 -- These temporaries must be finalized for each subaggregate,
1060 -- to prevent multiple attachments of the same temporary
1061 -- location to same finalization chain (and consequently
1062 -- circular lists). To ensure that finalization takes place
1063 -- for each subaggregate we wrap the assignment in a block.
1065 if Is_Array_Type
(Comp_Type
)
1066 and then Nkind
(Expr
) = N_Aggregate
1069 Make_Block_Statement
(Loc
,
1070 Handled_Statement_Sequence
=>
1071 Make_Handled_Sequence_Of_Statements
(Loc
,
1072 Statements
=> New_List
(A
)));
1078 -- Adjust the tag if tagged (because of possible view
1079 -- conversions), unless compiling for the Java VM
1080 -- where tags are implicit.
1082 if Present
(Comp_Type
)
1083 and then Is_Tagged_Type
(Comp_Type
)
1084 and then not Java_VM
1087 Make_OK_Assignment_Statement
(Loc
,
1089 Make_Selected_Component
(Loc
,
1090 Prefix
=> New_Copy_Tree
(Indexed_Comp
),
1093 (First_Tag_Component
(Comp_Type
), Loc
)),
1096 Unchecked_Convert_To
(RTE
(RE_Tag
),
1098 (Node
(First_Elmt
(Access_Disp_Table
(Comp_Type
))),
1104 -- Adjust and Attach the component to the proper final list
1105 -- which can be the controller of the outer record object or
1106 -- the final list associated with the scope
1108 if Present
(Comp_Type
) and then Controlled_Type
(Comp_Type
) then
1111 Ref
=> New_Copy_Tree
(Indexed_Comp
),
1114 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1118 return Add_Loop_Actions
(L
);
1125 function Gen_Loop
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
is
1129 -- Index_Base'(L) .. Index_Base'(H)
1131 L_Iteration_Scheme
: Node_Id
;
1132 -- L_J in Index_Base'(L) .. Index_Base'(H)
1135 -- The statements to execute in the loop
1137 S
: constant List_Id
:= New_List
;
1138 -- List of statements
1141 -- Copy of expression tree, used for checking purposes
1144 -- If loop bounds define an empty range return the null statement
1146 if Empty_Range
(L
, H
) then
1147 Append_To
(S
, Make_Null_Statement
(Loc
));
1149 -- Ada 2005 (AI-287): Nothing else need to be done in case of
1150 -- default initialized component.
1156 -- The expression must be type-checked even though no component
1157 -- of the aggregate will have this value. This is done only for
1158 -- actual components of the array, not for subaggregates. Do
1159 -- the check on a copy, because the expression may be shared
1160 -- among several choices, some of which might be non-null.
1162 if Present
(Etype
(N
))
1163 and then Is_Array_Type
(Etype
(N
))
1164 and then No
(Next_Index
(Index
))
1166 Expander_Mode_Save_And_Set
(False);
1167 Tcopy
:= New_Copy_Tree
(Expr
);
1168 Set_Parent
(Tcopy
, N
);
1169 Analyze_And_Resolve
(Tcopy
, Component_Type
(Etype
(N
)));
1170 Expander_Mode_Restore
;
1176 -- If loop bounds are the same then generate an assignment
1178 elsif Equal
(L
, H
) then
1179 return Gen_Assign
(New_Copy_Tree
(L
), Expr
);
1181 -- If H - L <= 2 then generate a sequence of assignments
1182 -- when we are processing the bottom most aggregate and it contains
1183 -- scalar components.
1185 elsif No
(Next_Index
(Index
))
1186 and then Scalar_Comp
1187 and then Local_Compile_Time_Known_Value
(L
)
1188 and then Local_Compile_Time_Known_Value
(H
)
1189 and then Local_Expr_Value
(H
) - Local_Expr_Value
(L
) <= 2
1192 Append_List_To
(S
, Gen_Assign
(New_Copy_Tree
(L
), Expr
));
1193 Append_List_To
(S
, Gen_Assign
(Add
(1, To
=> L
), Expr
));
1195 if Local_Expr_Value
(H
) - Local_Expr_Value
(L
) = 2 then
1196 Append_List_To
(S
, Gen_Assign
(Add
(2, To
=> L
), Expr
));
1202 -- Otherwise construct the loop, starting with the loop index L_J
1204 L_J
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
1206 -- Construct "L .. H"
1211 Low_Bound
=> Make_Qualified_Expression
1213 Subtype_Mark
=> Index_Base_Name
,
1215 High_Bound
=> Make_Qualified_Expression
1217 Subtype_Mark
=> Index_Base_Name
,
1220 -- Construct "for L_J in Index_Base range L .. H"
1222 L_Iteration_Scheme
:=
1223 Make_Iteration_Scheme
1225 Loop_Parameter_Specification
=>
1226 Make_Loop_Parameter_Specification
1228 Defining_Identifier
=> L_J
,
1229 Discrete_Subtype_Definition
=> L_Range
));
1231 -- Construct the statements to execute in the loop body
1233 L_Body
:= Gen_Assign
(New_Reference_To
(L_J
, Loc
), Expr
);
1235 -- Construct the final loop
1237 Append_To
(S
, Make_Implicit_Loop_Statement
1239 Identifier
=> Empty
,
1240 Iteration_Scheme
=> L_Iteration_Scheme
,
1241 Statements
=> L_Body
));
1250 -- The code built is
1252 -- W_J : Index_Base := L;
1253 -- while W_J < H loop
1254 -- W_J := Index_Base'Succ (W);
1258 function Gen_While
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
is
1262 -- W_J : Base_Type := L;
1264 W_Iteration_Scheme
: Node_Id
;
1267 W_Index_Succ
: Node_Id
;
1268 -- Index_Base'Succ (J)
1270 W_Increment
: Node_Id
;
1271 -- W_J := Index_Base'Succ (W)
1273 W_Body
: constant List_Id
:= New_List
;
1274 -- The statements to execute in the loop
1276 S
: constant List_Id
:= New_List
;
1277 -- list of statement
1280 -- If loop bounds define an empty range or are equal return null
1282 if Empty_Range
(L
, H
) or else Equal
(L
, H
) then
1283 Append_To
(S
, Make_Null_Statement
(Loc
));
1287 -- Build the decl of W_J
1289 W_J
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
1291 Make_Object_Declaration
1293 Defining_Identifier
=> W_J
,
1294 Object_Definition
=> Index_Base_Name
,
1297 -- Theoretically we should do a New_Copy_Tree (L) here, but we know
1298 -- that in this particular case L is a fresh Expr generated by
1299 -- Add which we are the only ones to use.
1301 Append_To
(S
, W_Decl
);
1303 -- Construct " while W_J < H"
1305 W_Iteration_Scheme
:=
1306 Make_Iteration_Scheme
1308 Condition
=> Make_Op_Lt
1310 Left_Opnd
=> New_Reference_To
(W_J
, Loc
),
1311 Right_Opnd
=> New_Copy_Tree
(H
)));
1313 -- Construct the statements to execute in the loop body
1316 Make_Attribute_Reference
1318 Prefix
=> Index_Base_Name
,
1319 Attribute_Name
=> Name_Succ
,
1320 Expressions
=> New_List
(New_Reference_To
(W_J
, Loc
)));
1323 Make_OK_Assignment_Statement
1325 Name
=> New_Reference_To
(W_J
, Loc
),
1326 Expression
=> W_Index_Succ
);
1328 Append_To
(W_Body
, W_Increment
);
1329 Append_List_To
(W_Body
,
1330 Gen_Assign
(New_Reference_To
(W_J
, Loc
), Expr
));
1332 -- Construct the final loop
1334 Append_To
(S
, Make_Implicit_Loop_Statement
1336 Identifier
=> Empty
,
1337 Iteration_Scheme
=> W_Iteration_Scheme
,
1338 Statements
=> W_Body
));
1343 ---------------------
1344 -- Index_Base_Name --
1345 ---------------------
1347 function Index_Base_Name
return Node_Id
is
1349 return New_Reference_To
(Index_Base
, Sloc
(N
));
1350 end Index_Base_Name
;
1352 ------------------------------------
1353 -- Local_Compile_Time_Known_Value --
1354 ------------------------------------
1356 function Local_Compile_Time_Known_Value
(E
: Node_Id
) return Boolean is
1358 return Compile_Time_Known_Value
(E
)
1360 (Nkind
(E
) = N_Attribute_Reference
1361 and then Attribute_Name
(E
) = Name_Val
1362 and then Compile_Time_Known_Value
(First
(Expressions
(E
))));
1363 end Local_Compile_Time_Known_Value
;
1365 ----------------------
1366 -- Local_Expr_Value --
1367 ----------------------
1369 function Local_Expr_Value
(E
: Node_Id
) return Uint
is
1371 if Compile_Time_Known_Value
(E
) then
1372 return Expr_Value
(E
);
1374 return Expr_Value
(First
(Expressions
(E
)));
1376 end Local_Expr_Value
;
1378 -- Build_Array_Aggr_Code Variables
1385 Others_Expr
: Node_Id
:= Empty
;
1386 Others_Box_Present
: Boolean := False;
1388 Aggr_L
: constant Node_Id
:= Low_Bound
(Aggregate_Bounds
(N
));
1389 Aggr_H
: constant Node_Id
:= High_Bound
(Aggregate_Bounds
(N
));
1390 -- The aggregate bounds of this specific sub-aggregate. Note that if
1391 -- the code generated by Build_Array_Aggr_Code is executed then these
1392 -- bounds are OK. Otherwise a Constraint_Error would have been raised.
1394 Aggr_Low
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Aggr_L
);
1395 Aggr_High
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Aggr_H
);
1396 -- After Duplicate_Subexpr these are side-effect free
1401 Nb_Choices
: Nat
:= 0;
1402 Table
: Case_Table_Type
(1 .. Number_Of_Choices
(N
));
1403 -- Used to sort all the different choice values
1406 -- Number of elements in the positional aggregate
1408 New_Code
: constant List_Id
:= New_List
;
1410 -- Start of processing for Build_Array_Aggr_Code
1413 -- First before we start, a special case. if we have a bit packed
1414 -- array represented as a modular type, then clear the value to
1415 -- zero first, to ensure that unused bits are properly cleared.
1420 and then Is_Bit_Packed_Array
(Typ
)
1421 and then Is_Modular_Integer_Type
(Packed_Array_Type
(Typ
))
1423 Append_To
(New_Code
,
1424 Make_Assignment_Statement
(Loc
,
1425 Name
=> New_Copy_Tree
(Into
),
1427 Unchecked_Convert_To
(Typ
,
1428 Make_Integer_Literal
(Loc
, Uint_0
))));
1432 -- STEP 1: Process component associations
1433 -- For those associations that may generate a loop, initialize
1434 -- Loop_Actions to collect inserted actions that may be crated.
1436 if No
(Expressions
(N
)) then
1438 -- STEP 1 (a): Sort the discrete choices
1440 Assoc
:= First
(Component_Associations
(N
));
1441 while Present
(Assoc
) loop
1442 Choice
:= First
(Choices
(Assoc
));
1443 while Present
(Choice
) loop
1444 if Nkind
(Choice
) = N_Others_Choice
then
1445 Set_Loop_Actions
(Assoc
, New_List
);
1447 if Box_Present
(Assoc
) then
1448 Others_Box_Present
:= True;
1450 Others_Expr
:= Expression
(Assoc
);
1455 Get_Index_Bounds
(Choice
, Low
, High
);
1458 Set_Loop_Actions
(Assoc
, New_List
);
1461 Nb_Choices
:= Nb_Choices
+ 1;
1462 if Box_Present
(Assoc
) then
1463 Table
(Nb_Choices
) := (Choice_Lo
=> Low
,
1465 Choice_Node
=> Empty
);
1467 Table
(Nb_Choices
) := (Choice_Lo
=> Low
,
1469 Choice_Node
=> Expression
(Assoc
));
1477 -- If there is more than one set of choices these must be static
1478 -- and we can therefore sort them. Remember that Nb_Choices does not
1479 -- account for an others choice.
1481 if Nb_Choices
> 1 then
1482 Sort_Case_Table
(Table
);
1485 -- STEP 1 (b): take care of the whole set of discrete choices
1487 for J
in 1 .. Nb_Choices
loop
1488 Low
:= Table
(J
).Choice_Lo
;
1489 High
:= Table
(J
).Choice_Hi
;
1490 Expr
:= Table
(J
).Choice_Node
;
1491 Append_List
(Gen_Loop
(Low
, High
, Expr
), To
=> New_Code
);
1494 -- STEP 1 (c): generate the remaining loops to cover others choice
1495 -- We don't need to generate loops over empty gaps, but if there is
1496 -- a single empty range we must analyze the expression for semantics
1498 if Present
(Others_Expr
) or else Others_Box_Present
then
1500 First
: Boolean := True;
1503 for J
in 0 .. Nb_Choices
loop
1507 Low
:= Add
(1, To
=> Table
(J
).Choice_Hi
);
1510 if J
= Nb_Choices
then
1513 High
:= Add
(-1, To
=> Table
(J
+ 1).Choice_Lo
);
1516 -- If this is an expansion within an init proc, make
1517 -- sure that discriminant references are replaced by
1518 -- the corresponding discriminal.
1520 if Inside_Init_Proc
then
1521 if Is_Entity_Name
(Low
)
1522 and then Ekind
(Entity
(Low
)) = E_Discriminant
1524 Set_Entity
(Low
, Discriminal
(Entity
(Low
)));
1527 if Is_Entity_Name
(High
)
1528 and then Ekind
(Entity
(High
)) = E_Discriminant
1530 Set_Entity
(High
, Discriminal
(Entity
(High
)));
1535 or else not Empty_Range
(Low
, High
)
1539 (Gen_Loop
(Low
, High
, Others_Expr
), To
=> New_Code
);
1545 -- STEP 2: Process positional components
1548 -- STEP 2 (a): Generate the assignments for each positional element
1549 -- Note that here we have to use Aggr_L rather than Aggr_Low because
1550 -- Aggr_L is analyzed and Add wants an analyzed expression.
1552 Expr
:= First
(Expressions
(N
));
1555 while Present
(Expr
) loop
1556 Nb_Elements
:= Nb_Elements
+ 1;
1557 Append_List
(Gen_Assign
(Add
(Nb_Elements
, To
=> Aggr_L
), Expr
),
1562 -- STEP 2 (b): Generate final loop if an others choice is present
1563 -- Here Nb_Elements gives the offset of the last positional element.
1565 if Present
(Component_Associations
(N
)) then
1566 Assoc
:= Last
(Component_Associations
(N
));
1568 -- Ada 2005 (AI-287)
1570 if Box_Present
(Assoc
) then
1571 Append_List
(Gen_While
(Add
(Nb_Elements
, To
=> Aggr_L
),
1576 Expr
:= Expression
(Assoc
);
1578 Append_List
(Gen_While
(Add
(Nb_Elements
, To
=> Aggr_L
),
1587 end Build_Array_Aggr_Code
;
1589 ----------------------------
1590 -- Build_Record_Aggr_Code --
1591 ----------------------------
1593 function Build_Record_Aggr_Code
1597 Flist
: Node_Id
:= Empty
;
1598 Obj
: Entity_Id
:= Empty
;
1599 Is_Limited_Ancestor_Expansion
: Boolean := False) return List_Id
1601 Loc
: constant Source_Ptr
:= Sloc
(N
);
1602 L
: constant List_Id
:= New_List
;
1603 N_Typ
: constant Entity_Id
:= Etype
(N
);
1609 Comp_Type
: Entity_Id
;
1610 Selector
: Entity_Id
;
1611 Comp_Expr
: Node_Id
;
1614 Internal_Final_List
: Node_Id
;
1616 -- If this is an internal aggregate, the External_Final_List is an
1617 -- expression for the controller record of the enclosing type.
1618 -- If the current aggregate has several controlled components, this
1619 -- expression will appear in several calls to attach to the finali-
1620 -- zation list, and it must not be shared.
1622 External_Final_List
: Node_Id
;
1623 Ancestor_Is_Expression
: Boolean := False;
1624 Ancestor_Is_Subtype_Mark
: Boolean := False;
1626 Init_Typ
: Entity_Id
:= Empty
;
1628 Ctrl_Stuff_Done
: Boolean := False;
1630 function Ancestor_Discriminant_Value
(Disc
: Entity_Id
) return Node_Id
;
1631 -- Returns the value that the given discriminant of an ancestor
1632 -- type should receive (in the absence of a conflict with the
1633 -- value provided by an ancestor part of an extension aggregate).
1635 procedure Check_Ancestor_Discriminants
(Anc_Typ
: Entity_Id
);
1636 -- Check that each of the discriminant values defined by the
1637 -- ancestor part of an extension aggregate match the corresponding
1638 -- values provided by either an association of the aggregate or
1639 -- by the constraint imposed by a parent type (RM95-4.3.2(8)).
1641 function Compatible_Int_Bounds
1642 (Agg_Bounds
: Node_Id
;
1643 Typ_Bounds
: Node_Id
) return Boolean;
1644 -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is
1645 -- assumed that both bounds are integer ranges.
1647 procedure Gen_Ctrl_Actions_For_Aggr
;
1648 -- Deal with the various controlled type data structure
1651 function Get_Constraint_Association
(T
: Entity_Id
) return Node_Id
;
1652 -- Returns the first discriminant association in the constraint
1653 -- associated with T, if any, otherwise returns Empty.
1655 function Init_Controller
1660 Init_Pr
: Boolean) return List_Id
;
1661 -- returns the list of statements necessary to initialize the internal
1662 -- controller of the (possible) ancestor typ into target and attach
1663 -- it to finalization list F. Init_Pr conditions the call to the
1664 -- init proc since it may already be done due to ancestor initialization
1666 function Is_Int_Range_Bounds
(Bounds
: Node_Id
) return Boolean;
1667 -- Check whether Bounds is a range node and its lower and higher bounds
1668 -- are integers literals.
1670 ---------------------------------
1671 -- Ancestor_Discriminant_Value --
1672 ---------------------------------
1674 function Ancestor_Discriminant_Value
(Disc
: Entity_Id
) return Node_Id
is
1676 Assoc_Elmt
: Elmt_Id
;
1677 Aggr_Comp
: Entity_Id
;
1678 Corresp_Disc
: Entity_Id
;
1679 Current_Typ
: Entity_Id
:= Base_Type
(Typ
);
1680 Parent_Typ
: Entity_Id
;
1681 Parent_Disc
: Entity_Id
;
1682 Save_Assoc
: Node_Id
:= Empty
;
1685 -- First check any discriminant associations to see if
1686 -- any of them provide a value for the discriminant.
1688 if Present
(Discriminant_Specifications
(Parent
(Current_Typ
))) then
1689 Assoc
:= First
(Component_Associations
(N
));
1690 while Present
(Assoc
) loop
1691 Aggr_Comp
:= Entity
(First
(Choices
(Assoc
)));
1693 if Ekind
(Aggr_Comp
) = E_Discriminant
then
1694 Save_Assoc
:= Expression
(Assoc
);
1696 Corresp_Disc
:= Corresponding_Discriminant
(Aggr_Comp
);
1697 while Present
(Corresp_Disc
) loop
1698 -- If found a corresponding discriminant then return
1699 -- the value given in the aggregate. (Note: this is
1700 -- not correct in the presence of side effects. ???)
1702 if Disc
= Corresp_Disc
then
1703 return Duplicate_Subexpr
(Expression
(Assoc
));
1707 Corresponding_Discriminant
(Corresp_Disc
);
1715 -- No match found in aggregate, so chain up parent types to find
1716 -- a constraint that defines the value of the discriminant.
1718 Parent_Typ
:= Etype
(Current_Typ
);
1719 while Current_Typ
/= Parent_Typ
loop
1720 if Has_Discriminants
(Parent_Typ
) then
1721 Parent_Disc
:= First_Discriminant
(Parent_Typ
);
1723 -- We either get the association from the subtype indication
1724 -- of the type definition itself, or from the discriminant
1725 -- constraint associated with the type entity (which is
1726 -- preferable, but it's not always present ???)
1728 if Is_Empty_Elmt_List
(
1729 Discriminant_Constraint
(Current_Typ
))
1731 Assoc
:= Get_Constraint_Association
(Current_Typ
);
1732 Assoc_Elmt
:= No_Elmt
;
1735 First_Elmt
(Discriminant_Constraint
(Current_Typ
));
1736 Assoc
:= Node
(Assoc_Elmt
);
1739 -- Traverse the discriminants of the parent type looking
1740 -- for one that corresponds.
1742 while Present
(Parent_Disc
) and then Present
(Assoc
) loop
1743 Corresp_Disc
:= Parent_Disc
;
1744 while Present
(Corresp_Disc
)
1745 and then Disc
/= Corresp_Disc
1748 Corresponding_Discriminant
(Corresp_Disc
);
1751 if Disc
= Corresp_Disc
then
1752 if Nkind
(Assoc
) = N_Discriminant_Association
then
1753 Assoc
:= Expression
(Assoc
);
1756 -- If the located association directly denotes
1757 -- a discriminant, then use the value of a saved
1758 -- association of the aggregate. This is a kludge
1759 -- to handle certain cases involving multiple
1760 -- discriminants mapped to a single discriminant
1761 -- of a descendant. It's not clear how to locate the
1762 -- appropriate discriminant value for such cases. ???
1764 if Is_Entity_Name
(Assoc
)
1765 and then Ekind
(Entity
(Assoc
)) = E_Discriminant
1767 Assoc
:= Save_Assoc
;
1770 return Duplicate_Subexpr
(Assoc
);
1773 Next_Discriminant
(Parent_Disc
);
1775 if No
(Assoc_Elmt
) then
1778 Next_Elmt
(Assoc_Elmt
);
1779 if Present
(Assoc_Elmt
) then
1780 Assoc
:= Node
(Assoc_Elmt
);
1788 Current_Typ
:= Parent_Typ
;
1789 Parent_Typ
:= Etype
(Current_Typ
);
1792 -- In some cases there's no ancestor value to locate (such as
1793 -- when an ancestor part given by an expression defines the
1794 -- discriminant value).
1797 end Ancestor_Discriminant_Value
;
1799 ----------------------------------
1800 -- Check_Ancestor_Discriminants --
1801 ----------------------------------
1803 procedure Check_Ancestor_Discriminants
(Anc_Typ
: Entity_Id
) is
1804 Discr
: Entity_Id
:= First_Discriminant
(Base_Type
(Anc_Typ
));
1805 Disc_Value
: Node_Id
;
1809 while Present
(Discr
) loop
1810 Disc_Value
:= Ancestor_Discriminant_Value
(Discr
);
1812 if Present
(Disc_Value
) then
1813 Cond
:= Make_Op_Ne
(Loc
,
1815 Make_Selected_Component
(Loc
,
1816 Prefix
=> New_Copy_Tree
(Target
),
1817 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)),
1818 Right_Opnd
=> Disc_Value
);
1821 Make_Raise_Constraint_Error
(Loc
,
1823 Reason
=> CE_Discriminant_Check_Failed
));
1826 Next_Discriminant
(Discr
);
1828 end Check_Ancestor_Discriminants
;
1830 ---------------------------
1831 -- Compatible_Int_Bounds --
1832 ---------------------------
1834 function Compatible_Int_Bounds
1835 (Agg_Bounds
: Node_Id
;
1836 Typ_Bounds
: Node_Id
) return Boolean
1838 Agg_Lo
: constant Uint
:= Intval
(Low_Bound
(Agg_Bounds
));
1839 Agg_Hi
: constant Uint
:= Intval
(High_Bound
(Agg_Bounds
));
1840 Typ_Lo
: constant Uint
:= Intval
(Low_Bound
(Typ_Bounds
));
1841 Typ_Hi
: constant Uint
:= Intval
(High_Bound
(Typ_Bounds
));
1843 return Typ_Lo
<= Agg_Lo
and then Agg_Hi
<= Typ_Hi
;
1844 end Compatible_Int_Bounds
;
1846 --------------------------------
1847 -- Get_Constraint_Association --
1848 --------------------------------
1850 function Get_Constraint_Association
(T
: Entity_Id
) return Node_Id
is
1851 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(T
));
1852 Indic
: constant Node_Id
:= Subtype_Indication
(Typ_Def
);
1855 -- ??? Also need to cover case of a type mark denoting a subtype
1858 if Nkind
(Indic
) = N_Subtype_Indication
1859 and then Present
(Constraint
(Indic
))
1861 return First
(Constraints
(Constraint
(Indic
)));
1865 end Get_Constraint_Association
;
1867 ---------------------
1868 -- Init_controller --
1869 ---------------------
1871 function Init_Controller
1876 Init_Pr
: Boolean) return List_Id
1878 L
: constant List_Id
:= New_List
;
1884 -- init-proc (target._controller);
1885 -- initialize (target._controller);
1886 -- Attach_to_Final_List (target._controller, F);
1889 Make_Selected_Component
(Loc
,
1890 Prefix
=> Convert_To
(Typ
, New_Copy_Tree
(Target
)),
1891 Selector_Name
=> Make_Identifier
(Loc
, Name_uController
));
1892 Set_Assignment_OK
(Ref
);
1894 -- Ada 2005 (AI-287): Give support to default initialization of
1895 -- limited types and components.
1897 if (Nkind
(Target
) = N_Identifier
1898 and then Present
(Etype
(Target
))
1899 and then Is_Limited_Type
(Etype
(Target
)))
1901 (Nkind
(Target
) = N_Selected_Component
1902 and then Present
(Etype
(Selector_Name
(Target
)))
1903 and then Is_Limited_Type
(Etype
(Selector_Name
(Target
))))
1905 (Nkind
(Target
) = N_Unchecked_Type_Conversion
1906 and then Present
(Etype
(Target
))
1907 and then Is_Limited_Type
(Etype
(Target
)))
1909 (Nkind
(Target
) = N_Unchecked_Expression
1910 and then Nkind
(Expression
(Target
)) = N_Indexed_Component
1911 and then Present
(Etype
(Prefix
(Expression
(Target
))))
1912 and then Is_Limited_Type
(Etype
(Prefix
(Expression
(Target
)))))
1914 RC
:= RE_Limited_Record_Controller
;
1916 RC
:= RE_Record_Controller
;
1921 Build_Initialization_Call
(Loc
,
1924 In_Init_Proc
=> Within_Init_Proc
));
1928 Make_Procedure_Call_Statement
(Loc
,
1931 Find_Prim_Op
(RTE
(RC
), Name_Initialize
), Loc
),
1932 Parameter_Associations
=>
1933 New_List
(New_Copy_Tree
(Ref
))));
1937 Obj_Ref
=> New_Copy_Tree
(Ref
),
1939 With_Attach
=> Attach
));
1942 end Init_Controller
;
1944 -------------------------
1945 -- Is_Int_Range_Bounds --
1946 -------------------------
1948 function Is_Int_Range_Bounds
(Bounds
: Node_Id
) return Boolean is
1950 return Nkind
(Bounds
) = N_Range
1951 and then Nkind
(Low_Bound
(Bounds
)) = N_Integer_Literal
1952 and then Nkind
(High_Bound
(Bounds
)) = N_Integer_Literal
;
1953 end Is_Int_Range_Bounds
;
1955 -------------------------------
1956 -- Gen_Ctrl_Actions_For_Aggr --
1957 -------------------------------
1959 procedure Gen_Ctrl_Actions_For_Aggr
is
1962 and then Finalize_Storage_Only
(Typ
)
1963 and then (Is_Library_Level_Entity
(Obj
)
1964 or else Entity
(Constant_Value
(RTE
(RE_Garbage_Collected
))) =
1967 Attach
:= Make_Integer_Literal
(Loc
, 0);
1969 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
1970 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
1972 Attach
:= Make_Integer_Literal
(Loc
, 2);
1975 Attach
:= Make_Integer_Literal
(Loc
, 1);
1978 -- Determine the external finalization list. It is either the
1979 -- finalization list of the outer-scope or the one coming from
1980 -- an outer aggregate. When the target is not a temporary, the
1981 -- proper scope is the scope of the target rather than the
1982 -- potentially transient current scope.
1984 if Controlled_Type
(Typ
) then
1985 if Present
(Flist
) then
1986 External_Final_List
:= New_Copy_Tree
(Flist
);
1988 elsif Is_Entity_Name
(Target
)
1989 and then Present
(Scope
(Entity
(Target
)))
1992 := Find_Final_List
(Scope
(Entity
(Target
)));
1995 External_Final_List
:= Find_Final_List
(Current_Scope
);
1999 External_Final_List
:= Empty
;
2002 -- Initialize and attach the outer object in the is_controlled case
2004 if Is_Controlled
(Typ
) then
2005 if Ancestor_Is_Subtype_Mark
then
2006 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2007 Set_Assignment_OK
(Ref
);
2009 Make_Procedure_Call_Statement
(Loc
,
2012 (Find_Prim_Op
(Init_Typ
, Name_Initialize
), Loc
),
2013 Parameter_Associations
=> New_List
(New_Copy_Tree
(Ref
))));
2016 if not Has_Controlled_Component
(Typ
) then
2017 Ref
:= New_Copy_Tree
(Target
);
2018 Set_Assignment_OK
(Ref
);
2022 Flist_Ref
=> New_Copy_Tree
(External_Final_List
),
2023 With_Attach
=> Attach
));
2027 -- In the Has_Controlled component case, all the intermediate
2028 -- controllers must be initialized
2030 if Has_Controlled_Component
(Typ
)
2031 and not Is_Limited_Ancestor_Expansion
2034 Inner_Typ
: Entity_Id
;
2035 Outer_Typ
: Entity_Id
;
2040 Outer_Typ
:= Base_Type
(Typ
);
2042 -- Find outer type with a controller
2044 while Outer_Typ
/= Init_Typ
2045 and then not Has_New_Controlled_Component
(Outer_Typ
)
2047 Outer_Typ
:= Etype
(Outer_Typ
);
2050 -- Attach it to the outer record controller to the
2051 -- external final list
2053 if Outer_Typ
= Init_Typ
then
2058 F
=> External_Final_List
,
2063 Inner_Typ
:= Init_Typ
;
2070 F
=> External_Final_List
,
2074 Inner_Typ
:= Etype
(Outer_Typ
);
2076 not Is_Tagged_Type
(Typ
) or else Inner_Typ
= Outer_Typ
;
2079 -- The outer object has to be attached as well
2081 if Is_Controlled
(Typ
) then
2082 Ref
:= New_Copy_Tree
(Target
);
2083 Set_Assignment_OK
(Ref
);
2087 Flist_Ref
=> New_Copy_Tree
(External_Final_List
),
2088 With_Attach
=> New_Copy_Tree
(Attach
)));
2091 -- Initialize the internal controllers for tagged types with
2092 -- more than one controller.
2094 while not At_Root
and then Inner_Typ
/= Init_Typ
loop
2095 if Has_New_Controlled_Component
(Inner_Typ
) then
2097 Make_Selected_Component
(Loc
,
2099 Convert_To
(Outer_Typ
, New_Copy_Tree
(Target
)),
2101 Make_Identifier
(Loc
, Name_uController
));
2103 Make_Selected_Component
(Loc
,
2105 Selector_Name
=> Make_Identifier
(Loc
, Name_F
));
2112 Attach
=> Make_Integer_Literal
(Loc
, 1),
2114 Outer_Typ
:= Inner_Typ
;
2119 At_Root
:= Inner_Typ
= Etype
(Inner_Typ
);
2120 Inner_Typ
:= Etype
(Inner_Typ
);
2123 -- If not done yet attach the controller of the ancestor part
2125 if Outer_Typ
/= Init_Typ
2126 and then Inner_Typ
= Init_Typ
2127 and then Has_Controlled_Component
(Init_Typ
)
2130 Make_Selected_Component
(Loc
,
2131 Prefix
=> Convert_To
(Outer_Typ
, New_Copy_Tree
(Target
)),
2133 Make_Identifier
(Loc
, Name_uController
));
2135 Make_Selected_Component
(Loc
,
2137 Selector_Name
=> Make_Identifier
(Loc
, Name_F
));
2139 Attach
:= Make_Integer_Literal
(Loc
, 1);
2146 Init_Pr
=> Ancestor_Is_Expression
));
2150 end Gen_Ctrl_Actions_For_Aggr
;
2152 -- Start of processing for Build_Record_Aggr_Code
2155 -- Deal with the ancestor part of extension aggregates
2156 -- or with the discriminants of the root type
2158 if Nkind
(N
) = N_Extension_Aggregate
then
2160 A
: constant Node_Id
:= Ancestor_Part
(N
);
2164 -- If the ancestor part is a subtype mark "T", we generate
2166 -- init-proc (T(tmp)); if T is constrained and
2167 -- init-proc (S(tmp)); where S applies an appropriate
2168 -- constraint if T is unconstrained
2170 if Is_Entity_Name
(A
) and then Is_Type
(Entity
(A
)) then
2171 Ancestor_Is_Subtype_Mark
:= True;
2173 if Is_Constrained
(Entity
(A
)) then
2174 Init_Typ
:= Entity
(A
);
2176 -- For an ancestor part given by an unconstrained type
2177 -- mark, create a subtype constrained by appropriate
2178 -- corresponding discriminant values coming from either
2179 -- associations of the aggregate or a constraint on
2180 -- a parent type. The subtype will be used to generate
2181 -- the correct default value for the ancestor part.
2183 elsif Has_Discriminants
(Entity
(A
)) then
2185 Anc_Typ
: constant Entity_Id
:= Entity
(A
);
2186 Anc_Constr
: constant List_Id
:= New_List
;
2187 Discrim
: Entity_Id
;
2188 Disc_Value
: Node_Id
;
2189 New_Indic
: Node_Id
;
2190 Subt_Decl
: Node_Id
;
2193 Discrim
:= First_Discriminant
(Anc_Typ
);
2194 while Present
(Discrim
) loop
2195 Disc_Value
:= Ancestor_Discriminant_Value
(Discrim
);
2196 Append_To
(Anc_Constr
, Disc_Value
);
2197 Next_Discriminant
(Discrim
);
2201 Make_Subtype_Indication
(Loc
,
2202 Subtype_Mark
=> New_Occurrence_Of
(Anc_Typ
, Loc
),
2204 Make_Index_Or_Discriminant_Constraint
(Loc
,
2205 Constraints
=> Anc_Constr
));
2207 Init_Typ
:= Create_Itype
(Ekind
(Anc_Typ
), N
);
2210 Make_Subtype_Declaration
(Loc
,
2211 Defining_Identifier
=> Init_Typ
,
2212 Subtype_Indication
=> New_Indic
);
2214 -- Itypes must be analyzed with checks off
2215 -- Declaration must have a parent for proper
2216 -- handling of subsidiary actions.
2218 Set_Parent
(Subt_Decl
, N
);
2219 Analyze
(Subt_Decl
, Suppress
=> All_Checks
);
2223 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2224 Set_Assignment_OK
(Ref
);
2226 if Has_Default_Init_Comps
(N
)
2227 or else Has_Task
(Base_Type
(Init_Typ
))
2230 Build_Initialization_Call
(Loc
,
2233 In_Init_Proc
=> Within_Init_Proc
,
2234 With_Default_Init
=> True));
2237 Build_Initialization_Call
(Loc
,
2240 In_Init_Proc
=> Within_Init_Proc
));
2243 if Is_Constrained
(Entity
(A
))
2244 and then Has_Discriminants
(Entity
(A
))
2246 Check_Ancestor_Discriminants
(Entity
(A
));
2249 -- Ada 2005 (AI-287): If the ancestor part is an aggregate of
2250 -- limited type, a recursive call expands the ancestor. Note that
2251 -- in the limited case, the ancestor part must be either a
2252 -- function call (possibly qualified) or aggregate (definitely
2255 elsif Is_Limited_Type
(Etype
(A
))
2256 and then Nkind
(Unqualify
(A
)) /= N_Function_Call
-- aggregate?
2258 Ancestor_Is_Expression
:= True;
2261 Build_Record_Aggr_Code
(
2263 Typ
=> Etype
(Unqualify
(A
)),
2267 Is_Limited_Ancestor_Expansion
=> True));
2269 -- If the ancestor part is an expression "E", we generate
2271 -- In Ada 2005, this includes the case of a (possibly qualified)
2272 -- limited function call. The assignment will turn into a
2273 -- build-in-place function call (see
2274 -- Make_Build_In_Place_Call_In_Assignment).
2277 Ancestor_Is_Expression
:= True;
2278 Init_Typ
:= Etype
(A
);
2280 -- If the ancestor part is an aggregate, force its full
2281 -- expansion, which was delayed.
2283 if Nkind
(Unqualify
(A
)) = N_Aggregate
2284 or else Nkind
(Unqualify
(A
)) = N_Extension_Aggregate
2286 Set_Analyzed
(A
, False);
2287 Set_Analyzed
(Expression
(A
), False);
2290 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2291 Set_Assignment_OK
(Ref
);
2293 -- Make the assignment without usual controlled actions since
2294 -- we only want the post adjust but not the pre finalize here
2295 -- Add manual adjust when necessary
2297 Assign
:= New_List
(
2298 Make_OK_Assignment_Statement
(Loc
,
2301 Self_Ref
=> Has_Self_Reference
(N
)));
2302 Set_No_Ctrl_Actions
(First
(Assign
));
2304 -- Assign the tag now to make sure that the dispatching call in
2305 -- the subsequent deep_adjust works properly (unless Java_VM,
2306 -- where tags are implicit).
2310 Make_OK_Assignment_Statement
(Loc
,
2312 Make_Selected_Component
(Loc
,
2313 Prefix
=> New_Copy_Tree
(Target
),
2316 (First_Tag_Component
(Base_Type
(Typ
)), Loc
)),
2319 Unchecked_Convert_To
(RTE
(RE_Tag
),
2322 (Access_Disp_Table
(Base_Type
(Typ
)))),
2325 Set_Assignment_OK
(Name
(Instr
));
2326 Append_To
(Assign
, Instr
);
2329 -- Call Adjust manually
2331 if Controlled_Type
(Etype
(A
)) then
2332 Append_List_To
(Assign
,
2334 Ref
=> New_Copy_Tree
(Ref
),
2336 Flist_Ref
=> New_Reference_To
(
2337 RTE
(RE_Global_Final_List
), Loc
),
2338 With_Attach
=> Make_Integer_Literal
(Loc
, 0)));
2342 Make_Unsuppress_Block
(Loc
, Name_Discriminant_Check
, Assign
));
2344 if Has_Discriminants
(Init_Typ
) then
2345 Check_Ancestor_Discriminants
(Init_Typ
);
2350 -- Normal case (not an extension aggregate)
2353 -- Generate the discriminant expressions, component by component.
2354 -- If the base type is an unchecked union, the discriminants are
2355 -- unknown to the back-end and absent from a value of the type, so
2356 -- assignments for them are not emitted.
2358 if Has_Discriminants
(Typ
)
2359 and then not Is_Unchecked_Union
(Base_Type
(Typ
))
2361 -- If the type is derived, and constrains discriminants of the
2362 -- parent type, these discriminants are not components of the
2363 -- aggregate, and must be initialized explicitly. They are not
2364 -- visible components of the object, but can become visible with
2365 -- a view conversion to the ancestor.
2369 Parent_Type
: Entity_Id
;
2371 Discr_Val
: Elmt_Id
;
2374 Btype
:= Base_Type
(Typ
);
2376 while Is_Derived_Type
(Btype
)
2377 and then Present
(Stored_Constraint
(Btype
))
2379 Parent_Type
:= Etype
(Btype
);
2381 Disc
:= First_Discriminant
(Parent_Type
);
2383 First_Elmt
(Stored_Constraint
(Base_Type
(Typ
)));
2384 while Present
(Discr_Val
) loop
2386 -- Only those discriminants of the parent that are not
2387 -- renamed by discriminants of the derived type need to
2388 -- be added explicitly.
2390 if not Is_Entity_Name
(Node
(Discr_Val
))
2392 Ekind
(Entity
(Node
(Discr_Val
))) /= E_Discriminant
2395 Make_Selected_Component
(Loc
,
2396 Prefix
=> New_Copy_Tree
(Target
),
2397 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
2400 Make_OK_Assignment_Statement
(Loc
,
2402 Expression
=> New_Copy_Tree
(Node
(Discr_Val
)));
2404 Set_No_Ctrl_Actions
(Instr
);
2405 Append_To
(L
, Instr
);
2408 Next_Discriminant
(Disc
);
2409 Next_Elmt
(Discr_Val
);
2412 Btype
:= Base_Type
(Parent_Type
);
2416 -- Generate discriminant init values for the visible discriminants
2419 Discriminant
: Entity_Id
;
2420 Discriminant_Value
: Node_Id
;
2423 Discriminant
:= First_Stored_Discriminant
(Typ
);
2425 while Present
(Discriminant
) loop
2428 Make_Selected_Component
(Loc
,
2429 Prefix
=> New_Copy_Tree
(Target
),
2430 Selector_Name
=> New_Occurrence_Of
(Discriminant
, Loc
));
2432 Discriminant_Value
:=
2433 Get_Discriminant_Value
(
2436 Discriminant_Constraint
(N_Typ
));
2439 Make_OK_Assignment_Statement
(Loc
,
2441 Expression
=> New_Copy_Tree
(Discriminant_Value
));
2443 Set_No_Ctrl_Actions
(Instr
);
2444 Append_To
(L
, Instr
);
2446 Next_Stored_Discriminant
(Discriminant
);
2452 -- Generate the assignments, component by component
2454 -- tmp.comp1 := Expr1_From_Aggr;
2455 -- tmp.comp2 := Expr2_From_Aggr;
2458 Comp
:= First
(Component_Associations
(N
));
2459 while Present
(Comp
) loop
2460 Selector
:= Entity
(First
(Choices
(Comp
)));
2462 -- Ada 2005 (AI-287): For each default-initialized component genarate
2463 -- a call to the corresponding IP subprogram if available.
2465 if Box_Present
(Comp
)
2466 and then Has_Non_Null_Base_Init_Proc
(Etype
(Selector
))
2468 -- Ada 2005 (AI-287): If the component type has tasks then
2469 -- generate the activation chain and master entities (except
2470 -- in case of an allocator because in that case these entities
2471 -- are generated by Build_Task_Allocate_Block_With_Init_Stmts).
2474 Ctype
: constant Entity_Id
:= Etype
(Selector
);
2475 Inside_Allocator
: Boolean := False;
2476 P
: Node_Id
:= Parent
(N
);
2479 if Is_Task_Type
(Ctype
) or else Has_Task
(Ctype
) then
2480 while Present
(P
) loop
2481 if Nkind
(P
) = N_Allocator
then
2482 Inside_Allocator
:= True;
2489 if not Inside_Init_Proc
and not Inside_Allocator
then
2490 Build_Activation_Chain_Entity
(N
);
2496 Build_Initialization_Call
(Loc
,
2497 Id_Ref
=> Make_Selected_Component
(Loc
,
2498 Prefix
=> New_Copy_Tree
(Target
),
2499 Selector_Name
=> New_Occurrence_Of
(Selector
,
2501 Typ
=> Etype
(Selector
),
2502 With_Default_Init
=> True));
2507 -- Prepare for component assignment
2509 if Ekind
(Selector
) /= E_Discriminant
2510 or else Nkind
(N
) = N_Extension_Aggregate
2513 -- All the discriminants have now been assigned
2514 -- This is now a good moment to initialize and attach all the
2515 -- controllers. Their position may depend on the discriminants.
2517 if Ekind
(Selector
) /= E_Discriminant
2518 and then not Ctrl_Stuff_Done
2520 Gen_Ctrl_Actions_For_Aggr
;
2521 Ctrl_Stuff_Done
:= True;
2524 Comp_Type
:= Etype
(Selector
);
2526 Make_Selected_Component
(Loc
,
2527 Prefix
=> New_Copy_Tree
(Target
),
2528 Selector_Name
=> New_Occurrence_Of
(Selector
, Loc
));
2530 if Nkind
(Expression
(Comp
)) = N_Qualified_Expression
then
2531 Expr_Q
:= Expression
(Expression
(Comp
));
2533 Expr_Q
:= Expression
(Comp
);
2536 -- The controller is the one of the parent type defining
2537 -- the component (in case of inherited components).
2539 if Controlled_Type
(Comp_Type
) then
2540 Internal_Final_List
:=
2541 Make_Selected_Component
(Loc
,
2542 Prefix
=> Convert_To
(
2543 Scope
(Original_Record_Component
(Selector
)),
2544 New_Copy_Tree
(Target
)),
2546 Make_Identifier
(Loc
, Name_uController
));
2548 Internal_Final_List
:=
2549 Make_Selected_Component
(Loc
,
2550 Prefix
=> Internal_Final_List
,
2551 Selector_Name
=> Make_Identifier
(Loc
, Name_F
));
2553 -- The internal final list can be part of a constant object
2555 Set_Assignment_OK
(Internal_Final_List
);
2558 Internal_Final_List
:= Empty
;
2561 -- Now either create the assignment or generate the code for the
2562 -- inner aggregate top-down.
2564 if Is_Delayed_Aggregate
(Expr_Q
) then
2566 -- We have the following case of aggregate nesting inside
2567 -- an object declaration:
2569 -- type Arr_Typ is array (Integer range <>) of ...;
2571 -- type Rec_Typ (...) is record
2572 -- Obj_Arr_Typ : Arr_Typ (A .. B);
2575 -- Obj_Rec_Typ : Rec_Typ := (...,
2576 -- Obj_Arr_Typ => (X => (...), Y => (...)));
2578 -- The length of the ranges of the aggregate and Obj_Add_Typ
2579 -- are equal (B - A = Y - X), but they do not coincide (X /=
2580 -- A and B /= Y). This case requires array sliding which is
2581 -- performed in the following manner:
2583 -- subtype Arr_Sub is Arr_Typ (X .. Y);
2585 -- Temp (X) := (...);
2587 -- Temp (Y) := (...);
2588 -- Obj_Rec_Typ.Obj_Arr_Typ := Temp;
2591 and then Ekind
(Comp_Type
) = E_Array_Subtype
2592 and then Is_Int_Range_Bounds
(Aggregate_Bounds
(Expr_Q
))
2593 and then Is_Int_Range_Bounds
(First_Index
(Comp_Type
))
2595 Compatible_Int_Bounds
(
2596 Agg_Bounds
=> Aggregate_Bounds
(Expr_Q
),
2597 Typ_Bounds
=> First_Index
(Comp_Type
))
2600 -- Create the array subtype with bounds equal to those
2601 -- of the corresponding aggregate.
2603 SubE
: constant Entity_Id
:=
2604 Make_Defining_Identifier
(Loc
,
2605 New_Internal_Name
('T'));
2607 SubD
: constant Node_Id
:=
2608 Make_Subtype_Declaration
(Loc
,
2609 Defining_Identifier
=>
2611 Subtype_Indication
=>
2612 Make_Subtype_Indication
(Loc
,
2613 Subtype_Mark
=> New_Reference_To
(
2614 Etype
(Comp_Type
), Loc
),
2616 Make_Index_Or_Discriminant_Constraint
(
2617 Loc
, Constraints
=> New_List
(
2618 New_Copy_Tree
(Aggregate_Bounds
(
2621 -- Create a temporary array of the above subtype which
2622 -- will be used to capture the aggregate assignments.
2624 TmpE
: constant Entity_Id
:=
2625 Make_Defining_Identifier
(Loc
,
2626 New_Internal_Name
('A'));
2628 TmpD
: constant Node_Id
:=
2629 Make_Object_Declaration
(Loc
,
2630 Defining_Identifier
=>
2632 Object_Definition
=>
2633 New_Reference_To
(SubE
, Loc
));
2636 Set_No_Initialization
(TmpD
);
2637 Append_To
(L
, SubD
);
2638 Append_To
(L
, TmpD
);
2640 -- Expand the aggregate into assignments to the temporary
2644 Late_Expansion
(Expr_Q
, Comp_Type
,
2645 New_Reference_To
(TmpE
, Loc
), Internal_Final_List
));
2650 Make_Assignment_Statement
(Loc
,
2651 Name
=> New_Copy_Tree
(Comp_Expr
),
2652 Expression
=> New_Reference_To
(TmpE
, Loc
)));
2654 -- Do not pass the original aggregate to Gigi as is
2655 -- since it will potentially clobber the front or the
2656 -- end of the array. Setting the expression to empty
2657 -- is safe since all aggregates will be expanded into
2660 Set_Expression
(Parent
(Obj
), Empty
);
2663 -- Normal case (sliding not required)
2667 Late_Expansion
(Expr_Q
, Comp_Type
, Comp_Expr
,
2668 Internal_Final_List
));
2673 Make_OK_Assignment_Statement
(Loc
,
2675 Expression
=> Expression
(Comp
),
2676 Self_Ref
=> Has_Self_Reference
(N
));
2678 Set_No_Ctrl_Actions
(Instr
);
2679 Append_To
(L
, Instr
);
2681 -- Adjust the tag if tagged (because of possible view
2682 -- conversions), unless compiling for the Java VM
2683 -- where tags are implicit.
2685 -- tmp.comp._tag := comp_typ'tag;
2687 if Is_Tagged_Type
(Comp_Type
) and then not Java_VM
then
2689 Make_OK_Assignment_Statement
(Loc
,
2691 Make_Selected_Component
(Loc
,
2692 Prefix
=> New_Copy_Tree
(Comp_Expr
),
2695 (First_Tag_Component
(Comp_Type
), Loc
)),
2698 Unchecked_Convert_To
(RTE
(RE_Tag
),
2700 (Node
(First_Elmt
(Access_Disp_Table
(Comp_Type
))),
2703 Append_To
(L
, Instr
);
2706 -- Adjust and Attach the component to the proper controller
2707 -- Adjust (tmp.comp);
2708 -- Attach_To_Final_List (tmp.comp,
2709 -- comp_typ (tmp)._record_controller.f)
2711 if Controlled_Type
(Comp_Type
) then
2714 Ref
=> New_Copy_Tree
(Comp_Expr
),
2716 Flist_Ref
=> Internal_Final_List
,
2717 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
2723 elsif Ekind
(Selector
) = E_Discriminant
2724 and then Nkind
(N
) /= N_Extension_Aggregate
2725 and then Nkind
(Parent
(N
)) = N_Component_Association
2726 and then Is_Constrained
(Typ
)
2728 -- We must check that the discriminant value imposed by the
2729 -- context is the same as the value given in the subaggregate,
2730 -- because after the expansion into assignments there is no
2731 -- record on which to perform a regular discriminant check.
2738 D_Val
:= First_Elmt
(Discriminant_Constraint
(Typ
));
2739 Disc
:= First_Discriminant
(Typ
);
2741 while Chars
(Disc
) /= Chars
(Selector
) loop
2742 Next_Discriminant
(Disc
);
2746 pragma Assert
(Present
(D_Val
));
2749 Make_Raise_Constraint_Error
(Loc
,
2752 Left_Opnd
=> New_Copy_Tree
(Node
(D_Val
)),
2753 Right_Opnd
=> Expression
(Comp
)),
2754 Reason
=> CE_Discriminant_Check_Failed
));
2763 -- If the type is tagged, the tag needs to be initialized (unless
2764 -- compiling for the Java VM where tags are implicit). It is done
2765 -- late in the initialization process because in some cases, we call
2766 -- the init proc of an ancestor which will not leave out the right tag
2768 if Ancestor_Is_Expression
then
2771 elsif Is_Tagged_Type
(Typ
) and then not Java_VM
then
2773 Make_OK_Assignment_Statement
(Loc
,
2775 Make_Selected_Component
(Loc
,
2776 Prefix
=> New_Copy_Tree
(Target
),
2779 (First_Tag_Component
(Base_Type
(Typ
)), Loc
)),
2782 Unchecked_Convert_To
(RTE
(RE_Tag
),
2784 (Node
(First_Elmt
(Access_Disp_Table
(Base_Type
(Typ
)))),
2787 Append_To
(L
, Instr
);
2789 -- Ada 2005 (AI-251): If the tagged type has been derived from
2790 -- abstract interfaces we must also initialize the tags of the
2791 -- secondary dispatch tables.
2793 if Present
(Abstract_Interfaces
(Base_Type
(Typ
)))
2795 Is_Empty_Elmt_List
(Abstract_Interfaces
(Base_Type
(Typ
)))
2798 (Typ
=> Base_Type
(Typ
),
2804 -- If the controllers have not been initialized yet (by lack of non-
2805 -- discriminant components), let's do it now.
2807 if not Ctrl_Stuff_Done
then
2808 Gen_Ctrl_Actions_For_Aggr
;
2809 Ctrl_Stuff_Done
:= True;
2813 end Build_Record_Aggr_Code
;
2815 -------------------------------
2816 -- Convert_Aggr_In_Allocator --
2817 -------------------------------
2819 procedure Convert_Aggr_In_Allocator
(Decl
, Aggr
: Node_Id
) is
2820 Loc
: constant Source_Ptr
:= Sloc
(Aggr
);
2821 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2822 Temp
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2824 Occ
: constant Node_Id
:=
2825 Unchecked_Convert_To
(Typ
,
2826 Make_Explicit_Dereference
(Loc
,
2827 New_Reference_To
(Temp
, Loc
)));
2829 Access_Type
: constant Entity_Id
:= Etype
(Temp
);
2832 if Is_Array_Type
(Typ
) then
2833 Convert_Array_Aggr_In_Allocator
(Decl
, Aggr
, Occ
);
2835 elsif Has_Default_Init_Comps
(Aggr
) then
2837 L
: constant List_Id
:= New_List
;
2838 Init_Stmts
: List_Id
;
2841 Init_Stmts
:= Late_Expansion
(Aggr
, Typ
, Occ
,
2842 Find_Final_List
(Access_Type
),
2843 Associated_Final_Chain
(Base_Type
(Access_Type
)));
2845 Build_Task_Allocate_Block_With_Init_Stmts
(L
, Aggr
, Init_Stmts
);
2846 Insert_Actions_After
(Decl
, L
);
2850 Insert_Actions_After
(Decl
,
2851 Late_Expansion
(Aggr
, Typ
, Occ
,
2852 Find_Final_List
(Access_Type
),
2853 Associated_Final_Chain
(Base_Type
(Access_Type
))));
2855 end Convert_Aggr_In_Allocator
;
2857 --------------------------------
2858 -- Convert_Aggr_In_Assignment --
2859 --------------------------------
2861 procedure Convert_Aggr_In_Assignment
(N
: Node_Id
) is
2862 Aggr
: Node_Id
:= Expression
(N
);
2863 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2864 Occ
: constant Node_Id
:= New_Copy_Tree
(Name
(N
));
2867 if Nkind
(Aggr
) = N_Qualified_Expression
then
2868 Aggr
:= Expression
(Aggr
);
2871 Insert_Actions_After
(N
,
2872 Late_Expansion
(Aggr
, Typ
, Occ
,
2873 Find_Final_List
(Typ
, New_Copy_Tree
(Occ
))));
2874 end Convert_Aggr_In_Assignment
;
2876 ---------------------------------
2877 -- Convert_Aggr_In_Object_Decl --
2878 ---------------------------------
2880 procedure Convert_Aggr_In_Object_Decl
(N
: Node_Id
) is
2881 Obj
: constant Entity_Id
:= Defining_Identifier
(N
);
2882 Aggr
: Node_Id
:= Expression
(N
);
2883 Loc
: constant Source_Ptr
:= Sloc
(Aggr
);
2884 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2885 Occ
: constant Node_Id
:= New_Occurrence_Of
(Obj
, Loc
);
2887 function Discriminants_Ok
return Boolean;
2888 -- If the object type is constrained, the discriminants in the
2889 -- aggregate must be checked against the discriminants of the subtype.
2890 -- This cannot be done using Apply_Discriminant_Checks because after
2891 -- expansion there is no aggregate left to check.
2893 ----------------------
2894 -- Discriminants_Ok --
2895 ----------------------
2897 function Discriminants_Ok
return Boolean is
2898 Cond
: Node_Id
:= Empty
;
2907 D
:= First_Discriminant
(Typ
);
2908 Disc1
:= First_Elmt
(Discriminant_Constraint
(Typ
));
2909 Disc2
:= First_Elmt
(Discriminant_Constraint
(Etype
(Obj
)));
2911 while Present
(Disc1
) and then Present
(Disc2
) loop
2912 Val1
:= Node
(Disc1
);
2913 Val2
:= Node
(Disc2
);
2915 if not Is_OK_Static_Expression
(Val1
)
2916 or else not Is_OK_Static_Expression
(Val2
)
2918 Check
:= Make_Op_Ne
(Loc
,
2919 Left_Opnd
=> Duplicate_Subexpr
(Val1
),
2920 Right_Opnd
=> Duplicate_Subexpr
(Val2
));
2926 Cond
:= Make_Or_Else
(Loc
,
2928 Right_Opnd
=> Check
);
2931 elsif Expr_Value
(Val1
) /= Expr_Value
(Val2
) then
2932 Apply_Compile_Time_Constraint_Error
(Aggr
,
2933 Msg
=> "incorrect value for discriminant&?",
2934 Reason
=> CE_Discriminant_Check_Failed
,
2939 Next_Discriminant
(D
);
2944 -- If any discriminant constraint is non-static, emit a check
2946 if Present
(Cond
) then
2948 Make_Raise_Constraint_Error
(Loc
,
2950 Reason
=> CE_Discriminant_Check_Failed
));
2954 end Discriminants_Ok
;
2956 -- Start of processing for Convert_Aggr_In_Object_Decl
2959 Set_Assignment_OK
(Occ
);
2961 if Nkind
(Aggr
) = N_Qualified_Expression
then
2962 Aggr
:= Expression
(Aggr
);
2965 if Has_Discriminants
(Typ
)
2966 and then Typ
/= Etype
(Obj
)
2967 and then Is_Constrained
(Etype
(Obj
))
2968 and then not Discriminants_Ok
2973 if Requires_Transient_Scope
(Typ
) then
2974 Establish_Transient_Scope
(Aggr
, Sec_Stack
=>
2975 Is_Controlled
(Typ
) or else Has_Controlled_Component
(Typ
));
2978 Insert_Actions_After
(N
, Late_Expansion
(Aggr
, Typ
, Occ
, Obj
=> Obj
));
2979 Set_No_Initialization
(N
);
2980 Initialize_Discriminants
(N
, Typ
);
2981 end Convert_Aggr_In_Object_Decl
;
2983 -------------------------------------
2984 -- Convert_array_Aggr_In_Allocator --
2985 -------------------------------------
2987 procedure Convert_Array_Aggr_In_Allocator
2992 Aggr_Code
: List_Id
;
2993 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2994 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
2997 -- The target is an explicit dereference of the allocated object.
2998 -- Generate component assignments to it, as for an aggregate that
2999 -- appears on the right-hand side of an assignment statement.
3002 Build_Array_Aggr_Code
(Aggr
,
3004 Index
=> First_Index
(Typ
),
3006 Scalar_Comp
=> Is_Scalar_Type
(Ctyp
));
3008 Insert_Actions_After
(Decl
, Aggr_Code
);
3009 end Convert_Array_Aggr_In_Allocator
;
3011 ----------------------------
3012 -- Convert_To_Assignments --
3013 ----------------------------
3015 procedure Convert_To_Assignments
(N
: Node_Id
; Typ
: Entity_Id
) is
3016 Loc
: constant Source_Ptr
:= Sloc
(N
);
3020 Target_Expr
: Node_Id
;
3021 Parent_Kind
: Node_Kind
;
3022 Unc_Decl
: Boolean := False;
3023 Parent_Node
: Node_Id
;
3026 Parent_Node
:= Parent
(N
);
3027 Parent_Kind
:= Nkind
(Parent_Node
);
3029 if Parent_Kind
= N_Qualified_Expression
then
3031 -- Check if we are in a unconstrained declaration because in this
3032 -- case the current delayed expansion mechanism doesn't work when
3033 -- the declared object size depend on the initializing expr.
3036 Parent_Node
:= Parent
(Parent_Node
);
3037 Parent_Kind
:= Nkind
(Parent_Node
);
3039 if Parent_Kind
= N_Object_Declaration
then
3041 not Is_Entity_Name
(Object_Definition
(Parent_Node
))
3042 or else Has_Discriminants
3043 (Entity
(Object_Definition
(Parent_Node
)))
3044 or else Is_Class_Wide_Type
3045 (Entity
(Object_Definition
(Parent_Node
)));
3050 -- Just set the Delay flag in the following cases where the
3051 -- transformation will be done top down from above
3053 -- - internal aggregate (transformed when expanding the parent)
3054 -- - allocators (see Convert_Aggr_In_Allocator)
3055 -- - object decl (see Convert_Aggr_In_Object_Decl)
3056 -- - safe assignments (see Convert_Aggr_Assignments)
3057 -- so far only the assignments in the init procs are taken
3060 if Parent_Kind
= N_Aggregate
3061 or else Parent_Kind
= N_Extension_Aggregate
3062 or else Parent_Kind
= N_Component_Association
3063 or else Parent_Kind
= N_Allocator
3064 or else (Parent_Kind
= N_Object_Declaration
and then not Unc_Decl
)
3065 or else (Parent_Kind
= N_Assignment_Statement
3066 and then Inside_Init_Proc
)
3068 Set_Expansion_Delayed
(N
);
3072 if Requires_Transient_Scope
(Typ
) then
3073 Establish_Transient_Scope
(N
, Sec_Stack
=>
3074 Is_Controlled
(Typ
) or else Has_Controlled_Component
(Typ
));
3077 -- Create the temporary
3079 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
3082 Make_Object_Declaration
(Loc
,
3083 Defining_Identifier
=> Temp
,
3084 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
3086 Set_No_Initialization
(Instr
);
3087 Insert_Action
(N
, Instr
);
3088 Initialize_Discriminants
(Instr
, Typ
);
3089 Target_Expr
:= New_Occurrence_Of
(Temp
, Loc
);
3091 Insert_Actions
(N
, Build_Record_Aggr_Code
(N
, Typ
, Target_Expr
));
3092 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3093 Analyze_And_Resolve
(N
, Typ
);
3094 end Convert_To_Assignments
;
3096 ---------------------------
3097 -- Convert_To_Positional --
3098 ---------------------------
3100 procedure Convert_To_Positional
3102 Max_Others_Replicate
: Nat
:= 5;
3103 Handle_Bit_Packed
: Boolean := False)
3105 Typ
: constant Entity_Id
:= Etype
(N
);
3110 Ixb
: Node_Id
) return Boolean;
3111 -- Convert the aggregate into a purely positional form if possible.
3112 -- On entry the bounds of all dimensions are known to be static,
3113 -- and the total number of components is safe enough to expand.
3115 function Is_Flat
(N
: Node_Id
; Dims
: Int
) return Boolean;
3116 -- Return True iff the array N is flat (which is not rivial
3117 -- in the case of multidimensionsl aggregates).
3126 Ixb
: Node_Id
) return Boolean
3128 Loc
: constant Source_Ptr
:= Sloc
(N
);
3129 Blo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Ixb
));
3130 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Ix
));
3131 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Ix
));
3136 if Nkind
(Original_Node
(N
)) = N_String_Literal
then
3140 -- Only handle bounds starting at the base type low bound
3141 -- for now since the compiler isn't able to handle different low
3142 -- bounds yet. Case such as new String'(3..5 => ' ') will get
3143 -- the wrong bounds, though it seems that the aggregate should
3144 -- retain the bounds set on its Etype (see C64103E and CC1311B).
3146 Lov
:= Expr_Value
(Lo
);
3147 Hiv
:= Expr_Value
(Hi
);
3150 or else not Compile_Time_Known_Value
(Blo
)
3151 or else (Lov
/= Expr_Value
(Blo
))
3156 -- Determine if set of alternatives is suitable for conversion
3157 -- and build an array containing the values in sequence.
3160 Vals
: array (UI_To_Int
(Lov
) .. UI_To_Int
(Hiv
))
3161 of Node_Id
:= (others => Empty
);
3162 -- The values in the aggregate sorted appropriately
3165 -- Same data as Vals in list form
3168 -- Used to validate Max_Others_Replicate limit
3171 Num
: Int
:= UI_To_Int
(Lov
);
3176 if Present
(Expressions
(N
)) then
3177 Elmt
:= First
(Expressions
(N
));
3179 while Present
(Elmt
) loop
3180 if Nkind
(Elmt
) = N_Aggregate
3181 and then Present
(Next_Index
(Ix
))
3183 not Flatten
(Elmt
, Next_Index
(Ix
), Next_Index
(Ixb
))
3188 Vals
(Num
) := Relocate_Node
(Elmt
);
3195 if No
(Component_Associations
(N
)) then
3199 Elmt
:= First
(Component_Associations
(N
));
3201 if Nkind
(Expression
(Elmt
)) = N_Aggregate
then
3202 if Present
(Next_Index
(Ix
))
3205 (Expression
(Elmt
), Next_Index
(Ix
), Next_Index
(Ixb
))
3211 Component_Loop
: while Present
(Elmt
) loop
3212 Choice
:= First
(Choices
(Elmt
));
3213 Choice_Loop
: while Present
(Choice
) loop
3215 -- If we have an others choice, fill in the missing elements
3216 -- subject to the limit established by Max_Others_Replicate.
3218 if Nkind
(Choice
) = N_Others_Choice
then
3221 for J
in Vals
'Range loop
3222 if No
(Vals
(J
)) then
3223 Vals
(J
) := New_Copy_Tree
(Expression
(Elmt
));
3224 Rep_Count
:= Rep_Count
+ 1;
3226 -- Check for maximum others replication. Note that
3227 -- we skip this test if either of the restrictions
3228 -- No_Elaboration_Code or No_Implicit_Loops is
3229 -- active, or if this is a preelaborable unit.
3232 P
: constant Entity_Id
:=
3233 Cunit_Entity
(Current_Sem_Unit
);
3236 if Restriction_Active
(No_Elaboration_Code
)
3237 or else Restriction_Active
(No_Implicit_Loops
)
3238 or else Is_Preelaborated
(P
)
3239 or else (Ekind
(P
) = E_Package_Body
3241 Is_Preelaborated
(Spec_Entity
(P
)))
3245 elsif Rep_Count
> Max_Others_Replicate
then
3252 exit Component_Loop
;
3254 -- Case of a subtype mark
3256 elsif Nkind
(Choice
) = N_Identifier
3257 and then Is_Type
(Entity
(Choice
))
3259 Lo
:= Type_Low_Bound
(Etype
(Choice
));
3260 Hi
:= Type_High_Bound
(Etype
(Choice
));
3262 -- Case of subtype indication
3264 elsif Nkind
(Choice
) = N_Subtype_Indication
then
3265 Lo
:= Low_Bound
(Range_Expression
(Constraint
(Choice
)));
3266 Hi
:= High_Bound
(Range_Expression
(Constraint
(Choice
)));
3270 elsif Nkind
(Choice
) = N_Range
then
3271 Lo
:= Low_Bound
(Choice
);
3272 Hi
:= High_Bound
(Choice
);
3274 -- Normal subexpression case
3276 else pragma Assert
(Nkind
(Choice
) in N_Subexpr
);
3277 if not Compile_Time_Known_Value
(Choice
) then
3281 Vals
(UI_To_Int
(Expr_Value
(Choice
))) :=
3282 New_Copy_Tree
(Expression
(Elmt
));
3287 -- Range cases merge with Lo,Hi said
3289 if not Compile_Time_Known_Value
(Lo
)
3291 not Compile_Time_Known_Value
(Hi
)
3295 for J
in UI_To_Int
(Expr_Value
(Lo
)) ..
3296 UI_To_Int
(Expr_Value
(Hi
))
3298 Vals
(J
) := New_Copy_Tree
(Expression
(Elmt
));
3304 end loop Choice_Loop
;
3307 end loop Component_Loop
;
3309 -- If we get here the conversion is possible
3312 for J
in Vals
'Range loop
3313 Append
(Vals
(J
), Vlist
);
3316 Rewrite
(N
, Make_Aggregate
(Loc
, Expressions
=> Vlist
));
3317 Set_Aggregate_Bounds
(N
, Aggregate_Bounds
(Original_Node
(N
)));
3326 function Is_Flat
(N
: Node_Id
; Dims
: Int
) return Boolean is
3333 elsif Nkind
(N
) = N_Aggregate
then
3334 if Present
(Component_Associations
(N
)) then
3338 Elmt
:= First
(Expressions
(N
));
3340 while Present
(Elmt
) loop
3341 if not Is_Flat
(Elmt
, Dims
- 1) then
3355 -- Start of processing for Convert_To_Positional
3358 -- Ada 2005 (AI-287): Do not convert in case of default initialized
3359 -- components because in this case will need to call the corresponding
3362 if Has_Default_Init_Comps
(N
) then
3366 if Is_Flat
(N
, Number_Dimensions
(Typ
)) then
3370 if Is_Bit_Packed_Array
(Typ
)
3371 and then not Handle_Bit_Packed
3376 -- Do not convert to positional if controlled components are
3377 -- involved since these require special processing
3379 if Has_Controlled_Component
(Typ
) then
3383 if Aggr_Size_OK
(Typ
)
3385 Flatten
(N
, First_Index
(Typ
), First_Index
(Base_Type
(Typ
)))
3387 Analyze_And_Resolve
(N
, Typ
);
3389 end Convert_To_Positional
;
3391 ----------------------------
3392 -- Expand_Array_Aggregate --
3393 ----------------------------
3395 -- Array aggregate expansion proceeds as follows:
3397 -- 1. If requested we generate code to perform all the array aggregate
3398 -- bound checks, specifically
3400 -- (a) Check that the index range defined by aggregate bounds is
3401 -- compatible with corresponding index subtype.
3403 -- (b) If an others choice is present check that no aggregate
3404 -- index is outside the bounds of the index constraint.
3406 -- (c) For multidimensional arrays make sure that all subaggregates
3407 -- corresponding to the same dimension have the same bounds.
3409 -- 2. Check for packed array aggregate which can be converted to a
3410 -- constant so that the aggregate disappeares completely.
3412 -- 3. Check case of nested aggregate. Generally nested aggregates are
3413 -- handled during the processing of the parent aggregate.
3415 -- 4. Check if the aggregate can be statically processed. If this is the
3416 -- case pass it as is to Gigi. Note that a necessary condition for
3417 -- static processing is that the aggregate be fully positional.
3419 -- 5. If in place aggregate expansion is possible (i.e. no need to create
3420 -- a temporary) then mark the aggregate as such and return. Otherwise
3421 -- create a new temporary and generate the appropriate initialization
3424 procedure Expand_Array_Aggregate
(N
: Node_Id
) is
3425 Loc
: constant Source_Ptr
:= Sloc
(N
);
3427 Typ
: constant Entity_Id
:= Etype
(N
);
3428 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
3429 -- Typ is the correct constrained array subtype of the aggregate
3430 -- Ctyp is the corresponding component type.
3432 Aggr_Dimension
: constant Pos
:= Number_Dimensions
(Typ
);
3433 -- Number of aggregate index dimensions
3435 Aggr_Low
: array (1 .. Aggr_Dimension
) of Node_Id
;
3436 Aggr_High
: array (1 .. Aggr_Dimension
) of Node_Id
;
3437 -- Low and High bounds of the constraint for each aggregate index
3439 Aggr_Index_Typ
: array (1 .. Aggr_Dimension
) of Entity_Id
;
3440 -- The type of each index
3442 Maybe_In_Place_OK
: Boolean;
3443 -- If the type is neither controlled nor packed and the aggregate
3444 -- is the expression in an assignment, assignment in place may be
3445 -- possible, provided other conditions are met on the LHS.
3447 Others_Present
: array (1 .. Aggr_Dimension
) of Boolean :=
3449 -- If Others_Present (J) is True, then there is an others choice
3450 -- in one of the sub-aggregates of N at dimension J.
3452 procedure Build_Constrained_Type
(Positional
: Boolean);
3453 -- If the subtype is not static or unconstrained, build a constrained
3454 -- type using the computable sizes of the aggregate and its sub-
3457 procedure Check_Bounds
(Aggr_Bounds
: Node_Id
; Index_Bounds
: Node_Id
);
3458 -- Checks that the bounds of Aggr_Bounds are within the bounds defined
3461 procedure Check_Same_Aggr_Bounds
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3462 -- Checks that in a multi-dimensional array aggregate all subaggregates
3463 -- corresponding to the same dimension have the same bounds.
3464 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3465 -- corresponding to the sub-aggregate.
3467 procedure Compute_Others_Present
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3468 -- Computes the values of array Others_Present. Sub_Aggr is the
3469 -- array sub-aggregate we start the computation from. Dim is the
3470 -- dimension corresponding to the sub-aggregate.
3472 function Has_Address_Clause
(D
: Node_Id
) return Boolean;
3473 -- If the aggregate is the expression in an object declaration, it
3474 -- cannot be expanded in place. This function does a lookahead in the
3475 -- current declarative part to find an address clause for the object
3478 function In_Place_Assign_OK
return Boolean;
3479 -- Simple predicate to determine whether an aggregate assignment can
3480 -- be done in place, because none of the new values can depend on the
3481 -- components of the target of the assignment.
3483 procedure Others_Check
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3484 -- Checks that if an others choice is present in any sub-aggregate no
3485 -- aggregate index is outside the bounds of the index constraint.
3486 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3487 -- corresponding to the sub-aggregate.
3489 ----------------------------
3490 -- Build_Constrained_Type --
3491 ----------------------------
3493 procedure Build_Constrained_Type
(Positional
: Boolean) is
3494 Loc
: constant Source_Ptr
:= Sloc
(N
);
3495 Agg_Type
: Entity_Id
;
3498 Typ
: constant Entity_Id
:= Etype
(N
);
3499 Indices
: constant List_Id
:= New_List
;
3505 Make_Defining_Identifier
(
3506 Loc
, New_Internal_Name
('A'));
3508 -- If the aggregate is purely positional, all its subaggregates
3509 -- have the same size. We collect the dimensions from the first
3510 -- subaggregate at each level.
3515 for D
in 1 .. Number_Dimensions
(Typ
) loop
3516 Comp
:= First
(Expressions
(Sub_Agg
));
3521 while Present
(Comp
) loop
3528 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
3530 Make_Integer_Literal
(Loc
, Num
)),
3535 -- We know the aggregate type is unconstrained and the
3536 -- aggregate is not processable by the back end, therefore
3537 -- not necessarily positional. Retrieve the bounds of each
3538 -- dimension as computed earlier.
3540 for D
in 1 .. Number_Dimensions
(Typ
) loop
3543 Low_Bound
=> Aggr_Low
(D
),
3544 High_Bound
=> Aggr_High
(D
)),
3550 Make_Full_Type_Declaration
(Loc
,
3551 Defining_Identifier
=> Agg_Type
,
3553 Make_Constrained_Array_Definition
(Loc
,
3554 Discrete_Subtype_Definitions
=> Indices
,
3555 Component_Definition
=>
3556 Make_Component_Definition
(Loc
,
3557 Aliased_Present
=> False,
3558 Subtype_Indication
=>
3559 New_Occurrence_Of
(Component_Type
(Typ
), Loc
))));
3561 Insert_Action
(N
, Decl
);
3563 Set_Etype
(N
, Agg_Type
);
3564 Set_Is_Itype
(Agg_Type
);
3565 Freeze_Itype
(Agg_Type
, N
);
3566 end Build_Constrained_Type
;
3572 procedure Check_Bounds
(Aggr_Bounds
: Node_Id
; Index_Bounds
: Node_Id
) is
3579 Cond
: Node_Id
:= Empty
;
3582 Get_Index_Bounds
(Aggr_Bounds
, Aggr_Lo
, Aggr_Hi
);
3583 Get_Index_Bounds
(Index_Bounds
, Ind_Lo
, Ind_Hi
);
3585 -- Generate the following test:
3587 -- [constraint_error when
3588 -- Aggr_Lo <= Aggr_Hi and then
3589 -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
3591 -- As an optimization try to see if some tests are trivially vacuos
3592 -- because we are comparing an expression against itself.
3594 if Aggr_Lo
= Ind_Lo
and then Aggr_Hi
= Ind_Hi
then
3597 elsif Aggr_Hi
= Ind_Hi
then
3600 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3601 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Lo
));
3603 elsif Aggr_Lo
= Ind_Lo
then
3606 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
),
3607 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Hi
));
3614 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3615 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Lo
)),
3619 Left_Opnd
=> Duplicate_Subexpr
(Aggr_Hi
),
3620 Right_Opnd
=> Duplicate_Subexpr
(Ind_Hi
)));
3623 if Present
(Cond
) then
3628 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3629 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
)),
3631 Right_Opnd
=> Cond
);
3633 Set_Analyzed
(Left_Opnd
(Left_Opnd
(Cond
)), False);
3634 Set_Analyzed
(Right_Opnd
(Left_Opnd
(Cond
)), False);
3636 Make_Raise_Constraint_Error
(Loc
,
3638 Reason
=> CE_Length_Check_Failed
));
3642 ----------------------------
3643 -- Check_Same_Aggr_Bounds --
3644 ----------------------------
3646 procedure Check_Same_Aggr_Bounds
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
3647 Sub_Lo
: constant Node_Id
:= Low_Bound
(Aggregate_Bounds
(Sub_Aggr
));
3648 Sub_Hi
: constant Node_Id
:= High_Bound
(Aggregate_Bounds
(Sub_Aggr
));
3649 -- The bounds of this specific sub-aggregate
3651 Aggr_Lo
: constant Node_Id
:= Aggr_Low
(Dim
);
3652 Aggr_Hi
: constant Node_Id
:= Aggr_High
(Dim
);
3653 -- The bounds of the aggregate for this dimension
3655 Ind_Typ
: constant Entity_Id
:= Aggr_Index_Typ
(Dim
);
3656 -- The index type for this dimension.xxx
3658 Cond
: Node_Id
:= Empty
;
3664 -- If index checks are on generate the test
3666 -- [constraint_error when
3667 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
3669 -- As an optimization try to see if some tests are trivially vacuos
3670 -- because we are comparing an expression against itself. Also for
3671 -- the first dimension the test is trivially vacuous because there
3672 -- is just one aggregate for dimension 1.
3674 if Index_Checks_Suppressed
(Ind_Typ
) then
3678 or else (Aggr_Lo
= Sub_Lo
and then Aggr_Hi
= Sub_Hi
)
3682 elsif Aggr_Hi
= Sub_Hi
then
3685 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3686 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Lo
));
3688 elsif Aggr_Lo
= Sub_Lo
then
3691 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
),
3692 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Hi
));
3699 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3700 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Lo
)),
3704 Left_Opnd
=> Duplicate_Subexpr
(Aggr_Hi
),
3705 Right_Opnd
=> Duplicate_Subexpr
(Sub_Hi
)));
3708 if Present
(Cond
) then
3710 Make_Raise_Constraint_Error
(Loc
,
3712 Reason
=> CE_Length_Check_Failed
));
3715 -- Now look inside the sub-aggregate to see if there is more work
3717 if Dim
< Aggr_Dimension
then
3719 -- Process positional components
3721 if Present
(Expressions
(Sub_Aggr
)) then
3722 Expr
:= First
(Expressions
(Sub_Aggr
));
3723 while Present
(Expr
) loop
3724 Check_Same_Aggr_Bounds
(Expr
, Dim
+ 1);
3729 -- Process component associations
3731 if Present
(Component_Associations
(Sub_Aggr
)) then
3732 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
3733 while Present
(Assoc
) loop
3734 Expr
:= Expression
(Assoc
);
3735 Check_Same_Aggr_Bounds
(Expr
, Dim
+ 1);
3740 end Check_Same_Aggr_Bounds
;
3742 ----------------------------
3743 -- Compute_Others_Present --
3744 ----------------------------
3746 procedure Compute_Others_Present
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
3751 if Present
(Component_Associations
(Sub_Aggr
)) then
3752 Assoc
:= Last
(Component_Associations
(Sub_Aggr
));
3754 if Nkind
(First
(Choices
(Assoc
))) = N_Others_Choice
then
3755 Others_Present
(Dim
) := True;
3759 -- Now look inside the sub-aggregate to see if there is more work
3761 if Dim
< Aggr_Dimension
then
3763 -- Process positional components
3765 if Present
(Expressions
(Sub_Aggr
)) then
3766 Expr
:= First
(Expressions
(Sub_Aggr
));
3767 while Present
(Expr
) loop
3768 Compute_Others_Present
(Expr
, Dim
+ 1);
3773 -- Process component associations
3775 if Present
(Component_Associations
(Sub_Aggr
)) then
3776 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
3777 while Present
(Assoc
) loop
3778 Expr
:= Expression
(Assoc
);
3779 Compute_Others_Present
(Expr
, Dim
+ 1);
3784 end Compute_Others_Present
;
3786 ------------------------
3787 -- Has_Address_Clause --
3788 ------------------------
3790 function Has_Address_Clause
(D
: Node_Id
) return Boolean is
3791 Id
: constant Entity_Id
:= Defining_Identifier
(D
);
3792 Decl
: Node_Id
:= Next
(D
);
3795 while Present
(Decl
) loop
3796 if Nkind
(Decl
) = N_At_Clause
3797 and then Chars
(Identifier
(Decl
)) = Chars
(Id
)
3801 elsif Nkind
(Decl
) = N_Attribute_Definition_Clause
3802 and then Chars
(Decl
) = Name_Address
3803 and then Chars
(Name
(Decl
)) = Chars
(Id
)
3812 end Has_Address_Clause
;
3814 ------------------------
3815 -- In_Place_Assign_OK --
3816 ------------------------
3818 function In_Place_Assign_OK
return Boolean is
3826 function Is_Others_Aggregate
(Aggr
: Node_Id
) return Boolean;
3827 -- Aggregates that consist of a single Others choice are safe
3828 -- if the single expression is.
3830 function Safe_Aggregate
(Aggr
: Node_Id
) return Boolean;
3831 -- Check recursively that each component of a (sub)aggregate does
3832 -- not depend on the variable being assigned to.
3834 function Safe_Component
(Expr
: Node_Id
) return Boolean;
3835 -- Verify that an expression cannot depend on the variable being
3836 -- assigned to. Room for improvement here (but less than before).
3838 -------------------------
3839 -- Is_Others_Aggregate --
3840 -------------------------
3842 function Is_Others_Aggregate
(Aggr
: Node_Id
) return Boolean is
3844 return No
(Expressions
(Aggr
))
3846 (First
(Choices
(First
(Component_Associations
(Aggr
)))))
3848 end Is_Others_Aggregate
;
3850 --------------------
3851 -- Safe_Aggregate --
3852 --------------------
3854 function Safe_Aggregate
(Aggr
: Node_Id
) return Boolean is
3858 if Present
(Expressions
(Aggr
)) then
3859 Expr
:= First
(Expressions
(Aggr
));
3861 while Present
(Expr
) loop
3862 if Nkind
(Expr
) = N_Aggregate
then
3863 if not Safe_Aggregate
(Expr
) then
3867 elsif not Safe_Component
(Expr
) then
3875 if Present
(Component_Associations
(Aggr
)) then
3876 Expr
:= First
(Component_Associations
(Aggr
));
3878 while Present
(Expr
) loop
3879 if Nkind
(Expression
(Expr
)) = N_Aggregate
then
3880 if not Safe_Aggregate
(Expression
(Expr
)) then
3884 elsif not Safe_Component
(Expression
(Expr
)) then
3895 --------------------
3896 -- Safe_Component --
3897 --------------------
3899 function Safe_Component
(Expr
: Node_Id
) return Boolean is
3900 Comp
: Node_Id
:= Expr
;
3902 function Check_Component
(Comp
: Node_Id
) return Boolean;
3903 -- Do the recursive traversal, after copy
3905 ---------------------
3906 -- Check_Component --
3907 ---------------------
3909 function Check_Component
(Comp
: Node_Id
) return Boolean is
3911 if Is_Overloaded
(Comp
) then
3915 return Compile_Time_Known_Value
(Comp
)
3917 or else (Is_Entity_Name
(Comp
)
3918 and then Present
(Entity
(Comp
))
3919 and then No
(Renamed_Object
(Entity
(Comp
))))
3921 or else (Nkind
(Comp
) = N_Attribute_Reference
3922 and then Check_Component
(Prefix
(Comp
)))
3924 or else (Nkind
(Comp
) in N_Binary_Op
3925 and then Check_Component
(Left_Opnd
(Comp
))
3926 and then Check_Component
(Right_Opnd
(Comp
)))
3928 or else (Nkind
(Comp
) in N_Unary_Op
3929 and then Check_Component
(Right_Opnd
(Comp
)))
3931 or else (Nkind
(Comp
) = N_Selected_Component
3932 and then Check_Component
(Prefix
(Comp
)))
3934 or else (Nkind
(Comp
) = N_Unchecked_Type_Conversion
3935 and then Check_Component
(Expression
(Comp
)));
3936 end Check_Component
;
3938 -- Start of processing for Safe_Component
3941 -- If the component appears in an association that may
3942 -- correspond to more than one element, it is not analyzed
3943 -- before the expansion into assignments, to avoid side effects.
3944 -- We analyze, but do not resolve the copy, to obtain sufficient
3945 -- entity information for the checks that follow. If component is
3946 -- overloaded we assume an unsafe function call.
3948 if not Analyzed
(Comp
) then
3949 if Is_Overloaded
(Expr
) then
3952 elsif Nkind
(Expr
) = N_Aggregate
3953 and then not Is_Others_Aggregate
(Expr
)
3957 elsif Nkind
(Expr
) = N_Allocator
then
3959 -- For now, too complex to analyze
3964 Comp
:= New_Copy_Tree
(Expr
);
3965 Set_Parent
(Comp
, Parent
(Expr
));
3969 if Nkind
(Comp
) = N_Aggregate
then
3970 return Safe_Aggregate
(Comp
);
3972 return Check_Component
(Comp
);
3976 -- Start of processing for In_Place_Assign_OK
3979 if Present
(Component_Associations
(N
)) then
3981 -- On assignment, sliding can take place, so we cannot do the
3982 -- assignment in place unless the bounds of the aggregate are
3983 -- statically equal to those of the target.
3985 -- If the aggregate is given by an others choice, the bounds
3986 -- are derived from the left-hand side, and the assignment is
3987 -- safe if the expression is.
3989 if Is_Others_Aggregate
(N
) then
3992 (Expression
(First
(Component_Associations
(N
))));
3995 Aggr_In
:= First_Index
(Etype
(N
));
3996 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
3997 Obj_In
:= First_Index
(Etype
(Name
(Parent
(N
))));
4000 -- Context is an allocator. Check bounds of aggregate
4001 -- against given type in qualified expression.
4003 pragma Assert
(Nkind
(Parent
(Parent
(N
))) = N_Allocator
);
4005 First_Index
(Etype
(Entity
(Subtype_Mark
(Parent
(N
)))));
4008 while Present
(Aggr_In
) loop
4009 Get_Index_Bounds
(Aggr_In
, Aggr_Lo
, Aggr_Hi
);
4010 Get_Index_Bounds
(Obj_In
, Obj_Lo
, Obj_Hi
);
4012 if not Compile_Time_Known_Value
(Aggr_Lo
)
4013 or else not Compile_Time_Known_Value
(Aggr_Hi
)
4014 or else not Compile_Time_Known_Value
(Obj_Lo
)
4015 or else not Compile_Time_Known_Value
(Obj_Hi
)
4016 or else Expr_Value
(Aggr_Lo
) /= Expr_Value
(Obj_Lo
)
4017 or else Expr_Value
(Aggr_Hi
) /= Expr_Value
(Obj_Hi
)
4022 Next_Index
(Aggr_In
);
4023 Next_Index
(Obj_In
);
4027 -- Now check the component values themselves
4029 return Safe_Aggregate
(N
);
4030 end In_Place_Assign_OK
;
4036 procedure Others_Check
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
4037 Aggr_Lo
: constant Node_Id
:= Aggr_Low
(Dim
);
4038 Aggr_Hi
: constant Node_Id
:= Aggr_High
(Dim
);
4039 -- The bounds of the aggregate for this dimension
4041 Ind_Typ
: constant Entity_Id
:= Aggr_Index_Typ
(Dim
);
4042 -- The index type for this dimension
4044 Need_To_Check
: Boolean := False;
4046 Choices_Lo
: Node_Id
:= Empty
;
4047 Choices_Hi
: Node_Id
:= Empty
;
4048 -- The lowest and highest discrete choices for a named sub-aggregate
4050 Nb_Choices
: Int
:= -1;
4051 -- The number of discrete non-others choices in this sub-aggregate
4053 Nb_Elements
: Uint
:= Uint_0
;
4054 -- The number of elements in a positional aggregate
4056 Cond
: Node_Id
:= Empty
;
4063 -- Check if we have an others choice. If we do make sure that this
4064 -- sub-aggregate contains at least one element in addition to the
4067 if Range_Checks_Suppressed
(Ind_Typ
) then
4068 Need_To_Check
:= False;
4070 elsif Present
(Expressions
(Sub_Aggr
))
4071 and then Present
(Component_Associations
(Sub_Aggr
))
4073 Need_To_Check
:= True;
4075 elsif Present
(Component_Associations
(Sub_Aggr
)) then
4076 Assoc
:= Last
(Component_Associations
(Sub_Aggr
));
4078 if Nkind
(First
(Choices
(Assoc
))) /= N_Others_Choice
then
4079 Need_To_Check
:= False;
4082 -- Count the number of discrete choices. Start with -1
4083 -- because the others choice does not count.
4086 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4087 while Present
(Assoc
) loop
4088 Choice
:= First
(Choices
(Assoc
));
4089 while Present
(Choice
) loop
4090 Nb_Choices
:= Nb_Choices
+ 1;
4097 -- If there is only an others choice nothing to do
4099 Need_To_Check
:= (Nb_Choices
> 0);
4103 Need_To_Check
:= False;
4106 -- If we are dealing with a positional sub-aggregate with an
4107 -- others choice then compute the number or positional elements.
4109 if Need_To_Check
and then Present
(Expressions
(Sub_Aggr
)) then
4110 Expr
:= First
(Expressions
(Sub_Aggr
));
4111 Nb_Elements
:= Uint_0
;
4112 while Present
(Expr
) loop
4113 Nb_Elements
:= Nb_Elements
+ 1;
4117 -- If the aggregate contains discrete choices and an others choice
4118 -- compute the smallest and largest discrete choice values.
4120 elsif Need_To_Check
then
4121 Compute_Choices_Lo_And_Choices_Hi
: declare
4123 Table
: Case_Table_Type
(1 .. Nb_Choices
);
4124 -- Used to sort all the different choice values
4131 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4132 while Present
(Assoc
) loop
4133 Choice
:= First
(Choices
(Assoc
));
4134 while Present
(Choice
) loop
4135 if Nkind
(Choice
) = N_Others_Choice
then
4139 Get_Index_Bounds
(Choice
, Low
, High
);
4140 Table
(J
).Choice_Lo
:= Low
;
4141 Table
(J
).Choice_Hi
:= High
;
4150 -- Sort the discrete choices
4152 Sort_Case_Table
(Table
);
4154 Choices_Lo
:= Table
(1).Choice_Lo
;
4155 Choices_Hi
:= Table
(Nb_Choices
).Choice_Hi
;
4156 end Compute_Choices_Lo_And_Choices_Hi
;
4159 -- If no others choice in this sub-aggregate, or the aggregate
4160 -- comprises only an others choice, nothing to do.
4162 if not Need_To_Check
then
4165 -- If we are dealing with an aggregate containing an others
4166 -- choice and positional components, we generate the following test:
4168 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
4169 -- Ind_Typ'Pos (Aggr_Hi)
4171 -- raise Constraint_Error;
4174 elsif Nb_Elements
> Uint_0
then
4180 Make_Attribute_Reference
(Loc
,
4181 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
4182 Attribute_Name
=> Name_Pos
,
4185 (Duplicate_Subexpr_Move_Checks
(Aggr_Lo
))),
4186 Right_Opnd
=> Make_Integer_Literal
(Loc
, Nb_Elements
- 1)),
4189 Make_Attribute_Reference
(Loc
,
4190 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
4191 Attribute_Name
=> Name_Pos
,
4192 Expressions
=> New_List
(
4193 Duplicate_Subexpr_Move_Checks
(Aggr_Hi
))));
4195 -- If we are dealing with an aggregate containing an others
4196 -- choice and discrete choices we generate the following test:
4198 -- [constraint_error when
4199 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
4207 Duplicate_Subexpr_Move_Checks
(Choices_Lo
),
4209 Duplicate_Subexpr_Move_Checks
(Aggr_Lo
)),
4214 Duplicate_Subexpr
(Choices_Hi
),
4216 Duplicate_Subexpr
(Aggr_Hi
)));
4219 if Present
(Cond
) then
4221 Make_Raise_Constraint_Error
(Loc
,
4223 Reason
=> CE_Length_Check_Failed
));
4226 -- Now look inside the sub-aggregate to see if there is more work
4228 if Dim
< Aggr_Dimension
then
4230 -- Process positional components
4232 if Present
(Expressions
(Sub_Aggr
)) then
4233 Expr
:= First
(Expressions
(Sub_Aggr
));
4234 while Present
(Expr
) loop
4235 Others_Check
(Expr
, Dim
+ 1);
4240 -- Process component associations
4242 if Present
(Component_Associations
(Sub_Aggr
)) then
4243 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4244 while Present
(Assoc
) loop
4245 Expr
:= Expression
(Assoc
);
4246 Others_Check
(Expr
, Dim
+ 1);
4253 -- Remaining Expand_Array_Aggregate variables
4256 -- Holds the temporary aggregate value
4259 -- Holds the declaration of Tmp
4261 Aggr_Code
: List_Id
;
4262 Parent_Node
: Node_Id
;
4263 Parent_Kind
: Node_Kind
;
4265 -- Start of processing for Expand_Array_Aggregate
4268 -- Do not touch the special aggregates of attributes used for Asm calls
4270 if Is_RTE
(Ctyp
, RE_Asm_Input_Operand
)
4271 or else Is_RTE
(Ctyp
, RE_Asm_Output_Operand
)
4276 -- If the semantic analyzer has determined that aggregate N will raise
4277 -- Constraint_Error at run-time, then the aggregate node has been
4278 -- replaced with an N_Raise_Constraint_Error node and we should
4281 pragma Assert
(not Raises_Constraint_Error
(N
));
4285 -- Check that the index range defined by aggregate bounds is
4286 -- compatible with corresponding index subtype.
4288 Index_Compatibility_Check
: declare
4289 Aggr_Index_Range
: Node_Id
:= First_Index
(Typ
);
4290 -- The current aggregate index range
4292 Index_Constraint
: Node_Id
:= First_Index
(Etype
(Typ
));
4293 -- The corresponding index constraint against which we have to
4294 -- check the above aggregate index range.
4297 Compute_Others_Present
(N
, 1);
4299 for J
in 1 .. Aggr_Dimension
loop
4300 -- There is no need to emit a check if an others choice is
4301 -- present for this array aggregate dimension since in this
4302 -- case one of N's sub-aggregates has taken its bounds from the
4303 -- context and these bounds must have been checked already. In
4304 -- addition all sub-aggregates corresponding to the same
4305 -- dimension must all have the same bounds (checked in (c) below).
4307 if not Range_Checks_Suppressed
(Etype
(Index_Constraint
))
4308 and then not Others_Present
(J
)
4310 -- We don't use Checks.Apply_Range_Check here because it
4311 -- emits a spurious check. Namely it checks that the range
4312 -- defined by the aggregate bounds is non empty. But we know
4313 -- this already if we get here.
4315 Check_Bounds
(Aggr_Index_Range
, Index_Constraint
);
4318 -- Save the low and high bounds of the aggregate index as well
4319 -- as the index type for later use in checks (b) and (c) below.
4321 Aggr_Low
(J
) := Low_Bound
(Aggr_Index_Range
);
4322 Aggr_High
(J
) := High_Bound
(Aggr_Index_Range
);
4324 Aggr_Index_Typ
(J
) := Etype
(Index_Constraint
);
4326 Next_Index
(Aggr_Index_Range
);
4327 Next_Index
(Index_Constraint
);
4329 end Index_Compatibility_Check
;
4333 -- If an others choice is present check that no aggregate
4334 -- index is outside the bounds of the index constraint.
4336 Others_Check
(N
, 1);
4340 -- For multidimensional arrays make sure that all subaggregates
4341 -- corresponding to the same dimension have the same bounds.
4343 if Aggr_Dimension
> 1 then
4344 Check_Same_Aggr_Bounds
(N
, 1);
4349 -- Here we test for is packed array aggregate that we can handle
4350 -- at compile time. If so, return with transformation done. Note
4351 -- that we do this even if the aggregate is nested, because once
4352 -- we have done this processing, there is no more nested aggregate!
4354 if Packed_Array_Aggregate_Handled
(N
) then
4358 -- At this point we try to convert to positional form
4360 Convert_To_Positional
(N
);
4362 -- if the result is no longer an aggregate (e.g. it may be a string
4363 -- literal, or a temporary which has the needed value), then we are
4364 -- done, since there is no longer a nested aggregate.
4366 if Nkind
(N
) /= N_Aggregate
then
4369 -- We are also done if the result is an analyzed aggregate
4370 -- This case could use more comments ???
4373 and then N
/= Original_Node
(N
)
4378 -- Now see if back end processing is possible
4380 if Backend_Processing_Possible
(N
) then
4382 -- If the aggregate is static but the constraints are not, build
4383 -- a static subtype for the aggregate, so that Gigi can place it
4384 -- in static memory. Perform an unchecked_conversion to the non-
4385 -- static type imposed by the context.
4388 Itype
: constant Entity_Id
:= Etype
(N
);
4390 Needs_Type
: Boolean := False;
4393 Index
:= First_Index
(Itype
);
4395 while Present
(Index
) loop
4396 if not Is_Static_Subtype
(Etype
(Index
)) then
4405 Build_Constrained_Type
(Positional
=> True);
4406 Rewrite
(N
, Unchecked_Convert_To
(Itype
, N
));
4416 -- Delay expansion for nested aggregates it will be taken care of
4417 -- when the parent aggregate is expanded
4419 Parent_Node
:= Parent
(N
);
4420 Parent_Kind
:= Nkind
(Parent_Node
);
4422 if Parent_Kind
= N_Qualified_Expression
then
4423 Parent_Node
:= Parent
(Parent_Node
);
4424 Parent_Kind
:= Nkind
(Parent_Node
);
4427 if Parent_Kind
= N_Aggregate
4428 or else Parent_Kind
= N_Extension_Aggregate
4429 or else Parent_Kind
= N_Component_Association
4430 or else (Parent_Kind
= N_Object_Declaration
4431 and then Controlled_Type
(Typ
))
4432 or else (Parent_Kind
= N_Assignment_Statement
4433 and then Inside_Init_Proc
)
4435 Set_Expansion_Delayed
(N
);
4441 -- Look if in place aggregate expansion is possible
4443 -- For object declarations we build the aggregate in place, unless
4444 -- the array is bit-packed or the component is controlled.
4446 -- For assignments we do the assignment in place if all the component
4447 -- associations have compile-time known values. For other cases we
4448 -- create a temporary. The analysis for safety of on-line assignment
4449 -- is delicate, i.e. we don't know how to do it fully yet ???
4451 -- For allocators we assign to the designated object in place if the
4452 -- aggregate meets the same conditions as other in-place assignments.
4453 -- In this case the aggregate may not come from source but was created
4454 -- for default initialization, e.g. with Initialize_Scalars.
4456 if Requires_Transient_Scope
(Typ
) then
4457 Establish_Transient_Scope
4458 (N
, Sec_Stack
=> Has_Controlled_Component
(Typ
));
4461 if Has_Default_Init_Comps
(N
) then
4462 Maybe_In_Place_OK
:= False;
4464 elsif Is_Bit_Packed_Array
(Typ
)
4465 or else Has_Controlled_Component
(Typ
)
4467 Maybe_In_Place_OK
:= False;
4470 Maybe_In_Place_OK
:=
4471 (Nkind
(Parent
(N
)) = N_Assignment_Statement
4472 and then Comes_From_Source
(N
)
4473 and then In_Place_Assign_OK
)
4476 (Nkind
(Parent
(Parent
(N
))) = N_Allocator
4477 and then In_Place_Assign_OK
);
4480 if not Has_Default_Init_Comps
(N
)
4481 and then Comes_From_Source
(Parent
(N
))
4482 and then Nkind
(Parent
(N
)) = N_Object_Declaration
4484 Must_Slide
(Etype
(Defining_Identifier
(Parent
(N
))), Typ
)
4485 and then N
= Expression
(Parent
(N
))
4486 and then not Is_Bit_Packed_Array
(Typ
)
4487 and then not Has_Controlled_Component
(Typ
)
4488 and then not Has_Address_Clause
(Parent
(N
))
4490 Tmp
:= Defining_Identifier
(Parent
(N
));
4491 Set_No_Initialization
(Parent
(N
));
4492 Set_Expression
(Parent
(N
), Empty
);
4494 -- Set the type of the entity, for use in the analysis of the
4495 -- subsequent indexed assignments. If the nominal type is not
4496 -- constrained, build a subtype from the known bounds of the
4497 -- aggregate. If the declaration has a subtype mark, use it,
4498 -- otherwise use the itype of the aggregate.
4500 if not Is_Constrained
(Typ
) then
4501 Build_Constrained_Type
(Positional
=> False);
4502 elsif Is_Entity_Name
(Object_Definition
(Parent
(N
)))
4503 and then Is_Constrained
(Entity
(Object_Definition
(Parent
(N
))))
4505 Set_Etype
(Tmp
, Entity
(Object_Definition
(Parent
(N
))));
4507 Set_Size_Known_At_Compile_Time
(Typ
, False);
4508 Set_Etype
(Tmp
, Typ
);
4511 elsif Maybe_In_Place_OK
4512 and then Nkind
(Parent
(N
)) = N_Qualified_Expression
4513 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
4515 Set_Expansion_Delayed
(N
);
4518 -- In the remaining cases the aggregate is the RHS of an assignment
4520 elsif Maybe_In_Place_OK
4521 and then Is_Entity_Name
(Name
(Parent
(N
)))
4523 Tmp
:= Entity
(Name
(Parent
(N
)));
4525 if Etype
(Tmp
) /= Etype
(N
) then
4526 Apply_Length_Check
(N
, Etype
(Tmp
));
4528 if Nkind
(N
) = N_Raise_Constraint_Error
then
4530 -- Static error, nothing further to expand
4536 elsif Maybe_In_Place_OK
4537 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
4538 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
4540 Tmp
:= Name
(Parent
(N
));
4542 if Etype
(Tmp
) /= Etype
(N
) then
4543 Apply_Length_Check
(N
, Etype
(Tmp
));
4546 elsif Maybe_In_Place_OK
4547 and then Nkind
(Name
(Parent
(N
))) = N_Slice
4548 and then Safe_Slice_Assignment
(N
)
4550 -- Safe_Slice_Assignment rewrites assignment as a loop
4556 -- In place aggregate expansion is not possible
4559 Maybe_In_Place_OK
:= False;
4560 Tmp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
4562 Make_Object_Declaration
4564 Defining_Identifier
=> Tmp
,
4565 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
4566 Set_No_Initialization
(Tmp_Decl
, True);
4568 -- If we are within a loop, the temporary will be pushed on the
4569 -- stack at each iteration. If the aggregate is the expression for
4570 -- an allocator, it will be immediately copied to the heap and can
4571 -- be reclaimed at once. We create a transient scope around the
4572 -- aggregate for this purpose.
4574 if Ekind
(Current_Scope
) = E_Loop
4575 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
4577 Establish_Transient_Scope
(N
, False);
4580 Insert_Action
(N
, Tmp_Decl
);
4583 -- Construct and insert the aggregate code. We can safely suppress
4584 -- index checks because this code is guaranteed not to raise CE
4585 -- on index checks. However we should *not* suppress all checks.
4591 if Nkind
(Tmp
) = N_Defining_Identifier
then
4592 Target
:= New_Reference_To
(Tmp
, Loc
);
4596 if Has_Default_Init_Comps
(N
) then
4598 -- Ada 2005 (AI-287): This case has not been analyzed???
4600 raise Program_Error
;
4603 -- Name in assignment is explicit dereference
4605 Target
:= New_Copy
(Tmp
);
4609 Build_Array_Aggr_Code
(N
,
4611 Index
=> First_Index
(Typ
),
4613 Scalar_Comp
=> Is_Scalar_Type
(Ctyp
));
4616 if Comes_From_Source
(Tmp
) then
4617 Insert_Actions_After
(Parent
(N
), Aggr_Code
);
4620 Insert_Actions
(N
, Aggr_Code
);
4623 -- If the aggregate has been assigned in place, remove the original
4626 if Nkind
(Parent
(N
)) = N_Assignment_Statement
4627 and then Maybe_In_Place_OK
4629 Rewrite
(Parent
(N
), Make_Null_Statement
(Loc
));
4631 elsif Nkind
(Parent
(N
)) /= N_Object_Declaration
4632 or else Tmp
/= Defining_Identifier
(Parent
(N
))
4634 Rewrite
(N
, New_Occurrence_Of
(Tmp
, Loc
));
4635 Analyze_And_Resolve
(N
, Typ
);
4637 end Expand_Array_Aggregate
;
4639 ------------------------
4640 -- Expand_N_Aggregate --
4641 ------------------------
4643 procedure Expand_N_Aggregate
(N
: Node_Id
) is
4645 if Is_Record_Type
(Etype
(N
)) then
4646 Expand_Record_Aggregate
(N
);
4648 Expand_Array_Aggregate
(N
);
4652 when RE_Not_Available
=>
4654 end Expand_N_Aggregate
;
4656 ----------------------------------
4657 -- Expand_N_Extension_Aggregate --
4658 ----------------------------------
4660 -- If the ancestor part is an expression, add a component association for
4661 -- the parent field. If the type of the ancestor part is not the direct
4662 -- parent of the expected type, build recursively the needed ancestors.
4663 -- If the ancestor part is a subtype_mark, replace aggregate with a decla-
4664 -- ration for a temporary of the expected type, followed by individual
4665 -- assignments to the given components.
4667 procedure Expand_N_Extension_Aggregate
(N
: Node_Id
) is
4668 Loc
: constant Source_Ptr
:= Sloc
(N
);
4669 A
: constant Node_Id
:= Ancestor_Part
(N
);
4670 Typ
: constant Entity_Id
:= Etype
(N
);
4673 -- If the ancestor is a subtype mark, an init proc must be called
4674 -- on the resulting object which thus has to be materialized in
4677 if Is_Entity_Name
(A
) and then Is_Type
(Entity
(A
)) then
4678 Convert_To_Assignments
(N
, Typ
);
4680 -- The extension aggregate is transformed into a record aggregate
4681 -- of the following form (c1 and c2 are inherited components)
4683 -- (Exp with c3 => a, c4 => b)
4684 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b)
4689 -- No tag is needed in the case of Java_VM
4692 Expand_Record_Aggregate
(N
,
4695 Expand_Record_Aggregate
(N
,
4698 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
),
4704 when RE_Not_Available
=>
4706 end Expand_N_Extension_Aggregate
;
4708 -----------------------------
4709 -- Expand_Record_Aggregate --
4710 -----------------------------
4712 procedure Expand_Record_Aggregate
4714 Orig_Tag
: Node_Id
:= Empty
;
4715 Parent_Expr
: Node_Id
:= Empty
)
4717 Loc
: constant Source_Ptr
:= Sloc
(N
);
4718 Comps
: constant List_Id
:= Component_Associations
(N
);
4719 Typ
: constant Entity_Id
:= Etype
(N
);
4720 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
4722 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
return Boolean;
4723 -- Checks the presence of a nested aggregate which needs Late_Expansion
4724 -- or the presence of tagged components which may need tag adjustment.
4726 --------------------------------------------------
4727 -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
4728 --------------------------------------------------
4730 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
return Boolean is
4740 while Present
(C
) loop
4741 if Nkind
(Expression
(C
)) = N_Qualified_Expression
then
4742 Expr_Q
:= Expression
(Expression
(C
));
4744 Expr_Q
:= Expression
(C
);
4747 -- Return true if the aggregate has any associations for
4748 -- tagged components that may require tag adjustment.
4749 -- These are cases where the source expression may have
4750 -- a tag that could differ from the component tag (e.g.,
4751 -- can occur for type conversions and formal parameters).
4752 -- (Tag adjustment is not needed if Java_VM because object
4753 -- tags are implicit in the JVM.)
4755 if Is_Tagged_Type
(Etype
(Expr_Q
))
4756 and then (Nkind
(Expr_Q
) = N_Type_Conversion
4757 or else (Is_Entity_Name
(Expr_Q
)
4758 and then Ekind
(Entity
(Expr_Q
)) in Formal_Kind
))
4759 and then not Java_VM
4764 if Is_Delayed_Aggregate
(Expr_Q
) then
4772 end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
;
4774 -- Remaining Expand_Record_Aggregate variables
4776 Tag_Value
: Node_Id
;
4780 -- Start of processing for Expand_Record_Aggregate
4783 -- If the aggregate is to be assigned to an atomic variable, we
4784 -- have to prevent a piecemeal assignment even if the aggregate
4785 -- is to be expanded. We create a temporary for the aggregate, and
4786 -- assign the temporary instead, so that the back end can generate
4787 -- an atomic move for it.
4790 and then (Nkind
(Parent
(N
)) = N_Object_Declaration
4791 or else Nkind
(Parent
(N
)) = N_Assignment_Statement
)
4792 and then Comes_From_Source
(Parent
(N
))
4794 Expand_Atomic_Aggregate
(N
, Typ
);
4798 -- Ada 2005 (AI-318-2): We need to convert to assignments if components
4799 -- are build-in-place function calls. This test could be more specific,
4800 -- but doing it for all inherently limited aggregates seems harmless.
4801 -- The assignments will turn into build-in-place function calls (see
4802 -- Make_Build_In_Place_Call_In_Assignment).
4804 if Ada_Version
>= Ada_05
and then Is_Inherently_Limited_Type
(Typ
) then
4805 Convert_To_Assignments
(N
, Typ
);
4807 -- Gigi doesn't handle properly temporaries of variable size
4808 -- so we generate it in the front-end
4810 elsif not Size_Known_At_Compile_Time
(Typ
) then
4811 Convert_To_Assignments
(N
, Typ
);
4813 -- Temporaries for controlled aggregates need to be attached to a
4814 -- final chain in order to be properly finalized, so it has to
4815 -- be created in the front-end
4817 elsif Is_Controlled
(Typ
)
4818 or else Has_Controlled_Component
(Base_Type
(Typ
))
4820 Convert_To_Assignments
(N
, Typ
);
4822 -- Ada 2005 (AI-287): In case of default initialized components we
4823 -- convert the aggregate into assignments.
4825 elsif Has_Default_Init_Comps
(N
) then
4826 Convert_To_Assignments
(N
, Typ
);
4828 elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
then
4829 Convert_To_Assignments
(N
, Typ
);
4831 -- If an ancestor is private, some components are not inherited and
4832 -- we cannot expand into a record aggregate
4834 elsif Has_Private_Ancestor
(Typ
) then
4835 Convert_To_Assignments
(N
, Typ
);
4837 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
4838 -- is not able to handle the aggregate for Late_Request.
4840 elsif Is_Tagged_Type
(Typ
) and then Has_Discriminants
(Typ
) then
4841 Convert_To_Assignments
(N
, Typ
);
4843 -- If some components are mutable, the size of the aggregate component
4844 -- may be disctinct from the default size of the type component, so
4845 -- we need to expand to insure that the back-end copies the proper
4846 -- size of the data.
4848 elsif Has_Mutable_Components
(Typ
) then
4849 Convert_To_Assignments
(N
, Typ
);
4851 -- If the type involved has any non-bit aligned components, then
4852 -- we are not sure that the back end can handle this case correctly.
4854 elsif Type_May_Have_Bit_Aligned_Components
(Typ
) then
4855 Convert_To_Assignments
(N
, Typ
);
4857 -- In all other cases we generate a proper aggregate that
4858 -- can be handled by gigi.
4861 -- If no discriminants, nothing special to do
4863 if not Has_Discriminants
(Typ
) then
4866 -- Case of discriminants present
4868 elsif Is_Derived_Type
(Typ
) then
4870 -- For untagged types, non-stored discriminants are replaced
4871 -- with stored discriminants, which are the ones that gigi uses
4872 -- to describe the type and its components.
4874 Generate_Aggregate_For_Derived_Type
: declare
4875 Constraints
: constant List_Id
:= New_List
;
4876 First_Comp
: Node_Id
;
4877 Discriminant
: Entity_Id
;
4879 Num_Disc
: Int
:= 0;
4880 Num_Gird
: Int
:= 0;
4882 procedure Prepend_Stored_Values
(T
: Entity_Id
);
4883 -- Scan the list of stored discriminants of the type, and
4884 -- add their values to the aggregate being built.
4886 ---------------------------
4887 -- Prepend_Stored_Values --
4888 ---------------------------
4890 procedure Prepend_Stored_Values
(T
: Entity_Id
) is
4892 Discriminant
:= First_Stored_Discriminant
(T
);
4894 while Present
(Discriminant
) loop
4896 Make_Component_Association
(Loc
,
4898 New_List
(New_Occurrence_Of
(Discriminant
, Loc
)),
4902 Get_Discriminant_Value
(
4905 Discriminant_Constraint
(Typ
))));
4907 if No
(First_Comp
) then
4908 Prepend_To
(Component_Associations
(N
), New_Comp
);
4910 Insert_After
(First_Comp
, New_Comp
);
4913 First_Comp
:= New_Comp
;
4914 Next_Stored_Discriminant
(Discriminant
);
4916 end Prepend_Stored_Values
;
4918 -- Start of processing for Generate_Aggregate_For_Derived_Type
4921 -- Remove the associations for the discriminant of
4922 -- the derived type.
4924 First_Comp
:= First
(Component_Associations
(N
));
4926 while Present
(First_Comp
) loop
4930 if Ekind
(Entity
(First
(Choices
(Comp
)))) =
4934 Num_Disc
:= Num_Disc
+ 1;
4938 -- Insert stored discriminant associations in the correct
4939 -- order. If there are more stored discriminants than new
4940 -- discriminants, there is at least one new discriminant
4941 -- that constrains more than one of the stored discriminants.
4942 -- In this case we need to construct a proper subtype of
4943 -- the parent type, in order to supply values to all the
4944 -- components. Otherwise there is one-one correspondence
4945 -- between the constraints and the stored discriminants.
4947 First_Comp
:= Empty
;
4949 Discriminant
:= First_Stored_Discriminant
(Base_Type
(Typ
));
4951 while Present
(Discriminant
) loop
4952 Num_Gird
:= Num_Gird
+ 1;
4953 Next_Stored_Discriminant
(Discriminant
);
4956 -- Case of more stored discriminants than new discriminants
4958 if Num_Gird
> Num_Disc
then
4960 -- Create a proper subtype of the parent type, which is
4961 -- the proper implementation type for the aggregate, and
4962 -- convert it to the intended target type.
4964 Discriminant
:= First_Stored_Discriminant
(Base_Type
(Typ
));
4966 while Present
(Discriminant
) loop
4969 Get_Discriminant_Value
(
4972 Discriminant_Constraint
(Typ
)));
4973 Append
(New_Comp
, Constraints
);
4974 Next_Stored_Discriminant
(Discriminant
);
4978 Make_Subtype_Declaration
(Loc
,
4979 Defining_Identifier
=>
4980 Make_Defining_Identifier
(Loc
,
4981 New_Internal_Name
('T')),
4982 Subtype_Indication
=>
4983 Make_Subtype_Indication
(Loc
,
4985 New_Occurrence_Of
(Etype
(Base_Type
(Typ
)), Loc
),
4987 Make_Index_Or_Discriminant_Constraint
4988 (Loc
, Constraints
)));
4990 Insert_Action
(N
, Decl
);
4991 Prepend_Stored_Values
(Base_Type
(Typ
));
4993 Set_Etype
(N
, Defining_Identifier
(Decl
));
4996 Rewrite
(N
, Unchecked_Convert_To
(Typ
, N
));
4999 -- Case where we do not have fewer new discriminants than
5000 -- stored discriminants, so in this case we can simply
5001 -- use the stored discriminants of the subtype.
5004 Prepend_Stored_Values
(Typ
);
5006 end Generate_Aggregate_For_Derived_Type
;
5009 if Is_Tagged_Type
(Typ
) then
5011 -- The tagged case, _parent and _tag component must be created
5013 -- Reset null_present unconditionally. tagged records always have
5014 -- at least one field (the tag or the parent)
5016 Set_Null_Record_Present
(N
, False);
5018 -- When the current aggregate comes from the expansion of an
5019 -- extension aggregate, the parent expr is replaced by an
5020 -- aggregate formed by selected components of this expr
5022 if Present
(Parent_Expr
)
5023 and then Is_Empty_List
(Comps
)
5025 Comp
:= First_Entity
(Typ
);
5026 while Present
(Comp
) loop
5028 -- Skip all entities that aren't discriminants or components
5030 if Ekind
(Comp
) /= E_Discriminant
5031 and then Ekind
(Comp
) /= E_Component
5035 -- Skip all expander-generated components
5038 not Comes_From_Source
(Original_Record_Component
(Comp
))
5044 Make_Selected_Component
(Loc
,
5046 Unchecked_Convert_To
(Typ
,
5047 Duplicate_Subexpr
(Parent_Expr
, True)),
5049 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
5052 Make_Component_Association
(Loc
,
5054 New_List
(New_Occurrence_Of
(Comp
, Loc
)),
5058 Analyze_And_Resolve
(New_Comp
, Etype
(Comp
));
5065 -- Compute the value for the Tag now, if the type is a root it
5066 -- will be included in the aggregate right away, otherwise it will
5067 -- be propagated to the parent aggregate
5069 if Present
(Orig_Tag
) then
5070 Tag_Value
:= Orig_Tag
;
5076 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
5079 -- For a derived type, an aggregate for the parent is formed with
5080 -- all the inherited components.
5082 if Is_Derived_Type
(Typ
) then
5085 First_Comp
: Node_Id
;
5086 Parent_Comps
: List_Id
;
5087 Parent_Aggr
: Node_Id
;
5088 Parent_Name
: Node_Id
;
5091 -- Remove the inherited component association from the
5092 -- aggregate and store them in the parent aggregate
5094 First_Comp
:= First
(Component_Associations
(N
));
5095 Parent_Comps
:= New_List
;
5097 while Present
(First_Comp
)
5098 and then Scope
(Original_Record_Component
(
5099 Entity
(First
(Choices
(First_Comp
))))) /= Base_Typ
5104 Append
(Comp
, Parent_Comps
);
5107 Parent_Aggr
:= Make_Aggregate
(Loc
,
5108 Component_Associations
=> Parent_Comps
);
5109 Set_Etype
(Parent_Aggr
, Etype
(Base_Type
(Typ
)));
5111 -- Find the _parent component
5113 Comp
:= First_Component
(Typ
);
5114 while Chars
(Comp
) /= Name_uParent
loop
5115 Comp
:= Next_Component
(Comp
);
5118 Parent_Name
:= New_Occurrence_Of
(Comp
, Loc
);
5120 -- Insert the parent aggregate
5122 Prepend_To
(Component_Associations
(N
),
5123 Make_Component_Association
(Loc
,
5124 Choices
=> New_List
(Parent_Name
),
5125 Expression
=> Parent_Aggr
));
5127 -- Expand recursively the parent propagating the right Tag
5129 Expand_Record_Aggregate
(
5130 Parent_Aggr
, Tag_Value
, Parent_Expr
);
5133 -- For a root type, the tag component is added (unless compiling
5134 -- for the Java VM, where tags are implicit).
5136 elsif not Java_VM
then
5138 Tag_Name
: constant Node_Id
:=
5140 (First_Tag_Component
(Typ
), Loc
);
5141 Typ_Tag
: constant Entity_Id
:= RTE
(RE_Tag
);
5142 Conv_Node
: constant Node_Id
:=
5143 Unchecked_Convert_To
(Typ_Tag
, Tag_Value
);
5146 Set_Etype
(Conv_Node
, Typ_Tag
);
5147 Prepend_To
(Component_Associations
(N
),
5148 Make_Component_Association
(Loc
,
5149 Choices
=> New_List
(Tag_Name
),
5150 Expression
=> Conv_Node
));
5155 end Expand_Record_Aggregate
;
5157 ----------------------------
5158 -- Has_Default_Init_Comps --
5159 ----------------------------
5161 function Has_Default_Init_Comps
(N
: Node_Id
) return Boolean is
5162 Comps
: constant List_Id
:= Component_Associations
(N
);
5166 pragma Assert
(Nkind
(N
) = N_Aggregate
5167 or else Nkind
(N
) = N_Extension_Aggregate
);
5173 if Has_Self_Reference
(N
) then
5177 -- Check if any direct component has default initialized components
5180 while Present
(C
) loop
5181 if Box_Present
(C
) then
5188 -- Recursive call in case of aggregate expression
5191 while Present
(C
) loop
5192 Expr
:= Expression
(C
);
5195 and then (Nkind
(Expr
) = N_Aggregate
5196 or else Nkind
(Expr
) = N_Extension_Aggregate
)
5197 and then Has_Default_Init_Comps
(Expr
)
5206 end Has_Default_Init_Comps
;
5208 --------------------------
5209 -- Is_Delayed_Aggregate --
5210 --------------------------
5212 function Is_Delayed_Aggregate
(N
: Node_Id
) return Boolean is
5213 Node
: Node_Id
:= N
;
5214 Kind
: Node_Kind
:= Nkind
(Node
);
5217 if Kind
= N_Qualified_Expression
then
5218 Node
:= Expression
(Node
);
5219 Kind
:= Nkind
(Node
);
5222 if Kind
/= N_Aggregate
and then Kind
/= N_Extension_Aggregate
then
5225 return Expansion_Delayed
(Node
);
5227 end Is_Delayed_Aggregate
;
5229 --------------------
5230 -- Late_Expansion --
5231 --------------------
5233 function Late_Expansion
5237 Flist
: Node_Id
:= Empty
;
5238 Obj
: Entity_Id
:= Empty
) return List_Id
5241 if Is_Record_Type
(Etype
(N
)) then
5242 return Build_Record_Aggr_Code
(N
, Typ
, Target
, Flist
, Obj
);
5244 else pragma Assert
(Is_Array_Type
(Etype
(N
)));
5246 Build_Array_Aggr_Code
5248 Ctype
=> Component_Type
(Etype
(N
)),
5249 Index
=> First_Index
(Typ
),
5251 Scalar_Comp
=> Is_Scalar_Type
(Component_Type
(Typ
)),
5257 ----------------------------------
5258 -- Make_OK_Assignment_Statement --
5259 ----------------------------------
5261 function Make_OK_Assignment_Statement
5264 Expression
: Node_Id
;
5265 Self_Ref
: Boolean := False) return Node_Id
5267 function Replace_Type
(Expr
: Node_Id
) return Traverse_Result
;
5268 -- If the aggregate contains a self-reference, traverse each
5269 -- expression to replace a possible self-reference with a reference
5270 -- to the proper component of the target of the assignment.
5276 function Replace_Type
(Expr
: Node_Id
) return Traverse_Result
is
5278 if Nkind
(Expr
) = N_Attribute_Reference
5279 and then Is_Entity_Name
(Prefix
(Expr
))
5280 and then Is_Type
(Entity
(Prefix
(Expr
)))
5282 if Is_Entity_Name
(Prefix
(Name
)) then
5283 Rewrite
(Prefix
(Expr
),
5284 New_Occurrence_Of
(Entity
(Prefix
(Name
)), Sloc
));
5287 Make_Attribute_Reference
(Sloc
,
5288 Attribute_Name
=> Name_Unrestricted_Access
,
5289 Prefix
=> New_Copy_Tree
(Prefix
(Name
))));
5290 Set_Analyzed
(Parent
(Expr
), False);
5296 procedure Replace_Self_Reference
is
5297 new Traverse_Proc
(Replace_Type
);
5299 -- Start of processing for Make_OK_Assignment_Statement
5302 Set_Assignment_OK
(Name
);
5305 Replace_Self_Reference
(Expression
);
5308 return Make_Assignment_Statement
(Sloc
, Name
, Expression
);
5309 end Make_OK_Assignment_Statement
;
5311 -----------------------
5312 -- Number_Of_Choices --
5313 -----------------------
5315 function Number_Of_Choices
(N
: Node_Id
) return Nat
is
5319 Nb_Choices
: Nat
:= 0;
5322 if Present
(Expressions
(N
)) then
5326 Assoc
:= First
(Component_Associations
(N
));
5327 while Present
(Assoc
) loop
5329 Choice
:= First
(Choices
(Assoc
));
5330 while Present
(Choice
) loop
5332 if Nkind
(Choice
) /= N_Others_Choice
then
5333 Nb_Choices
:= Nb_Choices
+ 1;
5343 end Number_Of_Choices
;
5345 ------------------------------------
5346 -- Packed_Array_Aggregate_Handled --
5347 ------------------------------------
5349 -- The current version of this procedure will handle at compile time
5350 -- any array aggregate that meets these conditions:
5352 -- One dimensional, bit packed
5353 -- Underlying packed type is modular type
5354 -- Bounds are within 32-bit Int range
5355 -- All bounds and values are static
5357 function Packed_Array_Aggregate_Handled
(N
: Node_Id
) return Boolean is
5358 Loc
: constant Source_Ptr
:= Sloc
(N
);
5359 Typ
: constant Entity_Id
:= Etype
(N
);
5360 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
5362 Not_Handled
: exception;
5363 -- Exception raised if this aggregate cannot be handled
5366 -- For now, handle only one dimensional bit packed arrays
5368 if not Is_Bit_Packed_Array
(Typ
)
5369 or else Number_Dimensions
(Typ
) > 1
5370 or else not Is_Modular_Integer_Type
(Packed_Array_Type
(Typ
))
5376 Csiz
: constant Nat
:= UI_To_Int
(Component_Size
(Typ
));
5380 -- Bounds of index type
5384 -- Values of bounds if compile time known
5386 function Get_Component_Val
(N
: Node_Id
) return Uint
;
5387 -- Given a expression value N of the component type Ctyp, returns
5388 -- A value of Csiz (component size) bits representing this value.
5389 -- If the value is non-static or any other reason exists why the
5390 -- value cannot be returned, then Not_Handled is raised.
5392 -----------------------
5393 -- Get_Component_Val --
5394 -----------------------
5396 function Get_Component_Val
(N
: Node_Id
) return Uint
is
5400 -- We have to analyze the expression here before doing any further
5401 -- processing here. The analysis of such expressions is deferred
5402 -- till expansion to prevent some problems of premature analysis.
5404 Analyze_And_Resolve
(N
, Ctyp
);
5406 -- Must have a compile time value. String literals have to
5407 -- be converted into temporaries as well, because they cannot
5408 -- easily be converted into their bit representation.
5410 if not Compile_Time_Known_Value
(N
)
5411 or else Nkind
(N
) = N_String_Literal
5416 Val
:= Expr_Rep_Value
(N
);
5418 -- Adjust for bias, and strip proper number of bits
5420 if Has_Biased_Representation
(Ctyp
) then
5421 Val
:= Val
- Expr_Value
(Type_Low_Bound
(Ctyp
));
5424 return Val
mod Uint_2
** Csiz
;
5425 end Get_Component_Val
;
5427 -- Here we know we have a one dimensional bit packed array
5430 Get_Index_Bounds
(First_Index
(Typ
), Lo
, Hi
);
5432 -- Cannot do anything if bounds are dynamic
5434 if not Compile_Time_Known_Value
(Lo
)
5436 not Compile_Time_Known_Value
(Hi
)
5441 -- Or are silly out of range of int bounds
5443 Lob
:= Expr_Value
(Lo
);
5444 Hib
:= Expr_Value
(Hi
);
5446 if not UI_Is_In_Int_Range
(Lob
)
5448 not UI_Is_In_Int_Range
(Hib
)
5453 -- At this stage we have a suitable aggregate for handling
5454 -- at compile time (the only remaining checks, are that the
5455 -- values of expressions in the aggregate are compile time
5456 -- known (check performed by Get_Component_Val), and that
5457 -- any subtypes or ranges are statically known.
5459 -- If the aggregate is not fully positional at this stage,
5460 -- then convert it to positional form. Either this will fail,
5461 -- in which case we can do nothing, or it will succeed, in
5462 -- which case we have succeeded in handling the aggregate,
5463 -- or it will stay an aggregate, in which case we have failed
5464 -- to handle this case.
5466 if Present
(Component_Associations
(N
)) then
5467 Convert_To_Positional
5468 (N
, Max_Others_Replicate
=> 64, Handle_Bit_Packed
=> True);
5469 return Nkind
(N
) /= N_Aggregate
;
5472 -- Otherwise we are all positional, so convert to proper value
5475 Lov
: constant Int
:= UI_To_Int
(Lob
);
5476 Hiv
: constant Int
:= UI_To_Int
(Hib
);
5478 Len
: constant Nat
:= Int
'Max (0, Hiv
- Lov
+ 1);
5479 -- The length of the array (number of elements)
5481 Aggregate_Val
: Uint
;
5482 -- Value of aggregate. The value is set in the low order
5483 -- bits of this value. For the little-endian case, the
5484 -- values are stored from low-order to high-order and
5485 -- for the big-endian case the values are stored from
5486 -- high-order to low-order. Note that gigi will take care
5487 -- of the conversions to left justify the value in the big
5488 -- endian case (because of left justified modular type
5489 -- processing), so we do not have to worry about that here.
5492 -- Integer literal for resulting constructed value
5495 -- Shift count from low order for next value
5498 -- Shift increment for loop
5501 -- Next expression from positional parameters of aggregate
5504 -- For little endian, we fill up the low order bits of the
5505 -- target value. For big endian we fill up the high order
5506 -- bits of the target value (which is a left justified
5509 if Bytes_Big_Endian
xor Debug_Flag_8
then
5510 Shift
:= Csiz
* (Len
- 1);
5517 -- Loop to set the values
5520 Aggregate_Val
:= Uint_0
;
5522 Expr
:= First
(Expressions
(N
));
5523 Aggregate_Val
:= Get_Component_Val
(Expr
) * Uint_2
** Shift
;
5525 for J
in 2 .. Len
loop
5526 Shift
:= Shift
+ Incr
;
5529 Aggregate_Val
+ Get_Component_Val
(Expr
) * Uint_2
** Shift
;
5533 -- Now we can rewrite with the proper value
5536 Make_Integer_Literal
(Loc
,
5537 Intval
=> Aggregate_Val
);
5538 Set_Print_In_Hex
(Lit
);
5540 -- Construct the expression using this literal. Note that it is
5541 -- important to qualify the literal with its proper modular type
5542 -- since universal integer does not have the required range and
5543 -- also this is a left justified modular type, which is important
5544 -- in the big-endian case.
5547 Unchecked_Convert_To
(Typ
,
5548 Make_Qualified_Expression
(Loc
,
5550 New_Occurrence_Of
(Packed_Array_Type
(Typ
), Loc
),
5551 Expression
=> Lit
)));
5553 Analyze_And_Resolve
(N
, Typ
);
5561 end Packed_Array_Aggregate_Handled
;
5563 ----------------------------
5564 -- Has_Mutable_Components --
5565 ----------------------------
5567 function Has_Mutable_Components
(Typ
: Entity_Id
) return Boolean is
5571 Comp
:= First_Component
(Typ
);
5573 while Present
(Comp
) loop
5574 if Is_Record_Type
(Etype
(Comp
))
5575 and then Has_Discriminants
(Etype
(Comp
))
5576 and then not Is_Constrained
(Etype
(Comp
))
5581 Next_Component
(Comp
);
5585 end Has_Mutable_Components
;
5587 ------------------------------
5588 -- Initialize_Discriminants --
5589 ------------------------------
5591 procedure Initialize_Discriminants
(N
: Node_Id
; Typ
: Entity_Id
) is
5592 Loc
: constant Source_Ptr
:= Sloc
(N
);
5593 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
5594 Par
: constant Entity_Id
:= Etype
(Bas
);
5595 Decl
: constant Node_Id
:= Parent
(Par
);
5599 if Is_Tagged_Type
(Bas
)
5600 and then Is_Derived_Type
(Bas
)
5601 and then Has_Discriminants
(Par
)
5602 and then Has_Discriminants
(Bas
)
5603 and then Number_Discriminants
(Bas
) /= Number_Discriminants
(Par
)
5604 and then Nkind
(Decl
) = N_Full_Type_Declaration
5605 and then Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
5607 (Variant_Part
(Component_List
(Type_Definition
(Decl
))))
5608 and then Nkind
(N
) /= N_Extension_Aggregate
5611 -- Call init proc to set discriminants.
5612 -- There should eventually be a special procedure for this ???
5614 Ref
:= New_Reference_To
(Defining_Identifier
(N
), Loc
);
5615 Insert_Actions_After
(N
,
5616 Build_Initialization_Call
(Sloc
(N
), Ref
, Typ
));
5618 end Initialize_Discriminants
;
5625 (Obj_Type
: Entity_Id
;
5626 Typ
: Entity_Id
) return Boolean
5628 L1
, L2
, H1
, H2
: Node_Id
;
5630 -- No sliding if the type of the object is not established yet, if
5631 -- it is an unconstrained type whose actual subtype comes from the
5632 -- aggregate, or if the two types are identical.
5634 if not Is_Array_Type
(Obj_Type
) then
5637 elsif not Is_Constrained
(Obj_Type
) then
5640 elsif Typ
= Obj_Type
then
5644 -- Sliding can only occur along the first dimension
5646 Get_Index_Bounds
(First_Index
(Typ
), L1
, H1
);
5647 Get_Index_Bounds
(First_Index
(Obj_Type
), L2
, H2
);
5649 if not Is_Static_Expression
(L1
)
5650 or else not Is_Static_Expression
(L2
)
5651 or else not Is_Static_Expression
(H1
)
5652 or else not Is_Static_Expression
(H2
)
5656 return Expr_Value
(L1
) /= Expr_Value
(L2
)
5657 or else Expr_Value
(H1
) /= Expr_Value
(H2
);
5662 ---------------------------
5663 -- Safe_Slice_Assignment --
5664 ---------------------------
5666 function Safe_Slice_Assignment
(N
: Node_Id
) return Boolean is
5667 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
5668 Pref
: constant Node_Id
:= Prefix
(Name
(Parent
(N
)));
5669 Range_Node
: constant Node_Id
:= Discrete_Range
(Name
(Parent
(N
)));
5677 -- Generate: for J in Range loop Pref (J) := Expr; end loop;
5679 if Comes_From_Source
(N
)
5680 and then No
(Expressions
(N
))
5681 and then Nkind
(First
(Choices
(First
(Component_Associations
(N
)))))
5685 Expression
(First
(Component_Associations
(N
)));
5686 L_J
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
5689 Make_Iteration_Scheme
(Loc
,
5690 Loop_Parameter_Specification
=>
5691 Make_Loop_Parameter_Specification
5693 Defining_Identifier
=> L_J
,
5694 Discrete_Subtype_Definition
=> Relocate_Node
(Range_Node
)));
5697 Make_Assignment_Statement
(Loc
,
5699 Make_Indexed_Component
(Loc
,
5700 Prefix
=> Relocate_Node
(Pref
),
5701 Expressions
=> New_List
(New_Occurrence_Of
(L_J
, Loc
))),
5702 Expression
=> Relocate_Node
(Expr
));
5704 -- Construct the final loop
5707 Make_Implicit_Loop_Statement
5708 (Node
=> Parent
(N
),
5709 Identifier
=> Empty
,
5710 Iteration_Scheme
=> L_Iter
,
5711 Statements
=> New_List
(L_Body
));
5713 -- Set type of aggregate to be type of lhs in assignment,
5714 -- to suppress redundant length checks.
5716 Set_Etype
(N
, Etype
(Name
(Parent
(N
))));
5718 Rewrite
(Parent
(N
), Stat
);
5719 Analyze
(Parent
(N
));
5725 end Safe_Slice_Assignment
;
5727 ---------------------
5728 -- Sort_Case_Table --
5729 ---------------------
5731 procedure Sort_Case_Table
(Case_Table
: in out Case_Table_Type
) is
5732 L
: constant Int
:= Case_Table
'First;
5733 U
: constant Int
:= Case_Table
'Last;
5742 T
:= Case_Table
(K
+ 1);
5746 and then Expr_Value
(Case_Table
(J
- 1).Choice_Lo
) >
5747 Expr_Value
(T
.Choice_Lo
)
5749 Case_Table
(J
) := Case_Table
(J
- 1);
5753 Case_Table
(J
) := T
;
5756 end Sort_Case_Table
;