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
;
44 with Restrict
; use Restrict
;
45 with Rident
; use Rident
;
46 with Rtsfind
; use Rtsfind
;
47 with Ttypes
; use Ttypes
;
49 with Sem_Ch3
; use Sem_Ch3
;
50 with Sem_Eval
; use Sem_Eval
;
51 with Sem_Res
; use Sem_Res
;
52 with Sem_Util
; use Sem_Util
;
53 with Sinfo
; use Sinfo
;
54 with Snames
; use Snames
;
55 with Stand
; use Stand
;
56 with Tbuild
; use Tbuild
;
57 with Uintp
; use Uintp
;
59 package body Exp_Aggr
is
61 type Case_Bounds
is record
64 Choice_Node
: Node_Id
;
67 type Case_Table_Type
is array (Nat
range <>) of Case_Bounds
;
68 -- Table type used by Check_Case_Choices procedure
71 (Obj_Type
: Entity_Id
;
72 Typ
: Entity_Id
) return Boolean;
73 -- A static array aggregate in an object declaration can in most cases be
74 -- expanded in place. The one exception is when the aggregate is given
75 -- with component associations that specify different bounds from those of
76 -- the type definition in the object declaration. In this pathological
77 -- case the aggregate must slide, and we must introduce an intermediate
78 -- temporary to hold it.
80 -- The same holds in an assignment to one-dimensional array of arrays,
81 -- when a component may be given with bounds that differ from those of the
84 procedure Sort_Case_Table
(Case_Table
: in out Case_Table_Type
);
85 -- Sort the Case Table using the Lower Bound of each Choice as the key.
86 -- A simple insertion sort is used since the number of choices in a case
87 -- statement of variant part will usually be small and probably in near
90 function Has_Default_Init_Comps
(N
: Node_Id
) return Boolean;
91 -- N is an aggregate (record or array). Checks the presence of default
92 -- initialization (<>) in any component (Ada 2005: AI-287)
94 ------------------------------------------------------
95 -- Local subprograms for Record Aggregate Expansion --
96 ------------------------------------------------------
98 procedure Expand_Record_Aggregate
100 Orig_Tag
: Node_Id
:= Empty
;
101 Parent_Expr
: Node_Id
:= Empty
);
102 -- This is the top level procedure for record aggregate expansion.
103 -- Expansion for record aggregates needs expand aggregates for tagged
104 -- record types. Specifically Expand_Record_Aggregate adds the Tag
105 -- field in front of the Component_Association list that was created
106 -- during resolution by Resolve_Record_Aggregate.
108 -- N is the record aggregate node.
109 -- Orig_Tag is the value of the Tag that has to be provided for this
110 -- specific aggregate. It carries the tag corresponding to the type
111 -- of the outermost aggregate during the recursive expansion
112 -- Parent_Expr is the ancestor part of the original extension
115 procedure Convert_To_Assignments
(N
: Node_Id
; Typ
: Entity_Id
);
116 -- N is an N_Aggregate of a N_Extension_Aggregate. Typ is the type of
117 -- the aggregate. Transform the given aggregate into a sequence of
118 -- assignments component per component.
120 function Build_Record_Aggr_Code
124 Flist
: Node_Id
:= Empty
;
125 Obj
: Entity_Id
:= Empty
;
126 Is_Limited_Ancestor_Expansion
: Boolean := False) return List_Id
;
127 -- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type of the
128 -- aggregate. Target is an expression containing the location on which the
129 -- component by component assignments will take place. Returns the list of
130 -- assignments plus all other adjustments needed for tagged and controlled
131 -- types. Flist is an expression representing the finalization list on
132 -- which to attach the controlled components if any. Obj is present in the
133 -- object declaration and dynamic allocation cases, it contains an entity
134 -- that allows to know if the value being created needs to be attached to
135 -- the final list in case of pragma finalize_Storage_Only.
137 -- Is_Limited_Ancestor_Expansion indicates that the function has been
138 -- called recursively to expand the limited ancestor to avoid copying it.
140 function Has_Mutable_Components
(Typ
: Entity_Id
) return Boolean;
141 -- Return true if one of the component is of a discriminated type with
142 -- defaults. An aggregate for a type with mutable components must be
143 -- expanded into individual assignments.
145 procedure Initialize_Discriminants
(N
: Node_Id
; Typ
: Entity_Id
);
146 -- If the type of the aggregate is a type extension with renamed discrimi-
147 -- nants, we must initialize the hidden discriminants of the parent.
148 -- Otherwise, the target object must not be initialized. The discriminants
149 -- are initialized by calling the initialization procedure for the type.
150 -- This is incorrect if the initialization of other components has any
151 -- side effects. We restrict this call to the case where the parent type
152 -- has a variant part, because this is the only case where the hidden
153 -- discriminants are accessed, namely when calling discriminant checking
154 -- functions of the parent type, and when applying a stream attribute to
155 -- an object of the derived type.
157 -----------------------------------------------------
158 -- Local Subprograms for Array Aggregate Expansion --
159 -----------------------------------------------------
161 function Aggr_Size_OK
(Typ
: Entity_Id
) return Boolean;
162 -- Very large static aggregates present problems to the back-end, and
163 -- are transformed into assignments and loops. This function verifies
164 -- that the total number of components of an aggregate is acceptable
165 -- for transformation into a purely positional static form. It is called
166 -- prior to calling Flatten.
168 procedure Convert_Array_Aggr_In_Allocator
172 -- If the aggregate appears within an allocator and can be expanded in
173 -- place, this routine generates the individual assignments to components
174 -- of the designated object. This is an optimization over the general
175 -- case, where a temporary is first created on the stack and then used to
176 -- construct the allocated object on the heap.
178 procedure Convert_To_Positional
180 Max_Others_Replicate
: Nat
:= 5;
181 Handle_Bit_Packed
: Boolean := False);
182 -- If possible, convert named notation to positional notation. This
183 -- conversion is possible only in some static cases. If the conversion is
184 -- possible, then N is rewritten with the analyzed converted aggregate.
185 -- The parameter Max_Others_Replicate controls the maximum number of
186 -- values corresponding to an others choice that will be converted to
187 -- positional notation (the default of 5 is the normal limit, and reflects
188 -- the fact that normally the loop is better than a lot of separate
189 -- assignments). Note that this limit gets overridden in any case if
190 -- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
191 -- set. The parameter Handle_Bit_Packed is usually set False (since we do
192 -- not expect the back end to handle bit packed arrays, so the normal case
193 -- of conversion is pointless), but in the special case of a call from
194 -- Packed_Array_Aggregate_Handled, we set this parameter to True, since
195 -- these are cases we handle in there.
197 procedure Expand_Array_Aggregate
(N
: Node_Id
);
198 -- This is the top-level routine to perform array aggregate expansion.
199 -- N is the N_Aggregate node to be expanded.
201 function Backend_Processing_Possible
(N
: Node_Id
) return Boolean;
202 -- This function checks if array aggregate N can be processed directly
203 -- by Gigi. If this is the case True is returned.
205 function Build_Array_Aggr_Code
210 Scalar_Comp
: Boolean;
211 Indices
: List_Id
:= No_List
;
212 Flist
: Node_Id
:= Empty
) return List_Id
;
213 -- This recursive routine returns a list of statements containing the
214 -- loops and assignments that are needed for the expansion of the array
217 -- N is the (sub-)aggregate node to be expanded into code. This node
218 -- has been fully analyzed, and its Etype is properly set.
220 -- Index is the index node corresponding to the array sub-aggregate N.
222 -- Into is the target expression into which we are copying the aggregate.
223 -- Note that this node may not have been analyzed yet, and so the Etype
224 -- field may not be set.
226 -- Scalar_Comp is True if the component type of the aggregate is scalar.
228 -- Indices is the current list of expressions used to index the
229 -- object we are writing into.
231 -- Flist is an expression representing the finalization list on which
232 -- to attach the controlled components if any.
234 function Number_Of_Choices
(N
: Node_Id
) return Nat
;
235 -- Returns the number of discrete choices (not including the others choice
236 -- if present) contained in (sub-)aggregate N.
238 function Late_Expansion
242 Flist
: Node_Id
:= Empty
;
243 Obj
: Entity_Id
:= Empty
) return List_Id
;
244 -- N is a nested (record or array) aggregate that has been marked with
245 -- 'Delay_Expansion'. Typ is the expected type of the aggregate and Target
246 -- is a (duplicable) expression that will hold the result of the aggregate
247 -- expansion. Flist is the finalization list to be used to attach
248 -- controlled components. 'Obj' when non empty, carries the original
249 -- object being initialized in order to know if it needs to be attached to
250 -- the previous parameter which may not be the case in the case where
251 -- Finalize_Storage_Only is set. Basically this procedure is used to
252 -- implement top-down expansions of nested aggregates. This is necessary
253 -- for avoiding temporaries at each level as well as for propagating the
254 -- right internal finalization list.
256 function Make_OK_Assignment_Statement
259 Expression
: Node_Id
) return Node_Id
;
260 -- This is like Make_Assignment_Statement, except that Assignment_OK
261 -- is set in the left operand. All assignments built by this unit
262 -- use this routine. This is needed to deal with assignments to
263 -- initialized constants that are done in place.
265 function Packed_Array_Aggregate_Handled
(N
: Node_Id
) return Boolean;
266 -- Given an array aggregate, this function handles the case of a packed
267 -- array aggregate with all constant values, where the aggregate can be
268 -- evaluated at compile time. If this is possible, then N is rewritten
269 -- to be its proper compile time value with all the components properly
270 -- assembled. The expression is analyzed and resolved and True is
271 -- returned. If this transformation is not possible, N is unchanged
272 -- and False is returned
274 function Safe_Slice_Assignment
(N
: Node_Id
) return Boolean;
275 -- If a slice assignment has an aggregate with a single others_choice,
276 -- the assignment can be done in place even if bounds are not static,
277 -- by converting it into a loop over the discrete range of the slice.
283 function Aggr_Size_OK
(Typ
: Entity_Id
) return Boolean is
291 -- The following constant determines the maximum size of an
292 -- aggregate produced by converting named to positional
293 -- notation (e.g. from others clauses). This avoids running
294 -- away with attempts to convert huge aggregates, which hit
295 -- memory limits in the backend.
297 -- The normal limit is 5000, but we increase this limit to
298 -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code)
299 -- or Restrictions (No_Implicit_Loops) is specified, since in
300 -- either case, we are at risk of declaring the program illegal
301 -- because of this limit.
303 Max_Aggr_Size
: constant Nat
:=
304 5000 + (2 ** 24 - 5000) *
306 (Restriction_Active
(No_Elaboration_Code
)
308 Restriction_Active
(No_Implicit_Loops
));
310 function Component_Count
(T
: Entity_Id
) return Int
;
311 -- The limit is applied to the total number of components that the
312 -- aggregate will have, which is the number of static expressions
313 -- that will appear in the flattened array. This requires a recursive
314 -- computation of the the number of scalar components of the structure.
316 ---------------------
317 -- Component_Count --
318 ---------------------
320 function Component_Count
(T
: Entity_Id
) return Int
is
325 if Is_Scalar_Type
(T
) then
328 elsif Is_Record_Type
(T
) then
329 Comp
:= First_Component
(T
);
330 while Present
(Comp
) loop
331 Res
:= Res
+ Component_Count
(Etype
(Comp
));
332 Next_Component
(Comp
);
337 elsif Is_Array_Type
(T
) then
339 Lo
: constant Node_Id
:=
340 Type_Low_Bound
(Etype
(First_Index
(T
)));
341 Hi
: constant Node_Id
:=
342 Type_High_Bound
(Etype
(First_Index
(T
)));
344 Siz
: constant Int
:= Component_Count
(Component_Type
(T
));
347 if not Compile_Time_Known_Value
(Lo
)
348 or else not Compile_Time_Known_Value
(Hi
)
353 Siz
* UI_To_Int
(Expr_Value
(Hi
) - Expr_Value
(Lo
) + 1);
358 -- Can only be a null for an access type
364 -- Start of processing for Aggr_Size_OK
367 Siz
:= Component_Count
(Component_Type
(Typ
));
368 Indx
:= First_Index
(Typ
);
370 while Present
(Indx
) loop
371 Lo
:= Type_Low_Bound
(Etype
(Indx
));
372 Hi
:= Type_High_Bound
(Etype
(Indx
));
374 -- Bounds need to be known at compile time
376 if not Compile_Time_Known_Value
(Lo
)
377 or else not Compile_Time_Known_Value
(Hi
)
382 Lov
:= Expr_Value
(Lo
);
383 Hiv
:= Expr_Value
(Hi
);
385 -- A flat array is always safe
392 Rng
: constant Uint
:= Hiv
- Lov
+ 1;
395 -- Check if size is too large
397 if not UI_Is_In_Int_Range
(Rng
) then
401 Siz
:= Siz
* UI_To_Int
(Rng
);
405 or else Siz
> Max_Aggr_Size
410 -- Bounds must be in integer range, for later array construction
412 if not UI_Is_In_Int_Range
(Lov
)
414 not UI_Is_In_Int_Range
(Hiv
)
425 ---------------------------------
426 -- Backend_Processing_Possible --
427 ---------------------------------
429 -- Backend processing by Gigi/gcc is possible only if all the following
430 -- conditions are met:
432 -- 1. N is fully positional
434 -- 2. N is not a bit-packed array aggregate;
436 -- 3. The size of N's array type must be known at compile time. Note
437 -- that this implies that the component size is also known
439 -- 4. The array type of N does not follow the Fortran layout convention
440 -- or if it does it must be 1 dimensional.
442 -- 5. The array component type is tagged, which may necessitate
443 -- reassignment of proper tags.
445 -- 6. The array component type might have unaligned bit components
447 function Backend_Processing_Possible
(N
: Node_Id
) return Boolean is
448 Typ
: constant Entity_Id
:= Etype
(N
);
449 -- Typ is the correct constrained array subtype of the aggregate
451 function Static_Check
(N
: Node_Id
; Index
: Node_Id
) return Boolean;
452 -- Recursively checks that N is fully positional, returns true if so
458 function Static_Check
(N
: Node_Id
; Index
: Node_Id
) return Boolean is
462 -- Check for component associations
464 if Present
(Component_Associations
(N
)) then
468 -- Recurse to check subaggregates, which may appear in qualified
469 -- expressions. If delayed, the front-end will have to expand.
471 Expr
:= First
(Expressions
(N
));
473 while Present
(Expr
) loop
475 if Is_Delayed_Aggregate
(Expr
) then
479 if Present
(Next_Index
(Index
))
480 and then not Static_Check
(Expr
, Next_Index
(Index
))
491 -- Start of processing for Backend_Processing_Possible
494 -- Checks 2 (array must not be bit packed)
496 if Is_Bit_Packed_Array
(Typ
) then
500 -- Checks 4 (array must not be multi-dimensional Fortran case)
502 if Convention
(Typ
) = Convention_Fortran
503 and then Number_Dimensions
(Typ
) > 1
508 -- Checks 3 (size of array must be known at compile time)
510 if not Size_Known_At_Compile_Time
(Typ
) then
514 -- Checks 1 (aggregate must be fully positional)
516 if not Static_Check
(N
, First_Index
(Typ
)) then
520 -- Checks 5 (if the component type is tagged, then we may need
521 -- to do tag adjustments; perhaps this should be refined to check for
522 -- any component associations that actually need tag adjustment,
523 -- along the lines of the test that is carried out in
524 -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps for record aggregates
525 -- with tagged components, but not clear whether it's worthwhile ???;
526 -- in the case of the JVM, object tags are handled implicitly)
528 if Is_Tagged_Type
(Component_Type
(Typ
)) and then not Java_VM
then
532 -- Checks 6 (component type must not have bit aligned components)
534 if Type_May_Have_Bit_Aligned_Components
(Component_Type
(Typ
)) then
538 -- Backend processing is possible
540 Set_Compile_Time_Known_Aggregate
(N
, True);
541 Set_Size_Known_At_Compile_Time
(Etype
(N
), True);
543 end Backend_Processing_Possible
;
545 ---------------------------
546 -- Build_Array_Aggr_Code --
547 ---------------------------
549 -- The code that we generate from a one dimensional aggregate is
551 -- 1. If the sub-aggregate contains discrete choices we
553 -- (a) Sort the discrete choices
555 -- (b) Otherwise for each discrete choice that specifies a range we
556 -- emit a loop. If a range specifies a maximum of three values, or
557 -- we are dealing with an expression we emit a sequence of
558 -- assignments instead of a loop.
560 -- (c) Generate the remaining loops to cover the others choice if any
562 -- 2. If the aggregate contains positional elements we
564 -- (a) translate the positional elements in a series of assignments
566 -- (b) Generate a final loop to cover the others choice if any.
567 -- Note that this final loop has to be a while loop since the case
569 -- L : Integer := Integer'Last;
570 -- H : Integer := Integer'Last;
571 -- A : array (L .. H) := (1, others =>0);
573 -- cannot be handled by a for loop. Thus for the following
575 -- array (L .. H) := (.. positional elements.., others =>E);
577 -- we always generate something like:
579 -- J : Index_Type := Index_Of_Last_Positional_Element;
581 -- J := Index_Base'Succ (J)
585 function Build_Array_Aggr_Code
590 Scalar_Comp
: Boolean;
591 Indices
: List_Id
:= No_List
;
592 Flist
: Node_Id
:= Empty
) return List_Id
594 Loc
: constant Source_Ptr
:= Sloc
(N
);
595 Index_Base
: constant Entity_Id
:= Base_Type
(Etype
(Index
));
596 Index_Base_L
: constant Node_Id
:= Type_Low_Bound
(Index_Base
);
597 Index_Base_H
: constant Node_Id
:= Type_High_Bound
(Index_Base
);
599 function Add
(Val
: Int
; To
: Node_Id
) return Node_Id
;
600 -- Returns an expression where Val is added to expression To, unless
601 -- To+Val is provably out of To's base type range. To must be an
602 -- already analyzed expression.
604 function Empty_Range
(L
, H
: Node_Id
) return Boolean;
605 -- Returns True if the range defined by L .. H is certainly empty
607 function Equal
(L
, H
: Node_Id
) return Boolean;
608 -- Returns True if L = H for sure
610 function Index_Base_Name
return Node_Id
;
611 -- Returns a new reference to the index type name
613 function Gen_Assign
(Ind
: Node_Id
; Expr
: Node_Id
) return List_Id
;
614 -- Ind must be a side-effect free expression. If the input aggregate
615 -- N to Build_Loop contains no sub-aggregates, then this function
616 -- returns the assignment statement:
618 -- Into (Indices, Ind) := Expr;
620 -- Otherwise we call Build_Code recursively
622 -- Ada 2005 (AI-287): In case of default initialized component, Expr
623 -- is empty and we generate a call to the corresponding IP subprogram.
625 function Gen_Loop
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
;
626 -- Nodes L and H must be side-effect free expressions.
627 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
628 -- This routine returns the for loop statement
630 -- for J in Index_Base'(L) .. Index_Base'(H) loop
631 -- Into (Indices, J) := Expr;
634 -- Otherwise we call Build_Code recursively.
635 -- As an optimization if the loop covers 3 or less scalar elements we
636 -- generate a sequence of assignments.
638 function Gen_While
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
;
639 -- Nodes L and H must be side-effect free expressions.
640 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
641 -- This routine returns the while loop statement
643 -- J : Index_Base := L;
645 -- J := Index_Base'Succ (J);
646 -- Into (Indices, J) := Expr;
649 -- Otherwise we call Build_Code recursively
651 function Local_Compile_Time_Known_Value
(E
: Node_Id
) return Boolean;
652 function Local_Expr_Value
(E
: Node_Id
) return Uint
;
653 -- These two Local routines are used to replace the corresponding ones
654 -- in sem_eval because while processing the bounds of an aggregate with
655 -- discrete choices whose index type is an enumeration, we build static
656 -- expressions not recognized by Compile_Time_Known_Value as such since
657 -- they have not yet been analyzed and resolved. All the expressions in
658 -- question are things like Index_Base_Name'Val (Const) which we can
659 -- easily recognize as being constant.
665 function Add
(Val
: Int
; To
: Node_Id
) return Node_Id
is
670 U_Val
: constant Uint
:= UI_From_Int
(Val
);
673 -- Note: do not try to optimize the case of Val = 0, because
674 -- we need to build a new node with the proper Sloc value anyway.
676 -- First test if we can do constant folding
678 if Local_Compile_Time_Known_Value
(To
) then
679 U_To
:= Local_Expr_Value
(To
) + Val
;
681 -- Determine if our constant is outside the range of the index.
682 -- If so return an Empty node. This empty node will be caught
683 -- by Empty_Range below.
685 if Compile_Time_Known_Value
(Index_Base_L
)
686 and then U_To
< Expr_Value
(Index_Base_L
)
690 elsif Compile_Time_Known_Value
(Index_Base_H
)
691 and then U_To
> Expr_Value
(Index_Base_H
)
696 Expr_Pos
:= Make_Integer_Literal
(Loc
, U_To
);
697 Set_Is_Static_Expression
(Expr_Pos
);
699 if not Is_Enumeration_Type
(Index_Base
) then
702 -- If we are dealing with enumeration return
703 -- Index_Base'Val (Expr_Pos)
707 Make_Attribute_Reference
709 Prefix
=> Index_Base_Name
,
710 Attribute_Name
=> Name_Val
,
711 Expressions
=> New_List
(Expr_Pos
));
717 -- If we are here no constant folding possible
719 if not Is_Enumeration_Type
(Index_Base
) then
722 Left_Opnd
=> Duplicate_Subexpr
(To
),
723 Right_Opnd
=> Make_Integer_Literal
(Loc
, U_Val
));
725 -- If we are dealing with enumeration return
726 -- Index_Base'Val (Index_Base'Pos (To) + Val)
730 Make_Attribute_Reference
732 Prefix
=> Index_Base_Name
,
733 Attribute_Name
=> Name_Pos
,
734 Expressions
=> New_List
(Duplicate_Subexpr
(To
)));
739 Right_Opnd
=> Make_Integer_Literal
(Loc
, U_Val
));
742 Make_Attribute_Reference
744 Prefix
=> Index_Base_Name
,
745 Attribute_Name
=> Name_Val
,
746 Expressions
=> New_List
(Expr_Pos
));
756 function Empty_Range
(L
, H
: Node_Id
) return Boolean is
757 Is_Empty
: Boolean := False;
762 -- First check if L or H were already detected as overflowing the
763 -- index base range type by function Add above. If this is so Add
764 -- returns the empty node.
766 if No
(L
) or else No
(H
) then
773 -- L > H range is empty
779 -- B_L > H range must be empty
785 -- L > B_H range must be empty
789 High
:= Index_Base_H
;
792 if Local_Compile_Time_Known_Value
(Low
)
793 and then Local_Compile_Time_Known_Value
(High
)
796 UI_Gt
(Local_Expr_Value
(Low
), Local_Expr_Value
(High
));
809 function Equal
(L
, H
: Node_Id
) return Boolean is
814 elsif Local_Compile_Time_Known_Value
(L
)
815 and then Local_Compile_Time_Known_Value
(H
)
817 return UI_Eq
(Local_Expr_Value
(L
), Local_Expr_Value
(H
));
827 function Gen_Assign
(Ind
: Node_Id
; Expr
: Node_Id
) return List_Id
is
828 L
: constant List_Id
:= New_List
;
832 New_Indices
: List_Id
;
833 Indexed_Comp
: Node_Id
;
835 Comp_Type
: Entity_Id
:= Empty
;
837 function Add_Loop_Actions
(Lis
: List_Id
) return List_Id
;
838 -- Collect insert_actions generated in the construction of a
839 -- loop, and prepend them to the sequence of assignments to
840 -- complete the eventual body of the loop.
842 ----------------------
843 -- Add_Loop_Actions --
844 ----------------------
846 function Add_Loop_Actions
(Lis
: List_Id
) return List_Id
is
850 -- Ada 2005 (AI-287): Do nothing else in case of default
851 -- initialized component.
856 elsif Nkind
(Parent
(Expr
)) = N_Component_Association
857 and then Present
(Loop_Actions
(Parent
(Expr
)))
859 Append_List
(Lis
, Loop_Actions
(Parent
(Expr
)));
860 Res
:= Loop_Actions
(Parent
(Expr
));
861 Set_Loop_Actions
(Parent
(Expr
), No_List
);
867 end Add_Loop_Actions
;
869 -- Start of processing for Gen_Assign
873 New_Indices
:= New_List
;
875 New_Indices
:= New_Copy_List_Tree
(Indices
);
878 Append_To
(New_Indices
, Ind
);
880 if Present
(Flist
) then
881 F
:= New_Copy_Tree
(Flist
);
883 elsif Present
(Etype
(N
)) and then Controlled_Type
(Etype
(N
)) then
884 if Is_Entity_Name
(Into
)
885 and then Present
(Scope
(Entity
(Into
)))
887 F
:= Find_Final_List
(Scope
(Entity
(Into
)));
889 F
:= Find_Final_List
(Current_Scope
);
895 if Present
(Next_Index
(Index
)) then
898 Build_Array_Aggr_Code
901 Index
=> Next_Index
(Index
),
903 Scalar_Comp
=> Scalar_Comp
,
904 Indices
=> New_Indices
,
908 -- If we get here then we are at a bottom-level (sub-)aggregate
912 (Make_Indexed_Component
(Loc
,
913 Prefix
=> New_Copy_Tree
(Into
),
914 Expressions
=> New_Indices
));
916 Set_Assignment_OK
(Indexed_Comp
);
918 -- Ada 2005 (AI-287): In case of default initialized component, Expr
919 -- is not present (and therefore we also initialize Expr_Q to empty).
923 elsif Nkind
(Expr
) = N_Qualified_Expression
then
924 Expr_Q
:= Expression
(Expr
);
929 if Present
(Etype
(N
))
930 and then Etype
(N
) /= Any_Composite
932 Comp_Type
:= Component_Type
(Etype
(N
));
933 pragma Assert
(Comp_Type
= Ctype
); -- AI-287
935 elsif Present
(Next
(First
(New_Indices
))) then
937 -- Ada 2005 (AI-287): Do nothing in case of default initialized
938 -- component because we have received the component type in
939 -- the formal parameter Ctype.
941 -- ??? Some assert pragmas have been added to check if this new
942 -- formal can be used to replace this code in all cases.
944 if Present
(Expr
) then
946 -- This is a multidimensional array. Recover the component
947 -- type from the outermost aggregate, because subaggregates
948 -- do not have an assigned type.
951 P
: Node_Id
:= Parent
(Expr
);
954 while Present
(P
) loop
955 if Nkind
(P
) = N_Aggregate
956 and then Present
(Etype
(P
))
958 Comp_Type
:= Component_Type
(Etype
(P
));
966 pragma Assert
(Comp_Type
= Ctype
); -- AI-287
971 -- Ada 2005 (AI-287): We only analyze the expression in case of non-
972 -- default initialized components (otherwise Expr_Q is not present).
975 and then (Nkind
(Expr_Q
) = N_Aggregate
976 or else Nkind
(Expr_Q
) = N_Extension_Aggregate
)
978 -- At this stage the Expression may not have been
979 -- analyzed yet because the array aggregate code has not
980 -- been updated to use the Expansion_Delayed flag and
981 -- avoid analysis altogether to solve the same problem
982 -- (see Resolve_Aggr_Expr). So let us do the analysis of
983 -- non-array aggregates now in order to get the value of
984 -- Expansion_Delayed flag for the inner aggregate ???
986 if Present
(Comp_Type
) and then not Is_Array_Type
(Comp_Type
) then
987 Analyze_And_Resolve
(Expr_Q
, Comp_Type
);
990 if Is_Delayed_Aggregate
(Expr_Q
) then
992 -- This is either a subaggregate of a multidimentional array,
993 -- or a component of an array type whose component type is
994 -- also an array. In the latter case, the expression may have
995 -- component associations that provide different bounds from
996 -- those of the component type, and sliding must occur. Instead
997 -- of decomposing the current aggregate assignment, force the
998 -- re-analysis of the assignment, so that a temporary will be
999 -- generated in the usual fashion, and sliding will take place.
1001 if Nkind
(Parent
(N
)) = N_Assignment_Statement
1002 and then Is_Array_Type
(Comp_Type
)
1003 and then Present
(Component_Associations
(Expr_Q
))
1004 and then Must_Slide
(Comp_Type
, Etype
(Expr_Q
))
1006 Set_Expansion_Delayed
(Expr_Q
, False);
1007 Set_Analyzed
(Expr_Q
, False);
1013 Expr_Q
, Etype
(Expr_Q
), Indexed_Comp
, F
));
1018 -- Ada 2005 (AI-287): In case of default initialized component, call
1019 -- the initialization subprogram associated with the component type.
1022 if Present
(Base_Init_Proc
(Etype
(Ctype
)))
1023 or else Has_Task
(Base_Type
(Ctype
))
1026 Build_Initialization_Call
(Loc
,
1027 Id_Ref
=> Indexed_Comp
,
1029 With_Default_Init
=> True));
1033 -- Now generate the assignment with no associated controlled
1034 -- actions since the target of the assignment may not have
1035 -- been initialized, it is not possible to Finalize it as
1036 -- expected by normal controlled assignment. The rest of the
1037 -- controlled actions are done manually with the proper
1038 -- finalization list coming from the context.
1041 Make_OK_Assignment_Statement
(Loc
,
1042 Name
=> Indexed_Comp
,
1043 Expression
=> New_Copy_Tree
(Expr
));
1045 if Present
(Comp_Type
) and then Controlled_Type
(Comp_Type
) then
1046 Set_No_Ctrl_Actions
(A
);
1048 -- If this is an aggregate for an array of arrays, each
1049 -- subaggregate will be expanded as well, and even with
1050 -- No_Ctrl_Actions the assignments of inner components will
1051 -- require attachment in their assignments to temporaries.
1052 -- These temporaries must be finalized for each subaggregate,
1053 -- to prevent multiple attachments of the same temporary
1054 -- location to same finalization chain (and consequently
1055 -- circular lists). To ensure that finalization takes place
1056 -- for each subaggregate we wrap the assignment in a block.
1058 if Is_Array_Type
(Comp_Type
)
1059 and then Nkind
(Expr
) = N_Aggregate
1062 Make_Block_Statement
(Loc
,
1063 Handled_Statement_Sequence
=>
1064 Make_Handled_Sequence_Of_Statements
(Loc
,
1065 Statements
=> New_List
(A
)));
1071 -- Adjust the tag if tagged (because of possible view
1072 -- conversions), unless compiling for the Java VM
1073 -- where tags are implicit.
1075 if Present
(Comp_Type
)
1076 and then Is_Tagged_Type
(Comp_Type
)
1077 and then not Java_VM
1080 Make_OK_Assignment_Statement
(Loc
,
1082 Make_Selected_Component
(Loc
,
1083 Prefix
=> New_Copy_Tree
(Indexed_Comp
),
1086 (First_Tag_Component
(Comp_Type
), Loc
)),
1089 Unchecked_Convert_To
(RTE
(RE_Tag
),
1091 (Node
(First_Elmt
(Access_Disp_Table
(Comp_Type
))),
1097 -- Adjust and Attach the component to the proper final list
1098 -- which can be the controller of the outer record object or
1099 -- the final list associated with the scope
1101 if Present
(Comp_Type
) and then Controlled_Type
(Comp_Type
) then
1104 Ref
=> New_Copy_Tree
(Indexed_Comp
),
1107 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1111 return Add_Loop_Actions
(L
);
1118 function Gen_Loop
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
is
1122 -- Index_Base'(L) .. Index_Base'(H)
1124 L_Iteration_Scheme
: Node_Id
;
1125 -- L_J in Index_Base'(L) .. Index_Base'(H)
1128 -- The statements to execute in the loop
1130 S
: constant List_Id
:= New_List
;
1131 -- List of statements
1134 -- Copy of expression tree, used for checking purposes
1137 -- If loop bounds define an empty range return the null statement
1139 if Empty_Range
(L
, H
) then
1140 Append_To
(S
, Make_Null_Statement
(Loc
));
1142 -- Ada 2005 (AI-287): Nothing else need to be done in case of
1143 -- default initialized component.
1149 -- The expression must be type-checked even though no component
1150 -- of the aggregate will have this value. This is done only for
1151 -- actual components of the array, not for subaggregates. Do
1152 -- the check on a copy, because the expression may be shared
1153 -- among several choices, some of which might be non-null.
1155 if Present
(Etype
(N
))
1156 and then Is_Array_Type
(Etype
(N
))
1157 and then No
(Next_Index
(Index
))
1159 Expander_Mode_Save_And_Set
(False);
1160 Tcopy
:= New_Copy_Tree
(Expr
);
1161 Set_Parent
(Tcopy
, N
);
1162 Analyze_And_Resolve
(Tcopy
, Component_Type
(Etype
(N
)));
1163 Expander_Mode_Restore
;
1169 -- If loop bounds are the same then generate an assignment
1171 elsif Equal
(L
, H
) then
1172 return Gen_Assign
(New_Copy_Tree
(L
), Expr
);
1174 -- If H - L <= 2 then generate a sequence of assignments
1175 -- when we are processing the bottom most aggregate and it contains
1176 -- scalar components.
1178 elsif No
(Next_Index
(Index
))
1179 and then Scalar_Comp
1180 and then Local_Compile_Time_Known_Value
(L
)
1181 and then Local_Compile_Time_Known_Value
(H
)
1182 and then Local_Expr_Value
(H
) - Local_Expr_Value
(L
) <= 2
1185 Append_List_To
(S
, Gen_Assign
(New_Copy_Tree
(L
), Expr
));
1186 Append_List_To
(S
, Gen_Assign
(Add
(1, To
=> L
), Expr
));
1188 if Local_Expr_Value
(H
) - Local_Expr_Value
(L
) = 2 then
1189 Append_List_To
(S
, Gen_Assign
(Add
(2, To
=> L
), Expr
));
1195 -- Otherwise construct the loop, starting with the loop index L_J
1197 L_J
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
1199 -- Construct "L .. H"
1204 Low_Bound
=> Make_Qualified_Expression
1206 Subtype_Mark
=> Index_Base_Name
,
1208 High_Bound
=> Make_Qualified_Expression
1210 Subtype_Mark
=> Index_Base_Name
,
1213 -- Construct "for L_J in Index_Base range L .. H"
1215 L_Iteration_Scheme
:=
1216 Make_Iteration_Scheme
1218 Loop_Parameter_Specification
=>
1219 Make_Loop_Parameter_Specification
1221 Defining_Identifier
=> L_J
,
1222 Discrete_Subtype_Definition
=> L_Range
));
1224 -- Construct the statements to execute in the loop body
1226 L_Body
:= Gen_Assign
(New_Reference_To
(L_J
, Loc
), Expr
);
1228 -- Construct the final loop
1230 Append_To
(S
, Make_Implicit_Loop_Statement
1232 Identifier
=> Empty
,
1233 Iteration_Scheme
=> L_Iteration_Scheme
,
1234 Statements
=> L_Body
));
1243 -- The code built is
1245 -- W_J : Index_Base := L;
1246 -- while W_J < H loop
1247 -- W_J := Index_Base'Succ (W);
1251 function Gen_While
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
is
1255 -- W_J : Base_Type := L;
1257 W_Iteration_Scheme
: Node_Id
;
1260 W_Index_Succ
: Node_Id
;
1261 -- Index_Base'Succ (J)
1263 W_Increment
: Node_Id
;
1264 -- W_J := Index_Base'Succ (W)
1266 W_Body
: constant List_Id
:= New_List
;
1267 -- The statements to execute in the loop
1269 S
: constant List_Id
:= New_List
;
1270 -- list of statement
1273 -- If loop bounds define an empty range or are equal return null
1275 if Empty_Range
(L
, H
) or else Equal
(L
, H
) then
1276 Append_To
(S
, Make_Null_Statement
(Loc
));
1280 -- Build the decl of W_J
1282 W_J
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
1284 Make_Object_Declaration
1286 Defining_Identifier
=> W_J
,
1287 Object_Definition
=> Index_Base_Name
,
1290 -- Theoretically we should do a New_Copy_Tree (L) here, but we know
1291 -- that in this particular case L is a fresh Expr generated by
1292 -- Add which we are the only ones to use.
1294 Append_To
(S
, W_Decl
);
1296 -- Construct " while W_J < H"
1298 W_Iteration_Scheme
:=
1299 Make_Iteration_Scheme
1301 Condition
=> Make_Op_Lt
1303 Left_Opnd
=> New_Reference_To
(W_J
, Loc
),
1304 Right_Opnd
=> New_Copy_Tree
(H
)));
1306 -- Construct the statements to execute in the loop body
1309 Make_Attribute_Reference
1311 Prefix
=> Index_Base_Name
,
1312 Attribute_Name
=> Name_Succ
,
1313 Expressions
=> New_List
(New_Reference_To
(W_J
, Loc
)));
1316 Make_OK_Assignment_Statement
1318 Name
=> New_Reference_To
(W_J
, Loc
),
1319 Expression
=> W_Index_Succ
);
1321 Append_To
(W_Body
, W_Increment
);
1322 Append_List_To
(W_Body
,
1323 Gen_Assign
(New_Reference_To
(W_J
, Loc
), Expr
));
1325 -- Construct the final loop
1327 Append_To
(S
, Make_Implicit_Loop_Statement
1329 Identifier
=> Empty
,
1330 Iteration_Scheme
=> W_Iteration_Scheme
,
1331 Statements
=> W_Body
));
1336 ---------------------
1337 -- Index_Base_Name --
1338 ---------------------
1340 function Index_Base_Name
return Node_Id
is
1342 return New_Reference_To
(Index_Base
, Sloc
(N
));
1343 end Index_Base_Name
;
1345 ------------------------------------
1346 -- Local_Compile_Time_Known_Value --
1347 ------------------------------------
1349 function Local_Compile_Time_Known_Value
(E
: Node_Id
) return Boolean is
1351 return Compile_Time_Known_Value
(E
)
1353 (Nkind
(E
) = N_Attribute_Reference
1354 and then Attribute_Name
(E
) = Name_Val
1355 and then Compile_Time_Known_Value
(First
(Expressions
(E
))));
1356 end Local_Compile_Time_Known_Value
;
1358 ----------------------
1359 -- Local_Expr_Value --
1360 ----------------------
1362 function Local_Expr_Value
(E
: Node_Id
) return Uint
is
1364 if Compile_Time_Known_Value
(E
) then
1365 return Expr_Value
(E
);
1367 return Expr_Value
(First
(Expressions
(E
)));
1369 end Local_Expr_Value
;
1371 -- Build_Array_Aggr_Code Variables
1378 Others_Expr
: Node_Id
:= Empty
;
1379 Others_Box_Present
: Boolean := False;
1381 Aggr_L
: constant Node_Id
:= Low_Bound
(Aggregate_Bounds
(N
));
1382 Aggr_H
: constant Node_Id
:= High_Bound
(Aggregate_Bounds
(N
));
1383 -- The aggregate bounds of this specific sub-aggregate. Note that if
1384 -- the code generated by Build_Array_Aggr_Code is executed then these
1385 -- bounds are OK. Otherwise a Constraint_Error would have been raised.
1387 Aggr_Low
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Aggr_L
);
1388 Aggr_High
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Aggr_H
);
1389 -- After Duplicate_Subexpr these are side-effect free
1394 Nb_Choices
: Nat
:= 0;
1395 Table
: Case_Table_Type
(1 .. Number_Of_Choices
(N
));
1396 -- Used to sort all the different choice values
1399 -- Number of elements in the positional aggregate
1401 New_Code
: constant List_Id
:= New_List
;
1403 -- Start of processing for Build_Array_Aggr_Code
1406 -- First before we start, a special case. if we have a bit packed
1407 -- array represented as a modular type, then clear the value to
1408 -- zero first, to ensure that unused bits are properly cleared.
1413 and then Is_Bit_Packed_Array
(Typ
)
1414 and then Is_Modular_Integer_Type
(Packed_Array_Type
(Typ
))
1416 Append_To
(New_Code
,
1417 Make_Assignment_Statement
(Loc
,
1418 Name
=> New_Copy_Tree
(Into
),
1420 Unchecked_Convert_To
(Typ
,
1421 Make_Integer_Literal
(Loc
, Uint_0
))));
1425 -- STEP 1: Process component associations
1426 -- For those associations that may generate a loop, initialize
1427 -- Loop_Actions to collect inserted actions that may be crated.
1429 if No
(Expressions
(N
)) then
1431 -- STEP 1 (a): Sort the discrete choices
1433 Assoc
:= First
(Component_Associations
(N
));
1434 while Present
(Assoc
) loop
1435 Choice
:= First
(Choices
(Assoc
));
1436 while Present
(Choice
) loop
1437 if Nkind
(Choice
) = N_Others_Choice
then
1438 Set_Loop_Actions
(Assoc
, New_List
);
1440 if Box_Present
(Assoc
) then
1441 Others_Box_Present
:= True;
1443 Others_Expr
:= Expression
(Assoc
);
1448 Get_Index_Bounds
(Choice
, Low
, High
);
1451 Set_Loop_Actions
(Assoc
, New_List
);
1454 Nb_Choices
:= Nb_Choices
+ 1;
1455 if Box_Present
(Assoc
) then
1456 Table
(Nb_Choices
) := (Choice_Lo
=> Low
,
1458 Choice_Node
=> Empty
);
1460 Table
(Nb_Choices
) := (Choice_Lo
=> Low
,
1462 Choice_Node
=> Expression
(Assoc
));
1470 -- If there is more than one set of choices these must be static
1471 -- and we can therefore sort them. Remember that Nb_Choices does not
1472 -- account for an others choice.
1474 if Nb_Choices
> 1 then
1475 Sort_Case_Table
(Table
);
1478 -- STEP 1 (b): take care of the whole set of discrete choices
1480 for J
in 1 .. Nb_Choices
loop
1481 Low
:= Table
(J
).Choice_Lo
;
1482 High
:= Table
(J
).Choice_Hi
;
1483 Expr
:= Table
(J
).Choice_Node
;
1484 Append_List
(Gen_Loop
(Low
, High
, Expr
), To
=> New_Code
);
1487 -- STEP 1 (c): generate the remaining loops to cover others choice
1488 -- We don't need to generate loops over empty gaps, but if there is
1489 -- a single empty range we must analyze the expression for semantics
1491 if Present
(Others_Expr
) or else Others_Box_Present
then
1493 First
: Boolean := True;
1496 for J
in 0 .. Nb_Choices
loop
1500 Low
:= Add
(1, To
=> Table
(J
).Choice_Hi
);
1503 if J
= Nb_Choices
then
1506 High
:= Add
(-1, To
=> Table
(J
+ 1).Choice_Lo
);
1509 -- If this is an expansion within an init proc, make
1510 -- sure that discriminant references are replaced by
1511 -- the corresponding discriminal.
1513 if Inside_Init_Proc
then
1514 if Is_Entity_Name
(Low
)
1515 and then Ekind
(Entity
(Low
)) = E_Discriminant
1517 Set_Entity
(Low
, Discriminal
(Entity
(Low
)));
1520 if Is_Entity_Name
(High
)
1521 and then Ekind
(Entity
(High
)) = E_Discriminant
1523 Set_Entity
(High
, Discriminal
(Entity
(High
)));
1528 or else not Empty_Range
(Low
, High
)
1532 (Gen_Loop
(Low
, High
, Others_Expr
), To
=> New_Code
);
1538 -- STEP 2: Process positional components
1541 -- STEP 2 (a): Generate the assignments for each positional element
1542 -- Note that here we have to use Aggr_L rather than Aggr_Low because
1543 -- Aggr_L is analyzed and Add wants an analyzed expression.
1545 Expr
:= First
(Expressions
(N
));
1548 while Present
(Expr
) loop
1549 Nb_Elements
:= Nb_Elements
+ 1;
1550 Append_List
(Gen_Assign
(Add
(Nb_Elements
, To
=> Aggr_L
), Expr
),
1555 -- STEP 2 (b): Generate final loop if an others choice is present
1556 -- Here Nb_Elements gives the offset of the last positional element.
1558 if Present
(Component_Associations
(N
)) then
1559 Assoc
:= Last
(Component_Associations
(N
));
1561 -- Ada 2005 (AI-287)
1563 if Box_Present
(Assoc
) then
1564 Append_List
(Gen_While
(Add
(Nb_Elements
, To
=> Aggr_L
),
1569 Expr
:= Expression
(Assoc
);
1571 Append_List
(Gen_While
(Add
(Nb_Elements
, To
=> Aggr_L
),
1580 end Build_Array_Aggr_Code
;
1582 ----------------------------
1583 -- Build_Record_Aggr_Code --
1584 ----------------------------
1586 function Build_Record_Aggr_Code
1590 Flist
: Node_Id
:= Empty
;
1591 Obj
: Entity_Id
:= Empty
;
1592 Is_Limited_Ancestor_Expansion
: Boolean := False) return List_Id
1594 Loc
: constant Source_Ptr
:= Sloc
(N
);
1595 L
: constant List_Id
:= New_List
;
1596 N_Typ
: constant Entity_Id
:= Etype
(N
);
1602 Comp_Type
: Entity_Id
;
1603 Selector
: Entity_Id
;
1604 Comp_Expr
: Node_Id
;
1607 Internal_Final_List
: Node_Id
;
1609 -- If this is an internal aggregate, the External_Final_List is an
1610 -- expression for the controller record of the enclosing type.
1611 -- If the current aggregate has several controlled components, this
1612 -- expression will appear in several calls to attach to the finali-
1613 -- zation list, and it must not be shared.
1615 External_Final_List
: Node_Id
;
1616 Ancestor_Is_Expression
: Boolean := False;
1617 Ancestor_Is_Subtype_Mark
: Boolean := False;
1619 Init_Typ
: Entity_Id
:= Empty
;
1621 Ctrl_Stuff_Done
: Boolean := False;
1623 function Ancestor_Discriminant_Value
(Disc
: Entity_Id
) return Node_Id
;
1624 -- Returns the value that the given discriminant of an ancestor
1625 -- type should receive (in the absence of a conflict with the
1626 -- value provided by an ancestor part of an extension aggregate).
1628 procedure Check_Ancestor_Discriminants
(Anc_Typ
: Entity_Id
);
1629 -- Check that each of the discriminant values defined by the
1630 -- ancestor part of an extension aggregate match the corresponding
1631 -- values provided by either an association of the aggregate or
1632 -- by the constraint imposed by a parent type (RM95-4.3.2(8)).
1634 function Compatible_Int_Bounds
1635 (Agg_Bounds
: Node_Id
;
1636 Typ_Bounds
: Node_Id
) return Boolean;
1637 -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is
1638 -- assumed that both bounds are integer ranges.
1640 procedure Gen_Ctrl_Actions_For_Aggr
;
1641 -- Deal with the various controlled type data structure
1644 function Get_Constraint_Association
(T
: Entity_Id
) return Node_Id
;
1645 -- Returns the first discriminant association in the constraint
1646 -- associated with T, if any, otherwise returns Empty.
1648 function Init_Controller
1653 Init_Pr
: Boolean) return List_Id
;
1654 -- returns the list of statements necessary to initialize the internal
1655 -- controller of the (possible) ancestor typ into target and attach
1656 -- it to finalization list F. Init_Pr conditions the call to the
1657 -- init proc since it may already be done due to ancestor initialization
1659 function Is_Int_Range_Bounds
(Bounds
: Node_Id
) return Boolean;
1660 -- Check whether Bounds is a range node and its lower and higher bounds
1661 -- are integers literals.
1663 ---------------------------------
1664 -- Ancestor_Discriminant_Value --
1665 ---------------------------------
1667 function Ancestor_Discriminant_Value
(Disc
: Entity_Id
) return Node_Id
is
1669 Assoc_Elmt
: Elmt_Id
;
1670 Aggr_Comp
: Entity_Id
;
1671 Corresp_Disc
: Entity_Id
;
1672 Current_Typ
: Entity_Id
:= Base_Type
(Typ
);
1673 Parent_Typ
: Entity_Id
;
1674 Parent_Disc
: Entity_Id
;
1675 Save_Assoc
: Node_Id
:= Empty
;
1678 -- First check any discriminant associations to see if
1679 -- any of them provide a value for the discriminant.
1681 if Present
(Discriminant_Specifications
(Parent
(Current_Typ
))) then
1682 Assoc
:= First
(Component_Associations
(N
));
1683 while Present
(Assoc
) loop
1684 Aggr_Comp
:= Entity
(First
(Choices
(Assoc
)));
1686 if Ekind
(Aggr_Comp
) = E_Discriminant
then
1687 Save_Assoc
:= Expression
(Assoc
);
1689 Corresp_Disc
:= Corresponding_Discriminant
(Aggr_Comp
);
1690 while Present
(Corresp_Disc
) loop
1691 -- If found a corresponding discriminant then return
1692 -- the value given in the aggregate. (Note: this is
1693 -- not correct in the presence of side effects. ???)
1695 if Disc
= Corresp_Disc
then
1696 return Duplicate_Subexpr
(Expression
(Assoc
));
1700 Corresponding_Discriminant
(Corresp_Disc
);
1708 -- No match found in aggregate, so chain up parent types to find
1709 -- a constraint that defines the value of the discriminant.
1711 Parent_Typ
:= Etype
(Current_Typ
);
1712 while Current_Typ
/= Parent_Typ
loop
1713 if Has_Discriminants
(Parent_Typ
) then
1714 Parent_Disc
:= First_Discriminant
(Parent_Typ
);
1716 -- We either get the association from the subtype indication
1717 -- of the type definition itself, or from the discriminant
1718 -- constraint associated with the type entity (which is
1719 -- preferable, but it's not always present ???)
1721 if Is_Empty_Elmt_List
(
1722 Discriminant_Constraint
(Current_Typ
))
1724 Assoc
:= Get_Constraint_Association
(Current_Typ
);
1725 Assoc_Elmt
:= No_Elmt
;
1728 First_Elmt
(Discriminant_Constraint
(Current_Typ
));
1729 Assoc
:= Node
(Assoc_Elmt
);
1732 -- Traverse the discriminants of the parent type looking
1733 -- for one that corresponds.
1735 while Present
(Parent_Disc
) and then Present
(Assoc
) loop
1736 Corresp_Disc
:= Parent_Disc
;
1737 while Present
(Corresp_Disc
)
1738 and then Disc
/= Corresp_Disc
1741 Corresponding_Discriminant
(Corresp_Disc
);
1744 if Disc
= Corresp_Disc
then
1745 if Nkind
(Assoc
) = N_Discriminant_Association
then
1746 Assoc
:= Expression
(Assoc
);
1749 -- If the located association directly denotes
1750 -- a discriminant, then use the value of a saved
1751 -- association of the aggregate. This is a kludge
1752 -- to handle certain cases involving multiple
1753 -- discriminants mapped to a single discriminant
1754 -- of a descendant. It's not clear how to locate the
1755 -- appropriate discriminant value for such cases. ???
1757 if Is_Entity_Name
(Assoc
)
1758 and then Ekind
(Entity
(Assoc
)) = E_Discriminant
1760 Assoc
:= Save_Assoc
;
1763 return Duplicate_Subexpr
(Assoc
);
1766 Next_Discriminant
(Parent_Disc
);
1768 if No
(Assoc_Elmt
) then
1771 Next_Elmt
(Assoc_Elmt
);
1772 if Present
(Assoc_Elmt
) then
1773 Assoc
:= Node
(Assoc_Elmt
);
1781 Current_Typ
:= Parent_Typ
;
1782 Parent_Typ
:= Etype
(Current_Typ
);
1785 -- In some cases there's no ancestor value to locate (such as
1786 -- when an ancestor part given by an expression defines the
1787 -- discriminant value).
1790 end Ancestor_Discriminant_Value
;
1792 ----------------------------------
1793 -- Check_Ancestor_Discriminants --
1794 ----------------------------------
1796 procedure Check_Ancestor_Discriminants
(Anc_Typ
: Entity_Id
) is
1797 Discr
: Entity_Id
:= First_Discriminant
(Base_Type
(Anc_Typ
));
1798 Disc_Value
: Node_Id
;
1802 while Present
(Discr
) loop
1803 Disc_Value
:= Ancestor_Discriminant_Value
(Discr
);
1805 if Present
(Disc_Value
) then
1806 Cond
:= Make_Op_Ne
(Loc
,
1808 Make_Selected_Component
(Loc
,
1809 Prefix
=> New_Copy_Tree
(Target
),
1810 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)),
1811 Right_Opnd
=> Disc_Value
);
1814 Make_Raise_Constraint_Error
(Loc
,
1816 Reason
=> CE_Discriminant_Check_Failed
));
1819 Next_Discriminant
(Discr
);
1821 end Check_Ancestor_Discriminants
;
1823 ---------------------------
1824 -- Compatible_Int_Bounds --
1825 ---------------------------
1827 function Compatible_Int_Bounds
1828 (Agg_Bounds
: Node_Id
;
1829 Typ_Bounds
: Node_Id
) return Boolean
1831 Agg_Lo
: constant Uint
:= Intval
(Low_Bound
(Agg_Bounds
));
1832 Agg_Hi
: constant Uint
:= Intval
(High_Bound
(Agg_Bounds
));
1833 Typ_Lo
: constant Uint
:= Intval
(Low_Bound
(Typ_Bounds
));
1834 Typ_Hi
: constant Uint
:= Intval
(High_Bound
(Typ_Bounds
));
1836 return Typ_Lo
<= Agg_Lo
and then Agg_Hi
<= Typ_Hi
;
1837 end Compatible_Int_Bounds
;
1839 --------------------------------
1840 -- Get_Constraint_Association --
1841 --------------------------------
1843 function Get_Constraint_Association
(T
: Entity_Id
) return Node_Id
is
1844 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(T
));
1845 Indic
: constant Node_Id
:= Subtype_Indication
(Typ_Def
);
1848 -- ??? Also need to cover case of a type mark denoting a subtype
1851 if Nkind
(Indic
) = N_Subtype_Indication
1852 and then Present
(Constraint
(Indic
))
1854 return First
(Constraints
(Constraint
(Indic
)));
1858 end Get_Constraint_Association
;
1860 ---------------------
1861 -- Init_controller --
1862 ---------------------
1864 function Init_Controller
1869 Init_Pr
: Boolean) return List_Id
1871 L
: constant List_Id
:= New_List
;
1877 -- init-proc (target._controller);
1878 -- initialize (target._controller);
1879 -- Attach_to_Final_List (target._controller, F);
1882 Make_Selected_Component
(Loc
,
1883 Prefix
=> Convert_To
(Typ
, New_Copy_Tree
(Target
)),
1884 Selector_Name
=> Make_Identifier
(Loc
, Name_uController
));
1885 Set_Assignment_OK
(Ref
);
1887 -- Ada 2005 (AI-287): Give support to default initialization of
1888 -- limited types and components.
1890 if (Nkind
(Target
) = N_Identifier
1891 and then Present
(Etype
(Target
))
1892 and then Is_Limited_Type
(Etype
(Target
)))
1894 (Nkind
(Target
) = N_Selected_Component
1895 and then Present
(Etype
(Selector_Name
(Target
)))
1896 and then Is_Limited_Type
(Etype
(Selector_Name
(Target
))))
1898 (Nkind
(Target
) = N_Unchecked_Type_Conversion
1899 and then Present
(Etype
(Target
))
1900 and then Is_Limited_Type
(Etype
(Target
)))
1902 (Nkind
(Target
) = N_Unchecked_Expression
1903 and then Nkind
(Expression
(Target
)) = N_Indexed_Component
1904 and then Present
(Etype
(Prefix
(Expression
(Target
))))
1905 and then Is_Limited_Type
(Etype
(Prefix
(Expression
(Target
)))))
1907 RC
:= RE_Limited_Record_Controller
;
1909 RC
:= RE_Record_Controller
;
1914 Build_Initialization_Call
(Loc
,
1917 In_Init_Proc
=> Within_Init_Proc
));
1921 Make_Procedure_Call_Statement
(Loc
,
1924 Find_Prim_Op
(RTE
(RC
), Name_Initialize
), Loc
),
1925 Parameter_Associations
=>
1926 New_List
(New_Copy_Tree
(Ref
))));
1930 Obj_Ref
=> New_Copy_Tree
(Ref
),
1932 With_Attach
=> Attach
));
1935 end Init_Controller
;
1937 -------------------------
1938 -- Is_Int_Range_Bounds --
1939 -------------------------
1941 function Is_Int_Range_Bounds
(Bounds
: Node_Id
) return Boolean is
1943 return Nkind
(Bounds
) = N_Range
1944 and then Nkind
(Low_Bound
(Bounds
)) = N_Integer_Literal
1945 and then Nkind
(High_Bound
(Bounds
)) = N_Integer_Literal
;
1946 end Is_Int_Range_Bounds
;
1948 -------------------------------
1949 -- Gen_Ctrl_Actions_For_Aggr --
1950 -------------------------------
1952 procedure Gen_Ctrl_Actions_For_Aggr
is
1955 and then Finalize_Storage_Only
(Typ
)
1956 and then (Is_Library_Level_Entity
(Obj
)
1957 or else Entity
(Constant_Value
(RTE
(RE_Garbage_Collected
))) =
1960 Attach
:= Make_Integer_Literal
(Loc
, 0);
1962 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
1963 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
1965 Attach
:= Make_Integer_Literal
(Loc
, 2);
1968 Attach
:= Make_Integer_Literal
(Loc
, 1);
1971 -- Determine the external finalization list. It is either the
1972 -- finalization list of the outer-scope or the one coming from
1973 -- an outer aggregate. When the target is not a temporary, the
1974 -- proper scope is the scope of the target rather than the
1975 -- potentially transient current scope.
1977 if Controlled_Type
(Typ
) then
1978 if Present
(Flist
) then
1979 External_Final_List
:= New_Copy_Tree
(Flist
);
1981 elsif Is_Entity_Name
(Target
)
1982 and then Present
(Scope
(Entity
(Target
)))
1985 := Find_Final_List
(Scope
(Entity
(Target
)));
1988 External_Final_List
:= Find_Final_List
(Current_Scope
);
1992 External_Final_List
:= Empty
;
1995 -- Initialize and attach the outer object in the is_controlled case
1997 if Is_Controlled
(Typ
) then
1998 if Ancestor_Is_Subtype_Mark
then
1999 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2000 Set_Assignment_OK
(Ref
);
2002 Make_Procedure_Call_Statement
(Loc
,
2005 (Find_Prim_Op
(Init_Typ
, Name_Initialize
), Loc
),
2006 Parameter_Associations
=> New_List
(New_Copy_Tree
(Ref
))));
2009 if not Has_Controlled_Component
(Typ
) then
2010 Ref
:= New_Copy_Tree
(Target
);
2011 Set_Assignment_OK
(Ref
);
2015 Flist_Ref
=> New_Copy_Tree
(External_Final_List
),
2016 With_Attach
=> Attach
));
2020 -- In the Has_Controlled component case, all the intermediate
2021 -- controllers must be initialized
2023 if Has_Controlled_Component
(Typ
)
2024 and not Is_Limited_Ancestor_Expansion
2027 Inner_Typ
: Entity_Id
;
2028 Outer_Typ
: Entity_Id
;
2033 Outer_Typ
:= Base_Type
(Typ
);
2035 -- Find outer type with a controller
2037 while Outer_Typ
/= Init_Typ
2038 and then not Has_New_Controlled_Component
(Outer_Typ
)
2040 Outer_Typ
:= Etype
(Outer_Typ
);
2043 -- Attach it to the outer record controller to the
2044 -- external final list
2046 if Outer_Typ
= Init_Typ
then
2051 F
=> External_Final_List
,
2056 Inner_Typ
:= Init_Typ
;
2063 F
=> External_Final_List
,
2067 Inner_Typ
:= Etype
(Outer_Typ
);
2069 not Is_Tagged_Type
(Typ
) or else Inner_Typ
= Outer_Typ
;
2072 -- The outer object has to be attached as well
2074 if Is_Controlled
(Typ
) then
2075 Ref
:= New_Copy_Tree
(Target
);
2076 Set_Assignment_OK
(Ref
);
2080 Flist_Ref
=> New_Copy_Tree
(External_Final_List
),
2081 With_Attach
=> New_Copy_Tree
(Attach
)));
2084 -- Initialize the internal controllers for tagged types with
2085 -- more than one controller.
2087 while not At_Root
and then Inner_Typ
/= Init_Typ
loop
2088 if Has_New_Controlled_Component
(Inner_Typ
) then
2090 Make_Selected_Component
(Loc
,
2092 Convert_To
(Outer_Typ
, New_Copy_Tree
(Target
)),
2094 Make_Identifier
(Loc
, Name_uController
));
2096 Make_Selected_Component
(Loc
,
2098 Selector_Name
=> Make_Identifier
(Loc
, Name_F
));
2105 Attach
=> Make_Integer_Literal
(Loc
, 1),
2107 Outer_Typ
:= Inner_Typ
;
2112 At_Root
:= Inner_Typ
= Etype
(Inner_Typ
);
2113 Inner_Typ
:= Etype
(Inner_Typ
);
2116 -- If not done yet attach the controller of the ancestor part
2118 if Outer_Typ
/= Init_Typ
2119 and then Inner_Typ
= Init_Typ
2120 and then Has_Controlled_Component
(Init_Typ
)
2123 Make_Selected_Component
(Loc
,
2124 Prefix
=> Convert_To
(Outer_Typ
, New_Copy_Tree
(Target
)),
2126 Make_Identifier
(Loc
, Name_uController
));
2128 Make_Selected_Component
(Loc
,
2130 Selector_Name
=> Make_Identifier
(Loc
, Name_F
));
2132 Attach
:= Make_Integer_Literal
(Loc
, 1);
2139 Init_Pr
=> Ancestor_Is_Expression
));
2143 end Gen_Ctrl_Actions_For_Aggr
;
2145 -- Start of processing for Build_Record_Aggr_Code
2148 -- Deal with the ancestor part of extension aggregates
2149 -- or with the discriminants of the root type
2151 if Nkind
(N
) = N_Extension_Aggregate
then
2153 A
: constant Node_Id
:= Ancestor_Part
(N
);
2157 -- If the ancestor part is a subtype mark "T", we generate
2159 -- init-proc (T(tmp)); if T is constrained and
2160 -- init-proc (S(tmp)); where S applies an appropriate
2161 -- constraint if T is unconstrained
2163 if Is_Entity_Name
(A
) and then Is_Type
(Entity
(A
)) then
2164 Ancestor_Is_Subtype_Mark
:= True;
2166 if Is_Constrained
(Entity
(A
)) then
2167 Init_Typ
:= Entity
(A
);
2169 -- For an ancestor part given by an unconstrained type
2170 -- mark, create a subtype constrained by appropriate
2171 -- corresponding discriminant values coming from either
2172 -- associations of the aggregate or a constraint on
2173 -- a parent type. The subtype will be used to generate
2174 -- the correct default value for the ancestor part.
2176 elsif Has_Discriminants
(Entity
(A
)) then
2178 Anc_Typ
: constant Entity_Id
:= Entity
(A
);
2179 Anc_Constr
: constant List_Id
:= New_List
;
2180 Discrim
: Entity_Id
;
2181 Disc_Value
: Node_Id
;
2182 New_Indic
: Node_Id
;
2183 Subt_Decl
: Node_Id
;
2186 Discrim
:= First_Discriminant
(Anc_Typ
);
2187 while Present
(Discrim
) loop
2188 Disc_Value
:= Ancestor_Discriminant_Value
(Discrim
);
2189 Append_To
(Anc_Constr
, Disc_Value
);
2190 Next_Discriminant
(Discrim
);
2194 Make_Subtype_Indication
(Loc
,
2195 Subtype_Mark
=> New_Occurrence_Of
(Anc_Typ
, Loc
),
2197 Make_Index_Or_Discriminant_Constraint
(Loc
,
2198 Constraints
=> Anc_Constr
));
2200 Init_Typ
:= Create_Itype
(Ekind
(Anc_Typ
), N
);
2203 Make_Subtype_Declaration
(Loc
,
2204 Defining_Identifier
=> Init_Typ
,
2205 Subtype_Indication
=> New_Indic
);
2207 -- Itypes must be analyzed with checks off
2208 -- Declaration must have a parent for proper
2209 -- handling of subsidiary actions.
2211 Set_Parent
(Subt_Decl
, N
);
2212 Analyze
(Subt_Decl
, Suppress
=> All_Checks
);
2216 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2217 Set_Assignment_OK
(Ref
);
2219 if Has_Default_Init_Comps
(N
)
2220 or else Has_Task
(Base_Type
(Init_Typ
))
2223 Build_Initialization_Call
(Loc
,
2226 In_Init_Proc
=> Within_Init_Proc
,
2227 With_Default_Init
=> True));
2230 Build_Initialization_Call
(Loc
,
2233 In_Init_Proc
=> Within_Init_Proc
));
2236 if Is_Constrained
(Entity
(A
))
2237 and then Has_Discriminants
(Entity
(A
))
2239 Check_Ancestor_Discriminants
(Entity
(A
));
2242 -- Ada 2005 (AI-287): If the ancestor part is a limited type,
2243 -- a recursive call expands the ancestor.
2245 elsif Is_Limited_Type
(Etype
(A
)) then
2246 Ancestor_Is_Expression
:= True;
2249 Build_Record_Aggr_Code
(
2250 N
=> Expression
(A
),
2251 Typ
=> Etype
(Expression
(A
)),
2255 Is_Limited_Ancestor_Expansion
=> True));
2257 -- If the ancestor part is an expression "E", we generate
2261 Ancestor_Is_Expression
:= True;
2262 Init_Typ
:= Etype
(A
);
2264 -- If the ancestor part is an aggregate, force its full
2265 -- expansion, which was delayed.
2267 if Nkind
(A
) = N_Qualified_Expression
2268 and then (Nkind
(Expression
(A
)) = N_Aggregate
2270 Nkind
(Expression
(A
)) = N_Extension_Aggregate
)
2272 Set_Analyzed
(A
, False);
2273 Set_Analyzed
(Expression
(A
), False);
2276 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2277 Set_Assignment_OK
(Ref
);
2279 -- Make the assignment without usual controlled actions since
2280 -- we only want the post adjust but not the pre finalize here
2281 -- Add manual adjust when necessary
2283 Assign
:= New_List
(
2284 Make_OK_Assignment_Statement
(Loc
,
2287 Set_No_Ctrl_Actions
(First
(Assign
));
2289 -- Assign the tag now to make sure that the dispatching call in
2290 -- the subsequent deep_adjust works properly (unless Java_VM,
2291 -- where tags are implicit).
2295 Make_OK_Assignment_Statement
(Loc
,
2297 Make_Selected_Component
(Loc
,
2298 Prefix
=> New_Copy_Tree
(Target
),
2301 (First_Tag_Component
(Base_Type
(Typ
)), Loc
)),
2304 Unchecked_Convert_To
(RTE
(RE_Tag
),
2307 (Access_Disp_Table
(Base_Type
(Typ
)))),
2310 Set_Assignment_OK
(Name
(Instr
));
2311 Append_To
(Assign
, Instr
);
2314 -- Call Adjust manually
2316 if Controlled_Type
(Etype
(A
)) then
2317 Append_List_To
(Assign
,
2319 Ref
=> New_Copy_Tree
(Ref
),
2321 Flist_Ref
=> New_Reference_To
(
2322 RTE
(RE_Global_Final_List
), Loc
),
2323 With_Attach
=> Make_Integer_Literal
(Loc
, 0)));
2327 Make_Unsuppress_Block
(Loc
, Name_Discriminant_Check
, Assign
));
2329 if Has_Discriminants
(Init_Typ
) then
2330 Check_Ancestor_Discriminants
(Init_Typ
);
2335 -- Normal case (not an extension aggregate)
2338 -- Generate the discriminant expressions, component by component.
2339 -- If the base type is an unchecked union, the discriminants are
2340 -- unknown to the back-end and absent from a value of the type, so
2341 -- assignments for them are not emitted.
2343 if Has_Discriminants
(Typ
)
2344 and then not Is_Unchecked_Union
(Base_Type
(Typ
))
2346 -- If the type is derived, and constrains discriminants of the
2347 -- parent type, these discriminants are not components of the
2348 -- aggregate, and must be initialized explicitly. They are not
2349 -- visible components of the object, but can become visible with
2350 -- a view conversion to the ancestor.
2354 Parent_Type
: Entity_Id
;
2356 Discr_Val
: Elmt_Id
;
2359 Btype
:= Base_Type
(Typ
);
2361 while Is_Derived_Type
(Btype
)
2362 and then Present
(Stored_Constraint
(Btype
))
2364 Parent_Type
:= Etype
(Btype
);
2366 Disc
:= First_Discriminant
(Parent_Type
);
2368 First_Elmt
(Stored_Constraint
(Base_Type
(Typ
)));
2369 while Present
(Discr_Val
) loop
2371 -- Only those discriminants of the parent that are not
2372 -- renamed by discriminants of the derived type need to
2373 -- be added explicitly.
2375 if not Is_Entity_Name
(Node
(Discr_Val
))
2377 Ekind
(Entity
(Node
(Discr_Val
))) /= E_Discriminant
2380 Make_Selected_Component
(Loc
,
2381 Prefix
=> New_Copy_Tree
(Target
),
2382 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
2385 Make_OK_Assignment_Statement
(Loc
,
2387 Expression
=> New_Copy_Tree
(Node
(Discr_Val
)));
2389 Set_No_Ctrl_Actions
(Instr
);
2390 Append_To
(L
, Instr
);
2393 Next_Discriminant
(Disc
);
2394 Next_Elmt
(Discr_Val
);
2397 Btype
:= Base_Type
(Parent_Type
);
2401 -- Generate discriminant init values for the visible discriminants
2404 Discriminant
: Entity_Id
;
2405 Discriminant_Value
: Node_Id
;
2408 Discriminant
:= First_Stored_Discriminant
(Typ
);
2410 while Present
(Discriminant
) loop
2413 Make_Selected_Component
(Loc
,
2414 Prefix
=> New_Copy_Tree
(Target
),
2415 Selector_Name
=> New_Occurrence_Of
(Discriminant
, Loc
));
2417 Discriminant_Value
:=
2418 Get_Discriminant_Value
(
2421 Discriminant_Constraint
(N_Typ
));
2424 Make_OK_Assignment_Statement
(Loc
,
2426 Expression
=> New_Copy_Tree
(Discriminant_Value
));
2428 Set_No_Ctrl_Actions
(Instr
);
2429 Append_To
(L
, Instr
);
2431 Next_Stored_Discriminant
(Discriminant
);
2437 -- Generate the assignments, component by component
2439 -- tmp.comp1 := Expr1_From_Aggr;
2440 -- tmp.comp2 := Expr2_From_Aggr;
2443 Comp
:= First
(Component_Associations
(N
));
2444 while Present
(Comp
) loop
2445 Selector
:= Entity
(First
(Choices
(Comp
)));
2447 -- Ada 2005 (AI-287): For each default-initialized component genarate
2448 -- a call to the corresponding IP subprogram if available.
2450 if Box_Present
(Comp
)
2451 and then Has_Non_Null_Base_Init_Proc
(Etype
(Selector
))
2453 -- Ada 2005 (AI-287): If the component type has tasks then
2454 -- generate the activation chain and master entities (except
2455 -- in case of an allocator because in that case these entities
2456 -- are generated by Build_Task_Allocate_Block_With_Init_Stmts).
2459 Ctype
: constant Entity_Id
:= Etype
(Selector
);
2460 Inside_Allocator
: Boolean := False;
2461 P
: Node_Id
:= Parent
(N
);
2464 if Is_Task_Type
(Ctype
) or else Has_Task
(Ctype
) then
2465 while Present
(P
) loop
2466 if Nkind
(P
) = N_Allocator
then
2467 Inside_Allocator
:= True;
2474 if not Inside_Init_Proc
and not Inside_Allocator
then
2475 Build_Activation_Chain_Entity
(N
);
2481 Build_Initialization_Call
(Loc
,
2482 Id_Ref
=> Make_Selected_Component
(Loc
,
2483 Prefix
=> New_Copy_Tree
(Target
),
2484 Selector_Name
=> New_Occurrence_Of
(Selector
,
2486 Typ
=> Etype
(Selector
),
2487 With_Default_Init
=> True));
2492 -- Prepare for component assignment
2494 if Ekind
(Selector
) /= E_Discriminant
2495 or else Nkind
(N
) = N_Extension_Aggregate
2498 -- All the discriminants have now been assigned
2499 -- This is now a good moment to initialize and attach all the
2500 -- controllers. Their position may depend on the discriminants.
2502 if Ekind
(Selector
) /= E_Discriminant
2503 and then not Ctrl_Stuff_Done
2505 Gen_Ctrl_Actions_For_Aggr
;
2506 Ctrl_Stuff_Done
:= True;
2509 Comp_Type
:= Etype
(Selector
);
2511 Make_Selected_Component
(Loc
,
2512 Prefix
=> New_Copy_Tree
(Target
),
2513 Selector_Name
=> New_Occurrence_Of
(Selector
, Loc
));
2515 if Nkind
(Expression
(Comp
)) = N_Qualified_Expression
then
2516 Expr_Q
:= Expression
(Expression
(Comp
));
2518 Expr_Q
:= Expression
(Comp
);
2521 -- The controller is the one of the parent type defining
2522 -- the component (in case of inherited components).
2524 if Controlled_Type
(Comp_Type
) then
2525 Internal_Final_List
:=
2526 Make_Selected_Component
(Loc
,
2527 Prefix
=> Convert_To
(
2528 Scope
(Original_Record_Component
(Selector
)),
2529 New_Copy_Tree
(Target
)),
2531 Make_Identifier
(Loc
, Name_uController
));
2533 Internal_Final_List
:=
2534 Make_Selected_Component
(Loc
,
2535 Prefix
=> Internal_Final_List
,
2536 Selector_Name
=> Make_Identifier
(Loc
, Name_F
));
2538 -- The internal final list can be part of a constant object
2540 Set_Assignment_OK
(Internal_Final_List
);
2543 Internal_Final_List
:= Empty
;
2546 -- Now either create the assignment or generate the code for the
2547 -- inner aggregate top-down.
2549 if Is_Delayed_Aggregate
(Expr_Q
) then
2551 -- We have the following case of aggregate nesting inside
2552 -- an object declaration:
2554 -- type Arr_Typ is array (Integer range <>) of ...;
2556 -- type Rec_Typ (...) is record
2557 -- Obj_Arr_Typ : Arr_Typ (A .. B);
2560 -- Obj_Rec_Typ : Rec_Typ := (...,
2561 -- Obj_Arr_Typ => (X => (...), Y => (...)));
2563 -- The length of the ranges of the aggregate and Obj_Add_Typ
2564 -- are equal (B - A = Y - X), but they do not coincide (X /=
2565 -- A and B /= Y). This case requires array sliding which is
2566 -- performed in the following manner:
2568 -- subtype Arr_Sub is Arr_Typ (X .. Y);
2570 -- Temp (X) := (...);
2572 -- Temp (Y) := (...);
2573 -- Obj_Rec_Typ.Obj_Arr_Typ := Temp;
2576 and then Ekind
(Comp_Type
) = E_Array_Subtype
2577 and then Is_Int_Range_Bounds
(Aggregate_Bounds
(Expr_Q
))
2578 and then Is_Int_Range_Bounds
(First_Index
(Comp_Type
))
2580 Compatible_Int_Bounds
(
2581 Agg_Bounds
=> Aggregate_Bounds
(Expr_Q
),
2582 Typ_Bounds
=> First_Index
(Comp_Type
))
2585 -- Create the array subtype with bounds equal to those
2586 -- of the corresponding aggregate.
2588 SubE
: constant Entity_Id
:=
2589 Make_Defining_Identifier
(Loc
,
2590 New_Internal_Name
('T'));
2592 SubD
: constant Node_Id
:=
2593 Make_Subtype_Declaration
(Loc
,
2594 Defining_Identifier
=>
2596 Subtype_Indication
=>
2597 Make_Subtype_Indication
(Loc
,
2598 Subtype_Mark
=> New_Reference_To
(
2599 Etype
(Comp_Type
), Loc
),
2601 Make_Index_Or_Discriminant_Constraint
(
2602 Loc
, Constraints
=> New_List
(
2603 New_Copy_Tree
(Aggregate_Bounds
(
2606 -- Create a temporary array of the above subtype which
2607 -- will be used to capture the aggregate assignments.
2609 TmpE
: constant Entity_Id
:=
2610 Make_Defining_Identifier
(Loc
,
2611 New_Internal_Name
('A'));
2613 TmpD
: constant Node_Id
:=
2614 Make_Object_Declaration
(Loc
,
2615 Defining_Identifier
=>
2617 Object_Definition
=>
2618 New_Reference_To
(SubE
, Loc
));
2621 Set_No_Initialization
(TmpD
);
2622 Append_To
(L
, SubD
);
2623 Append_To
(L
, TmpD
);
2625 -- Expand the aggregate into assignments to the temporary
2629 Late_Expansion
(Expr_Q
, Comp_Type
,
2630 New_Reference_To
(TmpE
, Loc
), Internal_Final_List
));
2635 Make_Assignment_Statement
(Loc
,
2636 Name
=> New_Copy_Tree
(Comp_Expr
),
2637 Expression
=> New_Reference_To
(TmpE
, Loc
)));
2639 -- Do not pass the original aggregate to Gigi as is
2640 -- since it will potentially clobber the front or the
2641 -- end of the array. Setting the expression to empty
2642 -- is safe since all aggregates will be expanded into
2645 Set_Expression
(Parent
(Obj
), Empty
);
2648 -- Normal case (sliding not required)
2652 Late_Expansion
(Expr_Q
, Comp_Type
, Comp_Expr
,
2653 Internal_Final_List
));
2658 Make_OK_Assignment_Statement
(Loc
,
2660 Expression
=> Expression
(Comp
));
2662 Set_No_Ctrl_Actions
(Instr
);
2663 Append_To
(L
, Instr
);
2665 -- Adjust the tag if tagged (because of possible view
2666 -- conversions), unless compiling for the Java VM
2667 -- where tags are implicit.
2669 -- tmp.comp._tag := comp_typ'tag;
2671 if Is_Tagged_Type
(Comp_Type
) and then not Java_VM
then
2673 Make_OK_Assignment_Statement
(Loc
,
2675 Make_Selected_Component
(Loc
,
2676 Prefix
=> New_Copy_Tree
(Comp_Expr
),
2679 (First_Tag_Component
(Comp_Type
), Loc
)),
2682 Unchecked_Convert_To
(RTE
(RE_Tag
),
2684 (Node
(First_Elmt
(Access_Disp_Table
(Comp_Type
))),
2687 Append_To
(L
, Instr
);
2690 -- Adjust and Attach the component to the proper controller
2691 -- Adjust (tmp.comp);
2692 -- Attach_To_Final_List (tmp.comp,
2693 -- comp_typ (tmp)._record_controller.f)
2695 if Controlled_Type
(Comp_Type
) then
2698 Ref
=> New_Copy_Tree
(Comp_Expr
),
2700 Flist_Ref
=> Internal_Final_List
,
2701 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
2707 elsif Ekind
(Selector
) = E_Discriminant
2708 and then Nkind
(N
) /= N_Extension_Aggregate
2709 and then Nkind
(Parent
(N
)) = N_Component_Association
2710 and then Is_Constrained
(Typ
)
2712 -- We must check that the discriminant value imposed by the
2713 -- context is the same as the value given in the subaggregate,
2714 -- because after the expansion into assignments there is no
2715 -- record on which to perform a regular discriminant check.
2722 D_Val
:= First_Elmt
(Discriminant_Constraint
(Typ
));
2723 Disc
:= First_Discriminant
(Typ
);
2725 while Chars
(Disc
) /= Chars
(Selector
) loop
2726 Next_Discriminant
(Disc
);
2730 pragma Assert
(Present
(D_Val
));
2733 Make_Raise_Constraint_Error
(Loc
,
2736 Left_Opnd
=> New_Copy_Tree
(Node
(D_Val
)),
2737 Right_Opnd
=> Expression
(Comp
)),
2738 Reason
=> CE_Discriminant_Check_Failed
));
2747 -- If the type is tagged, the tag needs to be initialized (unless
2748 -- compiling for the Java VM where tags are implicit). It is done
2749 -- late in the initialization process because in some cases, we call
2750 -- the init proc of an ancestor which will not leave out the right tag
2752 if Ancestor_Is_Expression
then
2755 elsif Is_Tagged_Type
(Typ
) and then not Java_VM
then
2757 Make_OK_Assignment_Statement
(Loc
,
2759 Make_Selected_Component
(Loc
,
2760 Prefix
=> New_Copy_Tree
(Target
),
2763 (First_Tag_Component
(Base_Type
(Typ
)), Loc
)),
2766 Unchecked_Convert_To
(RTE
(RE_Tag
),
2768 (Node
(First_Elmt
(Access_Disp_Table
(Base_Type
(Typ
)))),
2771 Append_To
(L
, Instr
);
2774 -- If the controllers have not been initialized yet (by lack of non-
2775 -- discriminant components), let's do it now.
2777 if not Ctrl_Stuff_Done
then
2778 Gen_Ctrl_Actions_For_Aggr
;
2779 Ctrl_Stuff_Done
:= True;
2783 end Build_Record_Aggr_Code
;
2785 -------------------------------
2786 -- Convert_Aggr_In_Allocator --
2787 -------------------------------
2789 procedure Convert_Aggr_In_Allocator
(Decl
, Aggr
: Node_Id
) is
2790 Loc
: constant Source_Ptr
:= Sloc
(Aggr
);
2791 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2792 Temp
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2794 Occ
: constant Node_Id
:=
2795 Unchecked_Convert_To
(Typ
,
2796 Make_Explicit_Dereference
(Loc
,
2797 New_Reference_To
(Temp
, Loc
)));
2799 Access_Type
: constant Entity_Id
:= Etype
(Temp
);
2802 if Is_Array_Type
(Typ
) then
2803 Convert_Array_Aggr_In_Allocator
(Decl
, Aggr
, Occ
);
2805 elsif Has_Default_Init_Comps
(Aggr
) then
2807 L
: constant List_Id
:= New_List
;
2808 Init_Stmts
: List_Id
;
2811 Init_Stmts
:= Late_Expansion
(Aggr
, Typ
, Occ
,
2812 Find_Final_List
(Access_Type
),
2813 Associated_Final_Chain
(Base_Type
(Access_Type
)));
2815 Build_Task_Allocate_Block_With_Init_Stmts
(L
, Aggr
, Init_Stmts
);
2816 Insert_Actions_After
(Decl
, L
);
2820 Insert_Actions_After
(Decl
,
2821 Late_Expansion
(Aggr
, Typ
, Occ
,
2822 Find_Final_List
(Access_Type
),
2823 Associated_Final_Chain
(Base_Type
(Access_Type
))));
2825 end Convert_Aggr_In_Allocator
;
2827 --------------------------------
2828 -- Convert_Aggr_In_Assignment --
2829 --------------------------------
2831 procedure Convert_Aggr_In_Assignment
(N
: Node_Id
) is
2832 Aggr
: Node_Id
:= Expression
(N
);
2833 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2834 Occ
: constant Node_Id
:= New_Copy_Tree
(Name
(N
));
2837 if Nkind
(Aggr
) = N_Qualified_Expression
then
2838 Aggr
:= Expression
(Aggr
);
2841 Insert_Actions_After
(N
,
2842 Late_Expansion
(Aggr
, Typ
, Occ
,
2843 Find_Final_List
(Typ
, New_Copy_Tree
(Occ
))));
2844 end Convert_Aggr_In_Assignment
;
2846 ---------------------------------
2847 -- Convert_Aggr_In_Object_Decl --
2848 ---------------------------------
2850 procedure Convert_Aggr_In_Object_Decl
(N
: Node_Id
) is
2851 Obj
: constant Entity_Id
:= Defining_Identifier
(N
);
2852 Aggr
: Node_Id
:= Expression
(N
);
2853 Loc
: constant Source_Ptr
:= Sloc
(Aggr
);
2854 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2855 Occ
: constant Node_Id
:= New_Occurrence_Of
(Obj
, Loc
);
2857 function Discriminants_Ok
return Boolean;
2858 -- If the object type is constrained, the discriminants in the
2859 -- aggregate must be checked against the discriminants of the subtype.
2860 -- This cannot be done using Apply_Discriminant_Checks because after
2861 -- expansion there is no aggregate left to check.
2863 ----------------------
2864 -- Discriminants_Ok --
2865 ----------------------
2867 function Discriminants_Ok
return Boolean is
2868 Cond
: Node_Id
:= Empty
;
2877 D
:= First_Discriminant
(Typ
);
2878 Disc1
:= First_Elmt
(Discriminant_Constraint
(Typ
));
2879 Disc2
:= First_Elmt
(Discriminant_Constraint
(Etype
(Obj
)));
2881 while Present
(Disc1
) and then Present
(Disc2
) loop
2882 Val1
:= Node
(Disc1
);
2883 Val2
:= Node
(Disc2
);
2885 if not Is_OK_Static_Expression
(Val1
)
2886 or else not Is_OK_Static_Expression
(Val2
)
2888 Check
:= Make_Op_Ne
(Loc
,
2889 Left_Opnd
=> Duplicate_Subexpr
(Val1
),
2890 Right_Opnd
=> Duplicate_Subexpr
(Val2
));
2896 Cond
:= Make_Or_Else
(Loc
,
2898 Right_Opnd
=> Check
);
2901 elsif Expr_Value
(Val1
) /= Expr_Value
(Val2
) then
2902 Apply_Compile_Time_Constraint_Error
(Aggr
,
2903 Msg
=> "incorrect value for discriminant&?",
2904 Reason
=> CE_Discriminant_Check_Failed
,
2909 Next_Discriminant
(D
);
2914 -- If any discriminant constraint is non-static, emit a check
2916 if Present
(Cond
) then
2918 Make_Raise_Constraint_Error
(Loc
,
2920 Reason
=> CE_Discriminant_Check_Failed
));
2924 end Discriminants_Ok
;
2926 -- Start of processing for Convert_Aggr_In_Object_Decl
2929 Set_Assignment_OK
(Occ
);
2931 if Nkind
(Aggr
) = N_Qualified_Expression
then
2932 Aggr
:= Expression
(Aggr
);
2935 if Has_Discriminants
(Typ
)
2936 and then Typ
/= Etype
(Obj
)
2937 and then Is_Constrained
(Etype
(Obj
))
2938 and then not Discriminants_Ok
2943 if Requires_Transient_Scope
(Typ
) then
2944 Establish_Transient_Scope
(Aggr
, Sec_Stack
=>
2945 Is_Controlled
(Typ
) or else Has_Controlled_Component
(Typ
));
2948 Insert_Actions_After
(N
, Late_Expansion
(Aggr
, Typ
, Occ
, Obj
=> Obj
));
2949 Set_No_Initialization
(N
);
2950 Initialize_Discriminants
(N
, Typ
);
2951 end Convert_Aggr_In_Object_Decl
;
2953 -------------------------------------
2954 -- Convert_array_Aggr_In_Allocator --
2955 -------------------------------------
2957 procedure Convert_Array_Aggr_In_Allocator
2962 Aggr_Code
: List_Id
;
2963 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2964 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
2967 -- The target is an explicit dereference of the allocated object.
2968 -- Generate component assignments to it, as for an aggregate that
2969 -- appears on the right-hand side of an assignment statement.
2972 Build_Array_Aggr_Code
(Aggr
,
2974 Index
=> First_Index
(Typ
),
2976 Scalar_Comp
=> Is_Scalar_Type
(Ctyp
));
2978 Insert_Actions_After
(Decl
, Aggr_Code
);
2979 end Convert_Array_Aggr_In_Allocator
;
2981 ----------------------------
2982 -- Convert_To_Assignments --
2983 ----------------------------
2985 procedure Convert_To_Assignments
(N
: Node_Id
; Typ
: Entity_Id
) is
2986 Loc
: constant Source_Ptr
:= Sloc
(N
);
2990 Target_Expr
: Node_Id
;
2991 Parent_Kind
: Node_Kind
;
2992 Unc_Decl
: Boolean := False;
2993 Parent_Node
: Node_Id
;
2996 Parent_Node
:= Parent
(N
);
2997 Parent_Kind
:= Nkind
(Parent_Node
);
2999 if Parent_Kind
= N_Qualified_Expression
then
3001 -- Check if we are in a unconstrained declaration because in this
3002 -- case the current delayed expansion mechanism doesn't work when
3003 -- the declared object size depend on the initializing expr.
3006 Parent_Node
:= Parent
(Parent_Node
);
3007 Parent_Kind
:= Nkind
(Parent_Node
);
3009 if Parent_Kind
= N_Object_Declaration
then
3011 not Is_Entity_Name
(Object_Definition
(Parent_Node
))
3012 or else Has_Discriminants
3013 (Entity
(Object_Definition
(Parent_Node
)))
3014 or else Is_Class_Wide_Type
3015 (Entity
(Object_Definition
(Parent_Node
)));
3020 -- Just set the Delay flag in the following cases where the
3021 -- transformation will be done top down from above
3023 -- - internal aggregate (transformed when expanding the parent)
3024 -- - allocators (see Convert_Aggr_In_Allocator)
3025 -- - object decl (see Convert_Aggr_In_Object_Decl)
3026 -- - safe assignments (see Convert_Aggr_Assignments)
3027 -- so far only the assignments in the init procs are taken
3030 if Parent_Kind
= N_Aggregate
3031 or else Parent_Kind
= N_Extension_Aggregate
3032 or else Parent_Kind
= N_Component_Association
3033 or else Parent_Kind
= N_Allocator
3034 or else (Parent_Kind
= N_Object_Declaration
and then not Unc_Decl
)
3035 or else (Parent_Kind
= N_Assignment_Statement
3036 and then Inside_Init_Proc
)
3038 Set_Expansion_Delayed
(N
);
3042 if Requires_Transient_Scope
(Typ
) then
3043 Establish_Transient_Scope
(N
, Sec_Stack
=>
3044 Is_Controlled
(Typ
) or else Has_Controlled_Component
(Typ
));
3047 -- Create the temporary
3049 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
3052 Make_Object_Declaration
(Loc
,
3053 Defining_Identifier
=> Temp
,
3054 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
3056 Set_No_Initialization
(Instr
);
3057 Insert_Action
(N
, Instr
);
3058 Initialize_Discriminants
(Instr
, Typ
);
3059 Target_Expr
:= New_Occurrence_Of
(Temp
, Loc
);
3061 Insert_Actions
(N
, Build_Record_Aggr_Code
(N
, Typ
, Target_Expr
));
3062 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3063 Analyze_And_Resolve
(N
, Typ
);
3064 end Convert_To_Assignments
;
3066 ---------------------------
3067 -- Convert_To_Positional --
3068 ---------------------------
3070 procedure Convert_To_Positional
3072 Max_Others_Replicate
: Nat
:= 5;
3073 Handle_Bit_Packed
: Boolean := False)
3075 Typ
: constant Entity_Id
:= Etype
(N
);
3080 Ixb
: Node_Id
) return Boolean;
3081 -- Convert the aggregate into a purely positional form if possible.
3082 -- On entry the bounds of all dimensions are known to be static,
3083 -- and the total number of components is safe enough to expand.
3085 function Is_Flat
(N
: Node_Id
; Dims
: Int
) return Boolean;
3086 -- Return True iff the array N is flat (which is not rivial
3087 -- in the case of multidimensionsl aggregates).
3096 Ixb
: Node_Id
) return Boolean
3098 Loc
: constant Source_Ptr
:= Sloc
(N
);
3099 Blo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Ixb
));
3100 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Ix
));
3101 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Ix
));
3106 if Nkind
(Original_Node
(N
)) = N_String_Literal
then
3110 -- Only handle bounds starting at the base type low bound
3111 -- for now since the compiler isn't able to handle different low
3112 -- bounds yet. Case such as new String'(3..5 => ' ') will get
3113 -- the wrong bounds, though it seems that the aggregate should
3114 -- retain the bounds set on its Etype (see C64103E and CC1311B).
3116 Lov
:= Expr_Value
(Lo
);
3117 Hiv
:= Expr_Value
(Hi
);
3120 or else not Compile_Time_Known_Value
(Blo
)
3121 or else (Lov
/= Expr_Value
(Blo
))
3126 -- Determine if set of alternatives is suitable for conversion
3127 -- and build an array containing the values in sequence.
3130 Vals
: array (UI_To_Int
(Lov
) .. UI_To_Int
(Hiv
))
3131 of Node_Id
:= (others => Empty
);
3132 -- The values in the aggregate sorted appropriately
3135 -- Same data as Vals in list form
3138 -- Used to validate Max_Others_Replicate limit
3141 Num
: Int
:= UI_To_Int
(Lov
);
3146 if Present
(Expressions
(N
)) then
3147 Elmt
:= First
(Expressions
(N
));
3149 while Present
(Elmt
) loop
3150 if Nkind
(Elmt
) = N_Aggregate
3151 and then Present
(Next_Index
(Ix
))
3153 not Flatten
(Elmt
, Next_Index
(Ix
), Next_Index
(Ixb
))
3158 Vals
(Num
) := Relocate_Node
(Elmt
);
3165 if No
(Component_Associations
(N
)) then
3169 Elmt
:= First
(Component_Associations
(N
));
3171 if Nkind
(Expression
(Elmt
)) = N_Aggregate
then
3172 if Present
(Next_Index
(Ix
))
3175 (Expression
(Elmt
), Next_Index
(Ix
), Next_Index
(Ixb
))
3181 Component_Loop
: while Present
(Elmt
) loop
3182 Choice
:= First
(Choices
(Elmt
));
3183 Choice_Loop
: while Present
(Choice
) loop
3185 -- If we have an others choice, fill in the missing elements
3186 -- subject to the limit established by Max_Others_Replicate.
3188 if Nkind
(Choice
) = N_Others_Choice
then
3191 for J
in Vals
'Range loop
3192 if No
(Vals
(J
)) then
3193 Vals
(J
) := New_Copy_Tree
(Expression
(Elmt
));
3194 Rep_Count
:= Rep_Count
+ 1;
3196 -- Check for maximum others replication. Note that
3197 -- we skip this test if either of the restrictions
3198 -- No_Elaboration_Code or No_Implicit_Loops is
3199 -- active, or if this is a preelaborable unit.
3202 P
: constant Entity_Id
:=
3203 Cunit_Entity
(Current_Sem_Unit
);
3206 if Restriction_Active
(No_Elaboration_Code
)
3207 or else Restriction_Active
(No_Implicit_Loops
)
3208 or else Is_Preelaborated
(P
)
3209 or else (Ekind
(P
) = E_Package_Body
3211 Is_Preelaborated
(Spec_Entity
(P
)))
3215 elsif Rep_Count
> Max_Others_Replicate
then
3222 exit Component_Loop
;
3224 -- Case of a subtype mark
3226 elsif Nkind
(Choice
) = N_Identifier
3227 and then Is_Type
(Entity
(Choice
))
3229 Lo
:= Type_Low_Bound
(Etype
(Choice
));
3230 Hi
:= Type_High_Bound
(Etype
(Choice
));
3232 -- Case of subtype indication
3234 elsif Nkind
(Choice
) = N_Subtype_Indication
then
3235 Lo
:= Low_Bound
(Range_Expression
(Constraint
(Choice
)));
3236 Hi
:= High_Bound
(Range_Expression
(Constraint
(Choice
)));
3240 elsif Nkind
(Choice
) = N_Range
then
3241 Lo
:= Low_Bound
(Choice
);
3242 Hi
:= High_Bound
(Choice
);
3244 -- Normal subexpression case
3246 else pragma Assert
(Nkind
(Choice
) in N_Subexpr
);
3247 if not Compile_Time_Known_Value
(Choice
) then
3251 Vals
(UI_To_Int
(Expr_Value
(Choice
))) :=
3252 New_Copy_Tree
(Expression
(Elmt
));
3257 -- Range cases merge with Lo,Hi said
3259 if not Compile_Time_Known_Value
(Lo
)
3261 not Compile_Time_Known_Value
(Hi
)
3265 for J
in UI_To_Int
(Expr_Value
(Lo
)) ..
3266 UI_To_Int
(Expr_Value
(Hi
))
3268 Vals
(J
) := New_Copy_Tree
(Expression
(Elmt
));
3274 end loop Choice_Loop
;
3277 end loop Component_Loop
;
3279 -- If we get here the conversion is possible
3282 for J
in Vals
'Range loop
3283 Append
(Vals
(J
), Vlist
);
3286 Rewrite
(N
, Make_Aggregate
(Loc
, Expressions
=> Vlist
));
3287 Set_Aggregate_Bounds
(N
, Aggregate_Bounds
(Original_Node
(N
)));
3296 function Is_Flat
(N
: Node_Id
; Dims
: Int
) return Boolean is
3303 elsif Nkind
(N
) = N_Aggregate
then
3304 if Present
(Component_Associations
(N
)) then
3308 Elmt
:= First
(Expressions
(N
));
3310 while Present
(Elmt
) loop
3311 if not Is_Flat
(Elmt
, Dims
- 1) then
3325 -- Start of processing for Convert_To_Positional
3328 -- Ada 2005 (AI-287): Do not convert in case of default initialized
3329 -- components because in this case will need to call the corresponding
3332 if Has_Default_Init_Comps
(N
) then
3336 if Is_Flat
(N
, Number_Dimensions
(Typ
)) then
3340 if Is_Bit_Packed_Array
(Typ
)
3341 and then not Handle_Bit_Packed
3346 -- Do not convert to positional if controlled components are
3347 -- involved since these require special processing
3349 if Has_Controlled_Component
(Typ
) then
3353 if Aggr_Size_OK
(Typ
)
3355 Flatten
(N
, First_Index
(Typ
), First_Index
(Base_Type
(Typ
)))
3357 Analyze_And_Resolve
(N
, Typ
);
3359 end Convert_To_Positional
;
3361 ----------------------------
3362 -- Expand_Array_Aggregate --
3363 ----------------------------
3365 -- Array aggregate expansion proceeds as follows:
3367 -- 1. If requested we generate code to perform all the array aggregate
3368 -- bound checks, specifically
3370 -- (a) Check that the index range defined by aggregate bounds is
3371 -- compatible with corresponding index subtype.
3373 -- (b) If an others choice is present check that no aggregate
3374 -- index is outside the bounds of the index constraint.
3376 -- (c) For multidimensional arrays make sure that all subaggregates
3377 -- corresponding to the same dimension have the same bounds.
3379 -- 2. Check for packed array aggregate which can be converted to a
3380 -- constant so that the aggregate disappeares completely.
3382 -- 3. Check case of nested aggregate. Generally nested aggregates are
3383 -- handled during the processing of the parent aggregate.
3385 -- 4. Check if the aggregate can be statically processed. If this is the
3386 -- case pass it as is to Gigi. Note that a necessary condition for
3387 -- static processing is that the aggregate be fully positional.
3389 -- 5. If in place aggregate expansion is possible (i.e. no need to create
3390 -- a temporary) then mark the aggregate as such and return. Otherwise
3391 -- create a new temporary and generate the appropriate initialization
3394 procedure Expand_Array_Aggregate
(N
: Node_Id
) is
3395 Loc
: constant Source_Ptr
:= Sloc
(N
);
3397 Typ
: constant Entity_Id
:= Etype
(N
);
3398 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
3399 -- Typ is the correct constrained array subtype of the aggregate
3400 -- Ctyp is the corresponding component type.
3402 Aggr_Dimension
: constant Pos
:= Number_Dimensions
(Typ
);
3403 -- Number of aggregate index dimensions
3405 Aggr_Low
: array (1 .. Aggr_Dimension
) of Node_Id
;
3406 Aggr_High
: array (1 .. Aggr_Dimension
) of Node_Id
;
3407 -- Low and High bounds of the constraint for each aggregate index
3409 Aggr_Index_Typ
: array (1 .. Aggr_Dimension
) of Entity_Id
;
3410 -- The type of each index
3412 Maybe_In_Place_OK
: Boolean;
3413 -- If the type is neither controlled nor packed and the aggregate
3414 -- is the expression in an assignment, assignment in place may be
3415 -- possible, provided other conditions are met on the LHS.
3417 Others_Present
: array (1 .. Aggr_Dimension
) of Boolean :=
3419 -- If Others_Present (J) is True, then there is an others choice
3420 -- in one of the sub-aggregates of N at dimension J.
3422 procedure Build_Constrained_Type
(Positional
: Boolean);
3423 -- If the subtype is not static or unconstrained, build a constrained
3424 -- type using the computable sizes of the aggregate and its sub-
3427 procedure Check_Bounds
(Aggr_Bounds
: Node_Id
; Index_Bounds
: Node_Id
);
3428 -- Checks that the bounds of Aggr_Bounds are within the bounds defined
3431 procedure Check_Same_Aggr_Bounds
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3432 -- Checks that in a multi-dimensional array aggregate all subaggregates
3433 -- corresponding to the same dimension have the same bounds.
3434 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3435 -- corresponding to the sub-aggregate.
3437 procedure Compute_Others_Present
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3438 -- Computes the values of array Others_Present. Sub_Aggr is the
3439 -- array sub-aggregate we start the computation from. Dim is the
3440 -- dimension corresponding to the sub-aggregate.
3442 function Has_Address_Clause
(D
: Node_Id
) return Boolean;
3443 -- If the aggregate is the expression in an object declaration, it
3444 -- cannot be expanded in place. This function does a lookahead in the
3445 -- current declarative part to find an address clause for the object
3448 function In_Place_Assign_OK
return Boolean;
3449 -- Simple predicate to determine whether an aggregate assignment can
3450 -- be done in place, because none of the new values can depend on the
3451 -- components of the target of the assignment.
3453 procedure Others_Check
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3454 -- Checks that if an others choice is present in any sub-aggregate no
3455 -- aggregate index is outside the bounds of the index constraint.
3456 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3457 -- corresponding to the sub-aggregate.
3459 ----------------------------
3460 -- Build_Constrained_Type --
3461 ----------------------------
3463 procedure Build_Constrained_Type
(Positional
: Boolean) is
3464 Loc
: constant Source_Ptr
:= Sloc
(N
);
3465 Agg_Type
: Entity_Id
;
3468 Typ
: constant Entity_Id
:= Etype
(N
);
3469 Indices
: constant List_Id
:= New_List
;
3475 Make_Defining_Identifier
(
3476 Loc
, New_Internal_Name
('A'));
3478 -- If the aggregate is purely positional, all its subaggregates
3479 -- have the same size. We collect the dimensions from the first
3480 -- subaggregate at each level.
3485 for D
in 1 .. Number_Dimensions
(Typ
) loop
3486 Comp
:= First
(Expressions
(Sub_Agg
));
3491 while Present
(Comp
) loop
3498 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
3500 Make_Integer_Literal
(Loc
, Num
)),
3505 -- We know the aggregate type is unconstrained and the
3506 -- aggregate is not processable by the back end, therefore
3507 -- not necessarily positional. Retrieve the bounds of each
3508 -- dimension as computed earlier.
3510 for D
in 1 .. Number_Dimensions
(Typ
) loop
3513 Low_Bound
=> Aggr_Low
(D
),
3514 High_Bound
=> Aggr_High
(D
)),
3520 Make_Full_Type_Declaration
(Loc
,
3521 Defining_Identifier
=> Agg_Type
,
3523 Make_Constrained_Array_Definition
(Loc
,
3524 Discrete_Subtype_Definitions
=> Indices
,
3525 Component_Definition
=>
3526 Make_Component_Definition
(Loc
,
3527 Aliased_Present
=> False,
3528 Subtype_Indication
=>
3529 New_Occurrence_Of
(Component_Type
(Typ
), Loc
))));
3531 Insert_Action
(N
, Decl
);
3533 Set_Etype
(N
, Agg_Type
);
3534 Set_Is_Itype
(Agg_Type
);
3535 Freeze_Itype
(Agg_Type
, N
);
3536 end Build_Constrained_Type
;
3542 procedure Check_Bounds
(Aggr_Bounds
: Node_Id
; Index_Bounds
: Node_Id
) is
3549 Cond
: Node_Id
:= Empty
;
3552 Get_Index_Bounds
(Aggr_Bounds
, Aggr_Lo
, Aggr_Hi
);
3553 Get_Index_Bounds
(Index_Bounds
, Ind_Lo
, Ind_Hi
);
3555 -- Generate the following test:
3557 -- [constraint_error when
3558 -- Aggr_Lo <= Aggr_Hi and then
3559 -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
3561 -- As an optimization try to see if some tests are trivially vacuos
3562 -- because we are comparing an expression against itself.
3564 if Aggr_Lo
= Ind_Lo
and then Aggr_Hi
= Ind_Hi
then
3567 elsif Aggr_Hi
= Ind_Hi
then
3570 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3571 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Lo
));
3573 elsif Aggr_Lo
= Ind_Lo
then
3576 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
),
3577 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Hi
));
3584 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3585 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Lo
)),
3589 Left_Opnd
=> Duplicate_Subexpr
(Aggr_Hi
),
3590 Right_Opnd
=> Duplicate_Subexpr
(Ind_Hi
)));
3593 if Present
(Cond
) then
3598 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3599 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
)),
3601 Right_Opnd
=> Cond
);
3603 Set_Analyzed
(Left_Opnd
(Left_Opnd
(Cond
)), False);
3604 Set_Analyzed
(Right_Opnd
(Left_Opnd
(Cond
)), False);
3606 Make_Raise_Constraint_Error
(Loc
,
3608 Reason
=> CE_Length_Check_Failed
));
3612 ----------------------------
3613 -- Check_Same_Aggr_Bounds --
3614 ----------------------------
3616 procedure Check_Same_Aggr_Bounds
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
3617 Sub_Lo
: constant Node_Id
:= Low_Bound
(Aggregate_Bounds
(Sub_Aggr
));
3618 Sub_Hi
: constant Node_Id
:= High_Bound
(Aggregate_Bounds
(Sub_Aggr
));
3619 -- The bounds of this specific sub-aggregate
3621 Aggr_Lo
: constant Node_Id
:= Aggr_Low
(Dim
);
3622 Aggr_Hi
: constant Node_Id
:= Aggr_High
(Dim
);
3623 -- The bounds of the aggregate for this dimension
3625 Ind_Typ
: constant Entity_Id
:= Aggr_Index_Typ
(Dim
);
3626 -- The index type for this dimension.xxx
3628 Cond
: Node_Id
:= Empty
;
3634 -- If index checks are on generate the test
3636 -- [constraint_error when
3637 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
3639 -- As an optimization try to see if some tests are trivially vacuos
3640 -- because we are comparing an expression against itself. Also for
3641 -- the first dimension the test is trivially vacuous because there
3642 -- is just one aggregate for dimension 1.
3644 if Index_Checks_Suppressed
(Ind_Typ
) then
3648 or else (Aggr_Lo
= Sub_Lo
and then Aggr_Hi
= Sub_Hi
)
3652 elsif Aggr_Hi
= Sub_Hi
then
3655 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3656 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Lo
));
3658 elsif Aggr_Lo
= Sub_Lo
then
3661 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
),
3662 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Hi
));
3669 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3670 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Lo
)),
3674 Left_Opnd
=> Duplicate_Subexpr
(Aggr_Hi
),
3675 Right_Opnd
=> Duplicate_Subexpr
(Sub_Hi
)));
3678 if Present
(Cond
) then
3680 Make_Raise_Constraint_Error
(Loc
,
3682 Reason
=> CE_Length_Check_Failed
));
3685 -- Now look inside the sub-aggregate to see if there is more work
3687 if Dim
< Aggr_Dimension
then
3689 -- Process positional components
3691 if Present
(Expressions
(Sub_Aggr
)) then
3692 Expr
:= First
(Expressions
(Sub_Aggr
));
3693 while Present
(Expr
) loop
3694 Check_Same_Aggr_Bounds
(Expr
, Dim
+ 1);
3699 -- Process component associations
3701 if Present
(Component_Associations
(Sub_Aggr
)) then
3702 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
3703 while Present
(Assoc
) loop
3704 Expr
:= Expression
(Assoc
);
3705 Check_Same_Aggr_Bounds
(Expr
, Dim
+ 1);
3710 end Check_Same_Aggr_Bounds
;
3712 ----------------------------
3713 -- Compute_Others_Present --
3714 ----------------------------
3716 procedure Compute_Others_Present
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
3721 if Present
(Component_Associations
(Sub_Aggr
)) then
3722 Assoc
:= Last
(Component_Associations
(Sub_Aggr
));
3724 if Nkind
(First
(Choices
(Assoc
))) = N_Others_Choice
then
3725 Others_Present
(Dim
) := True;
3729 -- Now look inside the sub-aggregate to see if there is more work
3731 if Dim
< Aggr_Dimension
then
3733 -- Process positional components
3735 if Present
(Expressions
(Sub_Aggr
)) then
3736 Expr
:= First
(Expressions
(Sub_Aggr
));
3737 while Present
(Expr
) loop
3738 Compute_Others_Present
(Expr
, Dim
+ 1);
3743 -- Process component associations
3745 if Present
(Component_Associations
(Sub_Aggr
)) then
3746 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
3747 while Present
(Assoc
) loop
3748 Expr
:= Expression
(Assoc
);
3749 Compute_Others_Present
(Expr
, Dim
+ 1);
3754 end Compute_Others_Present
;
3756 ------------------------
3757 -- Has_Address_Clause --
3758 ------------------------
3760 function Has_Address_Clause
(D
: Node_Id
) return Boolean is
3761 Id
: constant Entity_Id
:= Defining_Identifier
(D
);
3762 Decl
: Node_Id
:= Next
(D
);
3765 while Present
(Decl
) loop
3766 if Nkind
(Decl
) = N_At_Clause
3767 and then Chars
(Identifier
(Decl
)) = Chars
(Id
)
3771 elsif Nkind
(Decl
) = N_Attribute_Definition_Clause
3772 and then Chars
(Decl
) = Name_Address
3773 and then Chars
(Name
(Decl
)) = Chars
(Id
)
3782 end Has_Address_Clause
;
3784 ------------------------
3785 -- In_Place_Assign_OK --
3786 ------------------------
3788 function In_Place_Assign_OK
return Boolean is
3796 function Is_Others_Aggregate
(Aggr
: Node_Id
) return Boolean;
3797 -- Aggregates that consist of a single Others choice are safe
3798 -- if the single expression is.
3800 function Safe_Aggregate
(Aggr
: Node_Id
) return Boolean;
3801 -- Check recursively that each component of a (sub)aggregate does
3802 -- not depend on the variable being assigned to.
3804 function Safe_Component
(Expr
: Node_Id
) return Boolean;
3805 -- Verify that an expression cannot depend on the variable being
3806 -- assigned to. Room for improvement here (but less than before).
3808 -------------------------
3809 -- Is_Others_Aggregate --
3810 -------------------------
3812 function Is_Others_Aggregate
(Aggr
: Node_Id
) return Boolean is
3814 return No
(Expressions
(Aggr
))
3816 (First
(Choices
(First
(Component_Associations
(Aggr
)))))
3818 end Is_Others_Aggregate
;
3820 --------------------
3821 -- Safe_Aggregate --
3822 --------------------
3824 function Safe_Aggregate
(Aggr
: Node_Id
) return Boolean is
3828 if Present
(Expressions
(Aggr
)) then
3829 Expr
:= First
(Expressions
(Aggr
));
3831 while Present
(Expr
) loop
3832 if Nkind
(Expr
) = N_Aggregate
then
3833 if not Safe_Aggregate
(Expr
) then
3837 elsif not Safe_Component
(Expr
) then
3845 if Present
(Component_Associations
(Aggr
)) then
3846 Expr
:= First
(Component_Associations
(Aggr
));
3848 while Present
(Expr
) loop
3849 if Nkind
(Expression
(Expr
)) = N_Aggregate
then
3850 if not Safe_Aggregate
(Expression
(Expr
)) then
3854 elsif not Safe_Component
(Expression
(Expr
)) then
3865 --------------------
3866 -- Safe_Component --
3867 --------------------
3869 function Safe_Component
(Expr
: Node_Id
) return Boolean is
3870 Comp
: Node_Id
:= Expr
;
3872 function Check_Component
(Comp
: Node_Id
) return Boolean;
3873 -- Do the recursive traversal, after copy
3875 ---------------------
3876 -- Check_Component --
3877 ---------------------
3879 function Check_Component
(Comp
: Node_Id
) return Boolean is
3881 if Is_Overloaded
(Comp
) then
3885 return Compile_Time_Known_Value
(Comp
)
3887 or else (Is_Entity_Name
(Comp
)
3888 and then Present
(Entity
(Comp
))
3889 and then No
(Renamed_Object
(Entity
(Comp
))))
3891 or else (Nkind
(Comp
) = N_Attribute_Reference
3892 and then Check_Component
(Prefix
(Comp
)))
3894 or else (Nkind
(Comp
) in N_Binary_Op
3895 and then Check_Component
(Left_Opnd
(Comp
))
3896 and then Check_Component
(Right_Opnd
(Comp
)))
3898 or else (Nkind
(Comp
) in N_Unary_Op
3899 and then Check_Component
(Right_Opnd
(Comp
)))
3901 or else (Nkind
(Comp
) = N_Selected_Component
3902 and then Check_Component
(Prefix
(Comp
)))
3904 or else (Nkind
(Comp
) = N_Unchecked_Type_Conversion
3905 and then Check_Component
(Expression
(Comp
)));
3906 end Check_Component
;
3908 -- Start of processing for Safe_Component
3911 -- If the component appears in an association that may
3912 -- correspond to more than one element, it is not analyzed
3913 -- before the expansion into assignments, to avoid side effects.
3914 -- We analyze, but do not resolve the copy, to obtain sufficient
3915 -- entity information for the checks that follow. If component is
3916 -- overloaded we assume an unsafe function call.
3918 if not Analyzed
(Comp
) then
3919 if Is_Overloaded
(Expr
) then
3922 elsif Nkind
(Expr
) = N_Aggregate
3923 and then not Is_Others_Aggregate
(Expr
)
3927 elsif Nkind
(Expr
) = N_Allocator
then
3929 -- For now, too complex to analyze
3934 Comp
:= New_Copy_Tree
(Expr
);
3935 Set_Parent
(Comp
, Parent
(Expr
));
3939 if Nkind
(Comp
) = N_Aggregate
then
3940 return Safe_Aggregate
(Comp
);
3942 return Check_Component
(Comp
);
3946 -- Start of processing for In_Place_Assign_OK
3949 if Present
(Component_Associations
(N
)) then
3951 -- On assignment, sliding can take place, so we cannot do the
3952 -- assignment in place unless the bounds of the aggregate are
3953 -- statically equal to those of the target.
3955 -- If the aggregate is given by an others choice, the bounds
3956 -- are derived from the left-hand side, and the assignment is
3957 -- safe if the expression is.
3959 if Is_Others_Aggregate
(N
) then
3962 (Expression
(First
(Component_Associations
(N
))));
3965 Aggr_In
:= First_Index
(Etype
(N
));
3966 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
3967 Obj_In
:= First_Index
(Etype
(Name
(Parent
(N
))));
3970 -- Context is an allocator. Check bounds of aggregate
3971 -- against given type in qualified expression.
3973 pragma Assert
(Nkind
(Parent
(Parent
(N
))) = N_Allocator
);
3975 First_Index
(Etype
(Entity
(Subtype_Mark
(Parent
(N
)))));
3978 while Present
(Aggr_In
) loop
3979 Get_Index_Bounds
(Aggr_In
, Aggr_Lo
, Aggr_Hi
);
3980 Get_Index_Bounds
(Obj_In
, Obj_Lo
, Obj_Hi
);
3982 if not Compile_Time_Known_Value
(Aggr_Lo
)
3983 or else not Compile_Time_Known_Value
(Aggr_Hi
)
3984 or else not Compile_Time_Known_Value
(Obj_Lo
)
3985 or else not Compile_Time_Known_Value
(Obj_Hi
)
3986 or else Expr_Value
(Aggr_Lo
) /= Expr_Value
(Obj_Lo
)
3987 or else Expr_Value
(Aggr_Hi
) /= Expr_Value
(Obj_Hi
)
3992 Next_Index
(Aggr_In
);
3993 Next_Index
(Obj_In
);
3997 -- Now check the component values themselves
3999 return Safe_Aggregate
(N
);
4000 end In_Place_Assign_OK
;
4006 procedure Others_Check
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
4007 Aggr_Lo
: constant Node_Id
:= Aggr_Low
(Dim
);
4008 Aggr_Hi
: constant Node_Id
:= Aggr_High
(Dim
);
4009 -- The bounds of the aggregate for this dimension
4011 Ind_Typ
: constant Entity_Id
:= Aggr_Index_Typ
(Dim
);
4012 -- The index type for this dimension
4014 Need_To_Check
: Boolean := False;
4016 Choices_Lo
: Node_Id
:= Empty
;
4017 Choices_Hi
: Node_Id
:= Empty
;
4018 -- The lowest and highest discrete choices for a named sub-aggregate
4020 Nb_Choices
: Int
:= -1;
4021 -- The number of discrete non-others choices in this sub-aggregate
4023 Nb_Elements
: Uint
:= Uint_0
;
4024 -- The number of elements in a positional aggregate
4026 Cond
: Node_Id
:= Empty
;
4033 -- Check if we have an others choice. If we do make sure that this
4034 -- sub-aggregate contains at least one element in addition to the
4037 if Range_Checks_Suppressed
(Ind_Typ
) then
4038 Need_To_Check
:= False;
4040 elsif Present
(Expressions
(Sub_Aggr
))
4041 and then Present
(Component_Associations
(Sub_Aggr
))
4043 Need_To_Check
:= True;
4045 elsif Present
(Component_Associations
(Sub_Aggr
)) then
4046 Assoc
:= Last
(Component_Associations
(Sub_Aggr
));
4048 if Nkind
(First
(Choices
(Assoc
))) /= N_Others_Choice
then
4049 Need_To_Check
:= False;
4052 -- Count the number of discrete choices. Start with -1
4053 -- because the others choice does not count.
4056 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4057 while Present
(Assoc
) loop
4058 Choice
:= First
(Choices
(Assoc
));
4059 while Present
(Choice
) loop
4060 Nb_Choices
:= Nb_Choices
+ 1;
4067 -- If there is only an others choice nothing to do
4069 Need_To_Check
:= (Nb_Choices
> 0);
4073 Need_To_Check
:= False;
4076 -- If we are dealing with a positional sub-aggregate with an
4077 -- others choice then compute the number or positional elements.
4079 if Need_To_Check
and then Present
(Expressions
(Sub_Aggr
)) then
4080 Expr
:= First
(Expressions
(Sub_Aggr
));
4081 Nb_Elements
:= Uint_0
;
4082 while Present
(Expr
) loop
4083 Nb_Elements
:= Nb_Elements
+ 1;
4087 -- If the aggregate contains discrete choices and an others choice
4088 -- compute the smallest and largest discrete choice values.
4090 elsif Need_To_Check
then
4091 Compute_Choices_Lo_And_Choices_Hi
: declare
4093 Table
: Case_Table_Type
(1 .. Nb_Choices
);
4094 -- Used to sort all the different choice values
4101 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4102 while Present
(Assoc
) loop
4103 Choice
:= First
(Choices
(Assoc
));
4104 while Present
(Choice
) loop
4105 if Nkind
(Choice
) = N_Others_Choice
then
4109 Get_Index_Bounds
(Choice
, Low
, High
);
4110 Table
(J
).Choice_Lo
:= Low
;
4111 Table
(J
).Choice_Hi
:= High
;
4120 -- Sort the discrete choices
4122 Sort_Case_Table
(Table
);
4124 Choices_Lo
:= Table
(1).Choice_Lo
;
4125 Choices_Hi
:= Table
(Nb_Choices
).Choice_Hi
;
4126 end Compute_Choices_Lo_And_Choices_Hi
;
4129 -- If no others choice in this sub-aggregate, or the aggregate
4130 -- comprises only an others choice, nothing to do.
4132 if not Need_To_Check
then
4135 -- If we are dealing with an aggregate containing an others
4136 -- choice and positional components, we generate the following test:
4138 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
4139 -- Ind_Typ'Pos (Aggr_Hi)
4141 -- raise Constraint_Error;
4144 elsif Nb_Elements
> Uint_0
then
4150 Make_Attribute_Reference
(Loc
,
4151 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
4152 Attribute_Name
=> Name_Pos
,
4155 (Duplicate_Subexpr_Move_Checks
(Aggr_Lo
))),
4156 Right_Opnd
=> Make_Integer_Literal
(Loc
, Nb_Elements
- 1)),
4159 Make_Attribute_Reference
(Loc
,
4160 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
4161 Attribute_Name
=> Name_Pos
,
4162 Expressions
=> New_List
(
4163 Duplicate_Subexpr_Move_Checks
(Aggr_Hi
))));
4165 -- If we are dealing with an aggregate containing an others
4166 -- choice and discrete choices we generate the following test:
4168 -- [constraint_error when
4169 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
4177 Duplicate_Subexpr_Move_Checks
(Choices_Lo
),
4179 Duplicate_Subexpr_Move_Checks
(Aggr_Lo
)),
4184 Duplicate_Subexpr
(Choices_Hi
),
4186 Duplicate_Subexpr
(Aggr_Hi
)));
4189 if Present
(Cond
) then
4191 Make_Raise_Constraint_Error
(Loc
,
4193 Reason
=> CE_Length_Check_Failed
));
4196 -- Now look inside the sub-aggregate to see if there is more work
4198 if Dim
< Aggr_Dimension
then
4200 -- Process positional components
4202 if Present
(Expressions
(Sub_Aggr
)) then
4203 Expr
:= First
(Expressions
(Sub_Aggr
));
4204 while Present
(Expr
) loop
4205 Others_Check
(Expr
, Dim
+ 1);
4210 -- Process component associations
4212 if Present
(Component_Associations
(Sub_Aggr
)) then
4213 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4214 while Present
(Assoc
) loop
4215 Expr
:= Expression
(Assoc
);
4216 Others_Check
(Expr
, Dim
+ 1);
4223 -- Remaining Expand_Array_Aggregate variables
4226 -- Holds the temporary aggregate value
4229 -- Holds the declaration of Tmp
4231 Aggr_Code
: List_Id
;
4232 Parent_Node
: Node_Id
;
4233 Parent_Kind
: Node_Kind
;
4235 -- Start of processing for Expand_Array_Aggregate
4238 -- Do not touch the special aggregates of attributes used for Asm calls
4240 if Is_RTE
(Ctyp
, RE_Asm_Input_Operand
)
4241 or else Is_RTE
(Ctyp
, RE_Asm_Output_Operand
)
4246 -- If the semantic analyzer has determined that aggregate N will raise
4247 -- Constraint_Error at run-time, then the aggregate node has been
4248 -- replaced with an N_Raise_Constraint_Error node and we should
4251 pragma Assert
(not Raises_Constraint_Error
(N
));
4255 -- Check that the index range defined by aggregate bounds is
4256 -- compatible with corresponding index subtype.
4258 Index_Compatibility_Check
: declare
4259 Aggr_Index_Range
: Node_Id
:= First_Index
(Typ
);
4260 -- The current aggregate index range
4262 Index_Constraint
: Node_Id
:= First_Index
(Etype
(Typ
));
4263 -- The corresponding index constraint against which we have to
4264 -- check the above aggregate index range.
4267 Compute_Others_Present
(N
, 1);
4269 for J
in 1 .. Aggr_Dimension
loop
4270 -- There is no need to emit a check if an others choice is
4271 -- present for this array aggregate dimension since in this
4272 -- case one of N's sub-aggregates has taken its bounds from the
4273 -- context and these bounds must have been checked already. In
4274 -- addition all sub-aggregates corresponding to the same
4275 -- dimension must all have the same bounds (checked in (c) below).
4277 if not Range_Checks_Suppressed
(Etype
(Index_Constraint
))
4278 and then not Others_Present
(J
)
4280 -- We don't use Checks.Apply_Range_Check here because it
4281 -- emits a spurious check. Namely it checks that the range
4282 -- defined by the aggregate bounds is non empty. But we know
4283 -- this already if we get here.
4285 Check_Bounds
(Aggr_Index_Range
, Index_Constraint
);
4288 -- Save the low and high bounds of the aggregate index as well
4289 -- as the index type for later use in checks (b) and (c) below.
4291 Aggr_Low
(J
) := Low_Bound
(Aggr_Index_Range
);
4292 Aggr_High
(J
) := High_Bound
(Aggr_Index_Range
);
4294 Aggr_Index_Typ
(J
) := Etype
(Index_Constraint
);
4296 Next_Index
(Aggr_Index_Range
);
4297 Next_Index
(Index_Constraint
);
4299 end Index_Compatibility_Check
;
4303 -- If an others choice is present check that no aggregate
4304 -- index is outside the bounds of the index constraint.
4306 Others_Check
(N
, 1);
4310 -- For multidimensional arrays make sure that all subaggregates
4311 -- corresponding to the same dimension have the same bounds.
4313 if Aggr_Dimension
> 1 then
4314 Check_Same_Aggr_Bounds
(N
, 1);
4319 -- Here we test for is packed array aggregate that we can handle
4320 -- at compile time. If so, return with transformation done. Note
4321 -- that we do this even if the aggregate is nested, because once
4322 -- we have done this processing, there is no more nested aggregate!
4324 if Packed_Array_Aggregate_Handled
(N
) then
4328 -- At this point we try to convert to positional form
4330 Convert_To_Positional
(N
);
4332 -- if the result is no longer an aggregate (e.g. it may be a string
4333 -- literal, or a temporary which has the needed value), then we are
4334 -- done, since there is no longer a nested aggregate.
4336 if Nkind
(N
) /= N_Aggregate
then
4339 -- We are also done if the result is an analyzed aggregate
4340 -- This case could use more comments ???
4343 and then N
/= Original_Node
(N
)
4348 -- Now see if back end processing is possible
4350 if Backend_Processing_Possible
(N
) then
4352 -- If the aggregate is static but the constraints are not, build
4353 -- a static subtype for the aggregate, so that Gigi can place it
4354 -- in static memory. Perform an unchecked_conversion to the non-
4355 -- static type imposed by the context.
4358 Itype
: constant Entity_Id
:= Etype
(N
);
4360 Needs_Type
: Boolean := False;
4363 Index
:= First_Index
(Itype
);
4365 while Present
(Index
) loop
4366 if not Is_Static_Subtype
(Etype
(Index
)) then
4375 Build_Constrained_Type
(Positional
=> True);
4376 Rewrite
(N
, Unchecked_Convert_To
(Itype
, N
));
4386 -- Delay expansion for nested aggregates it will be taken care of
4387 -- when the parent aggregate is expanded
4389 Parent_Node
:= Parent
(N
);
4390 Parent_Kind
:= Nkind
(Parent_Node
);
4392 if Parent_Kind
= N_Qualified_Expression
then
4393 Parent_Node
:= Parent
(Parent_Node
);
4394 Parent_Kind
:= Nkind
(Parent_Node
);
4397 if Parent_Kind
= N_Aggregate
4398 or else Parent_Kind
= N_Extension_Aggregate
4399 or else Parent_Kind
= N_Component_Association
4400 or else (Parent_Kind
= N_Object_Declaration
4401 and then Controlled_Type
(Typ
))
4402 or else (Parent_Kind
= N_Assignment_Statement
4403 and then Inside_Init_Proc
)
4405 Set_Expansion_Delayed
(N
);
4411 -- Look if in place aggregate expansion is possible
4413 -- For object declarations we build the aggregate in place, unless
4414 -- the array is bit-packed or the component is controlled.
4416 -- For assignments we do the assignment in place if all the component
4417 -- associations have compile-time known values. For other cases we
4418 -- create a temporary. The analysis for safety of on-line assignment
4419 -- is delicate, i.e. we don't know how to do it fully yet ???
4421 -- For allocators we assign to the designated object in place if the
4422 -- aggregate meets the same conditions as other in-place assignments.
4423 -- In this case the aggregate may not come from source but was created
4424 -- for default initialization, e.g. with Initialize_Scalars.
4426 if Requires_Transient_Scope
(Typ
) then
4427 Establish_Transient_Scope
4428 (N
, Sec_Stack
=> Has_Controlled_Component
(Typ
));
4431 if Has_Default_Init_Comps
(N
) then
4432 Maybe_In_Place_OK
:= False;
4434 elsif Is_Bit_Packed_Array
(Typ
)
4435 or else Has_Controlled_Component
(Typ
)
4437 Maybe_In_Place_OK
:= False;
4440 Maybe_In_Place_OK
:=
4441 (Nkind
(Parent
(N
)) = N_Assignment_Statement
4442 and then Comes_From_Source
(N
)
4443 and then In_Place_Assign_OK
)
4446 (Nkind
(Parent
(Parent
(N
))) = N_Allocator
4447 and then In_Place_Assign_OK
);
4450 if not Has_Default_Init_Comps
(N
)
4451 and then Comes_From_Source
(Parent
(N
))
4452 and then Nkind
(Parent
(N
)) = N_Object_Declaration
4454 Must_Slide
(Etype
(Defining_Identifier
(Parent
(N
))), Typ
)
4455 and then N
= Expression
(Parent
(N
))
4456 and then not Is_Bit_Packed_Array
(Typ
)
4457 and then not Has_Controlled_Component
(Typ
)
4458 and then not Has_Address_Clause
(Parent
(N
))
4460 Tmp
:= Defining_Identifier
(Parent
(N
));
4461 Set_No_Initialization
(Parent
(N
));
4462 Set_Expression
(Parent
(N
), Empty
);
4464 -- Set the type of the entity, for use in the analysis of the
4465 -- subsequent indexed assignments. If the nominal type is not
4466 -- constrained, build a subtype from the known bounds of the
4467 -- aggregate. If the declaration has a subtype mark, use it,
4468 -- otherwise use the itype of the aggregate.
4470 if not Is_Constrained
(Typ
) then
4471 Build_Constrained_Type
(Positional
=> False);
4472 elsif Is_Entity_Name
(Object_Definition
(Parent
(N
)))
4473 and then Is_Constrained
(Entity
(Object_Definition
(Parent
(N
))))
4475 Set_Etype
(Tmp
, Entity
(Object_Definition
(Parent
(N
))));
4477 Set_Size_Known_At_Compile_Time
(Typ
, False);
4478 Set_Etype
(Tmp
, Typ
);
4481 elsif Maybe_In_Place_OK
4482 and then Nkind
(Parent
(N
)) = N_Qualified_Expression
4483 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
4485 Set_Expansion_Delayed
(N
);
4488 -- In the remaining cases the aggregate is the RHS of an assignment
4490 elsif Maybe_In_Place_OK
4491 and then Is_Entity_Name
(Name
(Parent
(N
)))
4493 Tmp
:= Entity
(Name
(Parent
(N
)));
4495 if Etype
(Tmp
) /= Etype
(N
) then
4496 Apply_Length_Check
(N
, Etype
(Tmp
));
4498 if Nkind
(N
) = N_Raise_Constraint_Error
then
4500 -- Static error, nothing further to expand
4506 elsif Maybe_In_Place_OK
4507 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
4508 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
4510 Tmp
:= Name
(Parent
(N
));
4512 if Etype
(Tmp
) /= Etype
(N
) then
4513 Apply_Length_Check
(N
, Etype
(Tmp
));
4516 elsif Maybe_In_Place_OK
4517 and then Nkind
(Name
(Parent
(N
))) = N_Slice
4518 and then Safe_Slice_Assignment
(N
)
4520 -- Safe_Slice_Assignment rewrites assignment as a loop
4526 -- In place aggregate expansion is not possible
4529 Maybe_In_Place_OK
:= False;
4530 Tmp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
4532 Make_Object_Declaration
4534 Defining_Identifier
=> Tmp
,
4535 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
4536 Set_No_Initialization
(Tmp_Decl
, True);
4538 -- If we are within a loop, the temporary will be pushed on the
4539 -- stack at each iteration. If the aggregate is the expression for
4540 -- an allocator, it will be immediately copied to the heap and can
4541 -- be reclaimed at once. We create a transient scope around the
4542 -- aggregate for this purpose.
4544 if Ekind
(Current_Scope
) = E_Loop
4545 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
4547 Establish_Transient_Scope
(N
, False);
4550 Insert_Action
(N
, Tmp_Decl
);
4553 -- Construct and insert the aggregate code. We can safely suppress
4554 -- index checks because this code is guaranteed not to raise CE
4555 -- on index checks. However we should *not* suppress all checks.
4561 if Nkind
(Tmp
) = N_Defining_Identifier
then
4562 Target
:= New_Reference_To
(Tmp
, Loc
);
4566 if Has_Default_Init_Comps
(N
) then
4568 -- Ada 2005 (AI-287): This case has not been analyzed???
4570 raise Program_Error
;
4573 -- Name in assignment is explicit dereference
4575 Target
:= New_Copy
(Tmp
);
4579 Build_Array_Aggr_Code
(N
,
4581 Index
=> First_Index
(Typ
),
4583 Scalar_Comp
=> Is_Scalar_Type
(Ctyp
));
4586 if Comes_From_Source
(Tmp
) then
4587 Insert_Actions_After
(Parent
(N
), Aggr_Code
);
4590 Insert_Actions
(N
, Aggr_Code
);
4593 -- If the aggregate has been assigned in place, remove the original
4596 if Nkind
(Parent
(N
)) = N_Assignment_Statement
4597 and then Maybe_In_Place_OK
4599 Rewrite
(Parent
(N
), Make_Null_Statement
(Loc
));
4601 elsif Nkind
(Parent
(N
)) /= N_Object_Declaration
4602 or else Tmp
/= Defining_Identifier
(Parent
(N
))
4604 Rewrite
(N
, New_Occurrence_Of
(Tmp
, Loc
));
4605 Analyze_And_Resolve
(N
, Typ
);
4607 end Expand_Array_Aggregate
;
4609 ------------------------
4610 -- Expand_N_Aggregate --
4611 ------------------------
4613 procedure Expand_N_Aggregate
(N
: Node_Id
) is
4615 if Is_Record_Type
(Etype
(N
)) then
4616 Expand_Record_Aggregate
(N
);
4618 Expand_Array_Aggregate
(N
);
4622 when RE_Not_Available
=>
4624 end Expand_N_Aggregate
;
4626 ----------------------------------
4627 -- Expand_N_Extension_Aggregate --
4628 ----------------------------------
4630 -- If the ancestor part is an expression, add a component association for
4631 -- the parent field. If the type of the ancestor part is not the direct
4632 -- parent of the expected type, build recursively the needed ancestors.
4633 -- If the ancestor part is a subtype_mark, replace aggregate with a decla-
4634 -- ration for a temporary of the expected type, followed by individual
4635 -- assignments to the given components.
4637 procedure Expand_N_Extension_Aggregate
(N
: Node_Id
) is
4638 Loc
: constant Source_Ptr
:= Sloc
(N
);
4639 A
: constant Node_Id
:= Ancestor_Part
(N
);
4640 Typ
: constant Entity_Id
:= Etype
(N
);
4643 -- If the ancestor is a subtype mark, an init proc must be called
4644 -- on the resulting object which thus has to be materialized in
4647 if Is_Entity_Name
(A
) and then Is_Type
(Entity
(A
)) then
4648 Convert_To_Assignments
(N
, Typ
);
4650 -- The extension aggregate is transformed into a record aggregate
4651 -- of the following form (c1 and c2 are inherited components)
4653 -- (Exp with c3 => a, c4 => b)
4654 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b)
4659 -- No tag is needed in the case of Java_VM
4662 Expand_Record_Aggregate
(N
,
4665 Expand_Record_Aggregate
(N
,
4668 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
),
4674 when RE_Not_Available
=>
4676 end Expand_N_Extension_Aggregate
;
4678 -----------------------------
4679 -- Expand_Record_Aggregate --
4680 -----------------------------
4682 procedure Expand_Record_Aggregate
4684 Orig_Tag
: Node_Id
:= Empty
;
4685 Parent_Expr
: Node_Id
:= Empty
)
4687 Loc
: constant Source_Ptr
:= Sloc
(N
);
4688 Comps
: constant List_Id
:= Component_Associations
(N
);
4689 Typ
: constant Entity_Id
:= Etype
(N
);
4690 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
4692 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
return Boolean;
4693 -- Checks the presence of a nested aggregate which needs Late_Expansion
4694 -- or the presence of tagged components which may need tag adjustment.
4696 --------------------------------------------------
4697 -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
4698 --------------------------------------------------
4700 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
return Boolean is
4710 while Present
(C
) loop
4711 if Nkind
(Expression
(C
)) = N_Qualified_Expression
then
4712 Expr_Q
:= Expression
(Expression
(C
));
4714 Expr_Q
:= Expression
(C
);
4717 -- Return true if the aggregate has any associations for
4718 -- tagged components that may require tag adjustment.
4719 -- These are cases where the source expression may have
4720 -- a tag that could differ from the component tag (e.g.,
4721 -- can occur for type conversions and formal parameters).
4722 -- (Tag adjustment is not needed if Java_VM because object
4723 -- tags are implicit in the JVM.)
4725 if Is_Tagged_Type
(Etype
(Expr_Q
))
4726 and then (Nkind
(Expr_Q
) = N_Type_Conversion
4727 or else (Is_Entity_Name
(Expr_Q
)
4728 and then Ekind
(Entity
(Expr_Q
)) in Formal_Kind
))
4729 and then not Java_VM
4734 if Is_Delayed_Aggregate
(Expr_Q
) then
4742 end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
;
4744 -- Remaining Expand_Record_Aggregate variables
4746 Tag_Value
: Node_Id
;
4750 -- Start of processing for Expand_Record_Aggregate
4753 -- If the aggregate is to be assigned to an atomic variable, we
4754 -- have to prevent a piecemeal assignment even if the aggregate
4755 -- is to be expanded. We create a temporary for the aggregate, and
4756 -- assign the temporary instead, so that the back end can generate
4757 -- an atomic move for it.
4760 and then (Nkind
(Parent
(N
)) = N_Object_Declaration
4761 or else Nkind
(Parent
(N
)) = N_Assignment_Statement
)
4762 and then Comes_From_Source
(Parent
(N
))
4764 Expand_Atomic_Aggregate
(N
, Typ
);
4768 -- Gigi doesn't handle properly temporaries of variable size
4769 -- so we generate it in the front-end
4771 if not Size_Known_At_Compile_Time
(Typ
) then
4772 Convert_To_Assignments
(N
, Typ
);
4774 -- Temporaries for controlled aggregates need to be attached to a
4775 -- final chain in order to be properly finalized, so it has to
4776 -- be created in the front-end
4778 elsif Is_Controlled
(Typ
)
4779 or else Has_Controlled_Component
(Base_Type
(Typ
))
4781 Convert_To_Assignments
(N
, Typ
);
4783 -- Ada 2005 (AI-287): In case of default initialized components we
4784 -- convert the aggregate into assignments.
4786 elsif Has_Default_Init_Comps
(N
) then
4787 Convert_To_Assignments
(N
, Typ
);
4789 elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
then
4790 Convert_To_Assignments
(N
, Typ
);
4792 -- If an ancestor is private, some components are not inherited and
4793 -- we cannot expand into a record aggregate
4795 elsif Has_Private_Ancestor
(Typ
) then
4796 Convert_To_Assignments
(N
, Typ
);
4798 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
4799 -- is not able to handle the aggregate for Late_Request.
4801 elsif Is_Tagged_Type
(Typ
) and then Has_Discriminants
(Typ
) then
4802 Convert_To_Assignments
(N
, Typ
);
4804 -- If some components are mutable, the size of the aggregate component
4805 -- may be disctinct from the default size of the type component, so
4806 -- we need to expand to insure that the back-end copies the proper
4807 -- size of the data.
4809 elsif Has_Mutable_Components
(Typ
) then
4810 Convert_To_Assignments
(N
, Typ
);
4812 -- If the type involved has any non-bit aligned components, then
4813 -- we are not sure that the back end can handle this case correctly.
4815 elsif Type_May_Have_Bit_Aligned_Components
(Typ
) then
4816 Convert_To_Assignments
(N
, Typ
);
4818 -- In all other cases we generate a proper aggregate that
4819 -- can be handled by gigi.
4822 -- If no discriminants, nothing special to do
4824 if not Has_Discriminants
(Typ
) then
4827 -- Case of discriminants present
4829 elsif Is_Derived_Type
(Typ
) then
4831 -- For untagged types, non-stored discriminants are replaced
4832 -- with stored discriminants, which are the ones that gigi uses
4833 -- to describe the type and its components.
4835 Generate_Aggregate_For_Derived_Type
: declare
4836 Constraints
: constant List_Id
:= New_List
;
4837 First_Comp
: Node_Id
;
4838 Discriminant
: Entity_Id
;
4840 Num_Disc
: Int
:= 0;
4841 Num_Gird
: Int
:= 0;
4843 procedure Prepend_Stored_Values
(T
: Entity_Id
);
4844 -- Scan the list of stored discriminants of the type, and
4845 -- add their values to the aggregate being built.
4847 ---------------------------
4848 -- Prepend_Stored_Values --
4849 ---------------------------
4851 procedure Prepend_Stored_Values
(T
: Entity_Id
) is
4853 Discriminant
:= First_Stored_Discriminant
(T
);
4855 while Present
(Discriminant
) loop
4857 Make_Component_Association
(Loc
,
4859 New_List
(New_Occurrence_Of
(Discriminant
, Loc
)),
4863 Get_Discriminant_Value
(
4866 Discriminant_Constraint
(Typ
))));
4868 if No
(First_Comp
) then
4869 Prepend_To
(Component_Associations
(N
), New_Comp
);
4871 Insert_After
(First_Comp
, New_Comp
);
4874 First_Comp
:= New_Comp
;
4875 Next_Stored_Discriminant
(Discriminant
);
4877 end Prepend_Stored_Values
;
4879 -- Start of processing for Generate_Aggregate_For_Derived_Type
4882 -- Remove the associations for the discriminant of
4883 -- the derived type.
4885 First_Comp
:= First
(Component_Associations
(N
));
4887 while Present
(First_Comp
) loop
4891 if Ekind
(Entity
(First
(Choices
(Comp
)))) =
4895 Num_Disc
:= Num_Disc
+ 1;
4899 -- Insert stored discriminant associations in the correct
4900 -- order. If there are more stored discriminants than new
4901 -- discriminants, there is at least one new discriminant
4902 -- that constrains more than one of the stored discriminants.
4903 -- In this case we need to construct a proper subtype of
4904 -- the parent type, in order to supply values to all the
4905 -- components. Otherwise there is one-one correspondence
4906 -- between the constraints and the stored discriminants.
4908 First_Comp
:= Empty
;
4910 Discriminant
:= First_Stored_Discriminant
(Base_Type
(Typ
));
4912 while Present
(Discriminant
) loop
4913 Num_Gird
:= Num_Gird
+ 1;
4914 Next_Stored_Discriminant
(Discriminant
);
4917 -- Case of more stored discriminants than new discriminants
4919 if Num_Gird
> Num_Disc
then
4921 -- Create a proper subtype of the parent type, which is
4922 -- the proper implementation type for the aggregate, and
4923 -- convert it to the intended target type.
4925 Discriminant
:= First_Stored_Discriminant
(Base_Type
(Typ
));
4927 while Present
(Discriminant
) loop
4930 Get_Discriminant_Value
(
4933 Discriminant_Constraint
(Typ
)));
4934 Append
(New_Comp
, Constraints
);
4935 Next_Stored_Discriminant
(Discriminant
);
4939 Make_Subtype_Declaration
(Loc
,
4940 Defining_Identifier
=>
4941 Make_Defining_Identifier
(Loc
,
4942 New_Internal_Name
('T')),
4943 Subtype_Indication
=>
4944 Make_Subtype_Indication
(Loc
,
4946 New_Occurrence_Of
(Etype
(Base_Type
(Typ
)), Loc
),
4948 Make_Index_Or_Discriminant_Constraint
4949 (Loc
, Constraints
)));
4951 Insert_Action
(N
, Decl
);
4952 Prepend_Stored_Values
(Base_Type
(Typ
));
4954 Set_Etype
(N
, Defining_Identifier
(Decl
));
4957 Rewrite
(N
, Unchecked_Convert_To
(Typ
, N
));
4960 -- Case where we do not have fewer new discriminants than
4961 -- stored discriminants, so in this case we can simply
4962 -- use the stored discriminants of the subtype.
4965 Prepend_Stored_Values
(Typ
);
4967 end Generate_Aggregate_For_Derived_Type
;
4970 if Is_Tagged_Type
(Typ
) then
4972 -- The tagged case, _parent and _tag component must be created
4974 -- Reset null_present unconditionally. tagged records always have
4975 -- at least one field (the tag or the parent)
4977 Set_Null_Record_Present
(N
, False);
4979 -- When the current aggregate comes from the expansion of an
4980 -- extension aggregate, the parent expr is replaced by an
4981 -- aggregate formed by selected components of this expr
4983 if Present
(Parent_Expr
)
4984 and then Is_Empty_List
(Comps
)
4986 Comp
:= First_Entity
(Typ
);
4987 while Present
(Comp
) loop
4989 -- Skip all entities that aren't discriminants or components
4991 if Ekind
(Comp
) /= E_Discriminant
4992 and then Ekind
(Comp
) /= E_Component
4996 -- Skip all expander-generated components
4999 not Comes_From_Source
(Original_Record_Component
(Comp
))
5005 Make_Selected_Component
(Loc
,
5007 Unchecked_Convert_To
(Typ
,
5008 Duplicate_Subexpr
(Parent_Expr
, True)),
5010 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
5013 Make_Component_Association
(Loc
,
5015 New_List
(New_Occurrence_Of
(Comp
, Loc
)),
5019 Analyze_And_Resolve
(New_Comp
, Etype
(Comp
));
5026 -- Compute the value for the Tag now, if the type is a root it
5027 -- will be included in the aggregate right away, otherwise it will
5028 -- be propagated to the parent aggregate
5030 if Present
(Orig_Tag
) then
5031 Tag_Value
:= Orig_Tag
;
5037 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
5040 -- For a derived type, an aggregate for the parent is formed with
5041 -- all the inherited components.
5043 if Is_Derived_Type
(Typ
) then
5046 First_Comp
: Node_Id
;
5047 Parent_Comps
: List_Id
;
5048 Parent_Aggr
: Node_Id
;
5049 Parent_Name
: Node_Id
;
5052 -- Remove the inherited component association from the
5053 -- aggregate and store them in the parent aggregate
5055 First_Comp
:= First
(Component_Associations
(N
));
5056 Parent_Comps
:= New_List
;
5058 while Present
(First_Comp
)
5059 and then Scope
(Original_Record_Component
(
5060 Entity
(First
(Choices
(First_Comp
))))) /= Base_Typ
5065 Append
(Comp
, Parent_Comps
);
5068 Parent_Aggr
:= Make_Aggregate
(Loc
,
5069 Component_Associations
=> Parent_Comps
);
5070 Set_Etype
(Parent_Aggr
, Etype
(Base_Type
(Typ
)));
5072 -- Find the _parent component
5074 Comp
:= First_Component
(Typ
);
5075 while Chars
(Comp
) /= Name_uParent
loop
5076 Comp
:= Next_Component
(Comp
);
5079 Parent_Name
:= New_Occurrence_Of
(Comp
, Loc
);
5081 -- Insert the parent aggregate
5083 Prepend_To
(Component_Associations
(N
),
5084 Make_Component_Association
(Loc
,
5085 Choices
=> New_List
(Parent_Name
),
5086 Expression
=> Parent_Aggr
));
5088 -- Expand recursively the parent propagating the right Tag
5090 Expand_Record_Aggregate
(
5091 Parent_Aggr
, Tag_Value
, Parent_Expr
);
5094 -- For a root type, the tag component is added (unless compiling
5095 -- for the Java VM, where tags are implicit).
5097 elsif not Java_VM
then
5099 Tag_Name
: constant Node_Id
:=
5101 (First_Tag_Component
(Typ
), Loc
);
5102 Typ_Tag
: constant Entity_Id
:= RTE
(RE_Tag
);
5103 Conv_Node
: constant Node_Id
:=
5104 Unchecked_Convert_To
(Typ_Tag
, Tag_Value
);
5107 Set_Etype
(Conv_Node
, Typ_Tag
);
5108 Prepend_To
(Component_Associations
(N
),
5109 Make_Component_Association
(Loc
,
5110 Choices
=> New_List
(Tag_Name
),
5111 Expression
=> Conv_Node
));
5116 end Expand_Record_Aggregate
;
5118 ----------------------------
5119 -- Has_Default_Init_Comps --
5120 ----------------------------
5122 function Has_Default_Init_Comps
(N
: Node_Id
) return Boolean is
5123 Comps
: constant List_Id
:= Component_Associations
(N
);
5127 pragma Assert
(Nkind
(N
) = N_Aggregate
5128 or else Nkind
(N
) = N_Extension_Aggregate
);
5134 -- Check if any direct component has default initialized components
5137 while Present
(C
) loop
5138 if Box_Present
(C
) then
5145 -- Recursive call in case of aggregate expression
5148 while Present
(C
) loop
5149 Expr
:= Expression
(C
);
5152 and then (Nkind
(Expr
) = N_Aggregate
5153 or else Nkind
(Expr
) = N_Extension_Aggregate
)
5154 and then Has_Default_Init_Comps
(Expr
)
5163 end Has_Default_Init_Comps
;
5165 --------------------------
5166 -- Is_Delayed_Aggregate --
5167 --------------------------
5169 function Is_Delayed_Aggregate
(N
: Node_Id
) return Boolean is
5170 Node
: Node_Id
:= N
;
5171 Kind
: Node_Kind
:= Nkind
(Node
);
5174 if Kind
= N_Qualified_Expression
then
5175 Node
:= Expression
(Node
);
5176 Kind
:= Nkind
(Node
);
5179 if Kind
/= N_Aggregate
and then Kind
/= N_Extension_Aggregate
then
5182 return Expansion_Delayed
(Node
);
5184 end Is_Delayed_Aggregate
;
5186 --------------------
5187 -- Late_Expansion --
5188 --------------------
5190 function Late_Expansion
5194 Flist
: Node_Id
:= Empty
;
5195 Obj
: Entity_Id
:= Empty
) return List_Id
5198 if Is_Record_Type
(Etype
(N
)) then
5199 return Build_Record_Aggr_Code
(N
, Typ
, Target
, Flist
, Obj
);
5201 else pragma Assert
(Is_Array_Type
(Etype
(N
)));
5203 Build_Array_Aggr_Code
5205 Ctype
=> Component_Type
(Etype
(N
)),
5206 Index
=> First_Index
(Typ
),
5208 Scalar_Comp
=> Is_Scalar_Type
(Component_Type
(Typ
)),
5214 ----------------------------------
5215 -- Make_OK_Assignment_Statement --
5216 ----------------------------------
5218 function Make_OK_Assignment_Statement
5221 Expression
: Node_Id
) return Node_Id
5224 Set_Assignment_OK
(Name
);
5225 return Make_Assignment_Statement
(Sloc
, Name
, Expression
);
5226 end Make_OK_Assignment_Statement
;
5228 -----------------------
5229 -- Number_Of_Choices --
5230 -----------------------
5232 function Number_Of_Choices
(N
: Node_Id
) return Nat
is
5236 Nb_Choices
: Nat
:= 0;
5239 if Present
(Expressions
(N
)) then
5243 Assoc
:= First
(Component_Associations
(N
));
5244 while Present
(Assoc
) loop
5246 Choice
:= First
(Choices
(Assoc
));
5247 while Present
(Choice
) loop
5249 if Nkind
(Choice
) /= N_Others_Choice
then
5250 Nb_Choices
:= Nb_Choices
+ 1;
5260 end Number_Of_Choices
;
5262 ------------------------------------
5263 -- Packed_Array_Aggregate_Handled --
5264 ------------------------------------
5266 -- The current version of this procedure will handle at compile time
5267 -- any array aggregate that meets these conditions:
5269 -- One dimensional, bit packed
5270 -- Underlying packed type is modular type
5271 -- Bounds are within 32-bit Int range
5272 -- All bounds and values are static
5274 function Packed_Array_Aggregate_Handled
(N
: Node_Id
) return Boolean is
5275 Loc
: constant Source_Ptr
:= Sloc
(N
);
5276 Typ
: constant Entity_Id
:= Etype
(N
);
5277 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
5279 Not_Handled
: exception;
5280 -- Exception raised if this aggregate cannot be handled
5283 -- For now, handle only one dimensional bit packed arrays
5285 if not Is_Bit_Packed_Array
(Typ
)
5286 or else Number_Dimensions
(Typ
) > 1
5287 or else not Is_Modular_Integer_Type
(Packed_Array_Type
(Typ
))
5293 Csiz
: constant Nat
:= UI_To_Int
(Component_Size
(Typ
));
5297 -- Bounds of index type
5301 -- Values of bounds if compile time known
5303 function Get_Component_Val
(N
: Node_Id
) return Uint
;
5304 -- Given a expression value N of the component type Ctyp, returns
5305 -- A value of Csiz (component size) bits representing this value.
5306 -- If the value is non-static or any other reason exists why the
5307 -- value cannot be returned, then Not_Handled is raised.
5309 -----------------------
5310 -- Get_Component_Val --
5311 -----------------------
5313 function Get_Component_Val
(N
: Node_Id
) return Uint
is
5317 -- We have to analyze the expression here before doing any further
5318 -- processing here. The analysis of such expressions is deferred
5319 -- till expansion to prevent some problems of premature analysis.
5321 Analyze_And_Resolve
(N
, Ctyp
);
5323 -- Must have a compile time value. String literals have to
5324 -- be converted into temporaries as well, because they cannot
5325 -- easily be converted into their bit representation.
5327 if not Compile_Time_Known_Value
(N
)
5328 or else Nkind
(N
) = N_String_Literal
5333 Val
:= Expr_Rep_Value
(N
);
5335 -- Adjust for bias, and strip proper number of bits
5337 if Has_Biased_Representation
(Ctyp
) then
5338 Val
:= Val
- Expr_Value
(Type_Low_Bound
(Ctyp
));
5341 return Val
mod Uint_2
** Csiz
;
5342 end Get_Component_Val
;
5344 -- Here we know we have a one dimensional bit packed array
5347 Get_Index_Bounds
(First_Index
(Typ
), Lo
, Hi
);
5349 -- Cannot do anything if bounds are dynamic
5351 if not Compile_Time_Known_Value
(Lo
)
5353 not Compile_Time_Known_Value
(Hi
)
5358 -- Or are silly out of range of int bounds
5360 Lob
:= Expr_Value
(Lo
);
5361 Hib
:= Expr_Value
(Hi
);
5363 if not UI_Is_In_Int_Range
(Lob
)
5365 not UI_Is_In_Int_Range
(Hib
)
5370 -- At this stage we have a suitable aggregate for handling
5371 -- at compile time (the only remaining checks, are that the
5372 -- values of expressions in the aggregate are compile time
5373 -- known (check performed by Get_Component_Val), and that
5374 -- any subtypes or ranges are statically known.
5376 -- If the aggregate is not fully positional at this stage,
5377 -- then convert it to positional form. Either this will fail,
5378 -- in which case we can do nothing, or it will succeed, in
5379 -- which case we have succeeded in handling the aggregate,
5380 -- or it will stay an aggregate, in which case we have failed
5381 -- to handle this case.
5383 if Present
(Component_Associations
(N
)) then
5384 Convert_To_Positional
5385 (N
, Max_Others_Replicate
=> 64, Handle_Bit_Packed
=> True);
5386 return Nkind
(N
) /= N_Aggregate
;
5389 -- Otherwise we are all positional, so convert to proper value
5392 Lov
: constant Int
:= UI_To_Int
(Lob
);
5393 Hiv
: constant Int
:= UI_To_Int
(Hib
);
5395 Len
: constant Nat
:= Int
'Max (0, Hiv
- Lov
+ 1);
5396 -- The length of the array (number of elements)
5398 Aggregate_Val
: Uint
;
5399 -- Value of aggregate. The value is set in the low order
5400 -- bits of this value. For the little-endian case, the
5401 -- values are stored from low-order to high-order and
5402 -- for the big-endian case the values are stored from
5403 -- high-order to low-order. Note that gigi will take care
5404 -- of the conversions to left justify the value in the big
5405 -- endian case (because of left justified modular type
5406 -- processing), so we do not have to worry about that here.
5409 -- Integer literal for resulting constructed value
5412 -- Shift count from low order for next value
5415 -- Shift increment for loop
5418 -- Next expression from positional parameters of aggregate
5421 -- For little endian, we fill up the low order bits of the
5422 -- target value. For big endian we fill up the high order
5423 -- bits of the target value (which is a left justified
5426 if Bytes_Big_Endian
xor Debug_Flag_8
then
5427 Shift
:= Csiz
* (Len
- 1);
5434 -- Loop to set the values
5437 Aggregate_Val
:= Uint_0
;
5439 Expr
:= First
(Expressions
(N
));
5440 Aggregate_Val
:= Get_Component_Val
(Expr
) * Uint_2
** Shift
;
5442 for J
in 2 .. Len
loop
5443 Shift
:= Shift
+ Incr
;
5446 Aggregate_Val
+ Get_Component_Val
(Expr
) * Uint_2
** Shift
;
5450 -- Now we can rewrite with the proper value
5453 Make_Integer_Literal
(Loc
,
5454 Intval
=> Aggregate_Val
);
5455 Set_Print_In_Hex
(Lit
);
5457 -- Construct the expression using this literal. Note that it is
5458 -- important to qualify the literal with its proper modular type
5459 -- since universal integer does not have the required range and
5460 -- also this is a left justified modular type, which is important
5461 -- in the big-endian case.
5464 Unchecked_Convert_To
(Typ
,
5465 Make_Qualified_Expression
(Loc
,
5467 New_Occurrence_Of
(Packed_Array_Type
(Typ
), Loc
),
5468 Expression
=> Lit
)));
5470 Analyze_And_Resolve
(N
, Typ
);
5478 end Packed_Array_Aggregate_Handled
;
5480 ----------------------------
5481 -- Has_Mutable_Components --
5482 ----------------------------
5484 function Has_Mutable_Components
(Typ
: Entity_Id
) return Boolean is
5488 Comp
:= First_Component
(Typ
);
5490 while Present
(Comp
) loop
5491 if Is_Record_Type
(Etype
(Comp
))
5492 and then Has_Discriminants
(Etype
(Comp
))
5493 and then not Is_Constrained
(Etype
(Comp
))
5498 Next_Component
(Comp
);
5502 end Has_Mutable_Components
;
5504 ------------------------------
5505 -- Initialize_Discriminants --
5506 ------------------------------
5508 procedure Initialize_Discriminants
(N
: Node_Id
; Typ
: Entity_Id
) is
5509 Loc
: constant Source_Ptr
:= Sloc
(N
);
5510 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
5511 Par
: constant Entity_Id
:= Etype
(Bas
);
5512 Decl
: constant Node_Id
:= Parent
(Par
);
5516 if Is_Tagged_Type
(Bas
)
5517 and then Is_Derived_Type
(Bas
)
5518 and then Has_Discriminants
(Par
)
5519 and then Has_Discriminants
(Bas
)
5520 and then Number_Discriminants
(Bas
) /= Number_Discriminants
(Par
)
5521 and then Nkind
(Decl
) = N_Full_Type_Declaration
5522 and then Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
5524 (Variant_Part
(Component_List
(Type_Definition
(Decl
))))
5525 and then Nkind
(N
) /= N_Extension_Aggregate
5528 -- Call init proc to set discriminants.
5529 -- There should eventually be a special procedure for this ???
5531 Ref
:= New_Reference_To
(Defining_Identifier
(N
), Loc
);
5532 Insert_Actions_After
(N
,
5533 Build_Initialization_Call
(Sloc
(N
), Ref
, Typ
));
5535 end Initialize_Discriminants
;
5542 (Obj_Type
: Entity_Id
;
5543 Typ
: Entity_Id
) return Boolean
5545 L1
, L2
, H1
, H2
: Node_Id
;
5547 -- No sliding if the type of the object is not established yet, if
5548 -- it is an unconstrained type whose actual subtype comes from the
5549 -- aggregate, or if the two types are identical.
5551 if not Is_Array_Type
(Obj_Type
) then
5554 elsif not Is_Constrained
(Obj_Type
) then
5557 elsif Typ
= Obj_Type
then
5561 -- Sliding can only occur along the first dimension
5563 Get_Index_Bounds
(First_Index
(Typ
), L1
, H1
);
5564 Get_Index_Bounds
(First_Index
(Obj_Type
), L2
, H2
);
5566 if not Is_Static_Expression
(L1
)
5567 or else not Is_Static_Expression
(L2
)
5568 or else not Is_Static_Expression
(H1
)
5569 or else not Is_Static_Expression
(H2
)
5573 return Expr_Value
(L1
) /= Expr_Value
(L2
)
5574 or else Expr_Value
(H1
) /= Expr_Value
(H2
);
5579 ---------------------------
5580 -- Safe_Slice_Assignment --
5581 ---------------------------
5583 function Safe_Slice_Assignment
(N
: Node_Id
) return Boolean is
5584 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
5585 Pref
: constant Node_Id
:= Prefix
(Name
(Parent
(N
)));
5586 Range_Node
: constant Node_Id
:= Discrete_Range
(Name
(Parent
(N
)));
5594 -- Generate: for J in Range loop Pref (J) := Expr; end loop;
5596 if Comes_From_Source
(N
)
5597 and then No
(Expressions
(N
))
5598 and then Nkind
(First
(Choices
(First
(Component_Associations
(N
)))))
5602 Expression
(First
(Component_Associations
(N
)));
5603 L_J
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
5606 Make_Iteration_Scheme
(Loc
,
5607 Loop_Parameter_Specification
=>
5608 Make_Loop_Parameter_Specification
5610 Defining_Identifier
=> L_J
,
5611 Discrete_Subtype_Definition
=> Relocate_Node
(Range_Node
)));
5614 Make_Assignment_Statement
(Loc
,
5616 Make_Indexed_Component
(Loc
,
5617 Prefix
=> Relocate_Node
(Pref
),
5618 Expressions
=> New_List
(New_Occurrence_Of
(L_J
, Loc
))),
5619 Expression
=> Relocate_Node
(Expr
));
5621 -- Construct the final loop
5624 Make_Implicit_Loop_Statement
5625 (Node
=> Parent
(N
),
5626 Identifier
=> Empty
,
5627 Iteration_Scheme
=> L_Iter
,
5628 Statements
=> New_List
(L_Body
));
5630 -- Set type of aggregate to be type of lhs in assignment,
5631 -- to suppress redundant length checks.
5633 Set_Etype
(N
, Etype
(Name
(Parent
(N
))));
5635 Rewrite
(Parent
(N
), Stat
);
5636 Analyze
(Parent
(N
));
5642 end Safe_Slice_Assignment
;
5644 ---------------------
5645 -- Sort_Case_Table --
5646 ---------------------
5648 procedure Sort_Case_Table
(Case_Table
: in out Case_Table_Type
) is
5649 L
: constant Int
:= Case_Table
'First;
5650 U
: constant Int
:= Case_Table
'Last;
5659 T
:= Case_Table
(K
+ 1);
5663 and then Expr_Value
(Case_Table
(J
- 1).Choice_Lo
) >
5664 Expr_Value
(T
.Choice_Lo
)
5666 Case_Table
(J
) := Case_Table
(J
- 1);
5670 Case_Table
(J
) := T
;
5673 end Sort_Case_Table
;