1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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.
853 if not Present
(Expr
) then
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).
921 if not Present
(Expr
) then
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.
1021 if not Present
(Expr
) then
1023 if Present
(Base_Init_Proc
(Etype
(Ctype
)))
1024 or else Has_Task
(Base_Type
(Ctype
))
1027 Build_Initialization_Call
(Loc
,
1028 Id_Ref
=> Indexed_Comp
,
1030 With_Default_Init
=> True));
1034 -- Now generate the assignment with no associated controlled
1035 -- actions since the target of the assignment may not have
1036 -- been initialized, it is not possible to Finalize it as
1037 -- expected by normal controlled assignment. The rest of the
1038 -- controlled actions are done manually with the proper
1039 -- finalization list coming from the context.
1042 Make_OK_Assignment_Statement
(Loc
,
1043 Name
=> Indexed_Comp
,
1044 Expression
=> New_Copy_Tree
(Expr
));
1046 if Present
(Comp_Type
) and then Controlled_Type
(Comp_Type
) then
1047 Set_No_Ctrl_Actions
(A
);
1049 -- If this is an aggregate for an array of arrays, each
1050 -- subaggregate will be expanded as well, and even with
1051 -- No_Ctrl_Actions the assignments of inner components will
1052 -- require attachment in their assignments to temporaries.
1053 -- These temporaries must be finalized for each subaggregate,
1054 -- to prevent multiple attachments of the same temporary
1055 -- location to same finalization chain (and consequently
1056 -- circular lists). To ensure that finalization takes place
1057 -- for each subaggregate we wrap the assignment in a block.
1059 if Is_Array_Type
(Comp_Type
)
1060 and then Nkind
(Expr
) = N_Aggregate
1063 Make_Block_Statement
(Loc
,
1064 Handled_Statement_Sequence
=>
1065 Make_Handled_Sequence_Of_Statements
(Loc
,
1066 Statements
=> New_List
(A
)));
1072 -- Adjust the tag if tagged (because of possible view
1073 -- conversions), unless compiling for the Java VM
1074 -- where tags are implicit.
1076 if Present
(Comp_Type
)
1077 and then Is_Tagged_Type
(Comp_Type
)
1078 and then not Java_VM
1081 Make_OK_Assignment_Statement
(Loc
,
1083 Make_Selected_Component
(Loc
,
1084 Prefix
=> New_Copy_Tree
(Indexed_Comp
),
1087 (First_Tag_Component
(Comp_Type
), Loc
)),
1090 Unchecked_Convert_To
(RTE
(RE_Tag
),
1092 (Node
(First_Elmt
(Access_Disp_Table
(Comp_Type
))),
1098 -- Adjust and Attach the component to the proper final list
1099 -- which can be the controller of the outer record object or
1100 -- the final list associated with the scope
1102 if Present
(Comp_Type
) and then Controlled_Type
(Comp_Type
) then
1105 Ref
=> New_Copy_Tree
(Indexed_Comp
),
1108 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1112 return Add_Loop_Actions
(L
);
1119 function Gen_Loop
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
is
1123 -- Index_Base'(L) .. Index_Base'(H)
1125 L_Iteration_Scheme
: Node_Id
;
1126 -- L_J in Index_Base'(L) .. Index_Base'(H)
1129 -- The statements to execute in the loop
1131 S
: constant List_Id
:= New_List
;
1132 -- List of statements
1135 -- Copy of expression tree, used for checking purposes
1138 -- If loop bounds define an empty range return the null statement
1140 if Empty_Range
(L
, H
) then
1141 Append_To
(S
, Make_Null_Statement
(Loc
));
1143 -- Ada 2005 (AI-287): Nothing else need to be done in case of
1144 -- default initialized component.
1146 if not Present
(Expr
) then
1150 -- The expression must be type-checked even though no component
1151 -- of the aggregate will have this value. This is done only for
1152 -- actual components of the array, not for subaggregates. Do
1153 -- the check on a copy, because the expression may be shared
1154 -- among several choices, some of which might be non-null.
1156 if Present
(Etype
(N
))
1157 and then Is_Array_Type
(Etype
(N
))
1158 and then No
(Next_Index
(Index
))
1160 Expander_Mode_Save_And_Set
(False);
1161 Tcopy
:= New_Copy_Tree
(Expr
);
1162 Set_Parent
(Tcopy
, N
);
1163 Analyze_And_Resolve
(Tcopy
, Component_Type
(Etype
(N
)));
1164 Expander_Mode_Restore
;
1170 -- If loop bounds are the same then generate an assignment
1172 elsif Equal
(L
, H
) then
1173 return Gen_Assign
(New_Copy_Tree
(L
), Expr
);
1175 -- If H - L <= 2 then generate a sequence of assignments
1176 -- when we are processing the bottom most aggregate and it contains
1177 -- scalar components.
1179 elsif No
(Next_Index
(Index
))
1180 and then Scalar_Comp
1181 and then Local_Compile_Time_Known_Value
(L
)
1182 and then Local_Compile_Time_Known_Value
(H
)
1183 and then Local_Expr_Value
(H
) - Local_Expr_Value
(L
) <= 2
1186 Append_List_To
(S
, Gen_Assign
(New_Copy_Tree
(L
), Expr
));
1187 Append_List_To
(S
, Gen_Assign
(Add
(1, To
=> L
), Expr
));
1189 if Local_Expr_Value
(H
) - Local_Expr_Value
(L
) = 2 then
1190 Append_List_To
(S
, Gen_Assign
(Add
(2, To
=> L
), Expr
));
1196 -- Otherwise construct the loop, starting with the loop index L_J
1198 L_J
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
1200 -- Construct "L .. H"
1205 Low_Bound
=> Make_Qualified_Expression
1207 Subtype_Mark
=> Index_Base_Name
,
1209 High_Bound
=> Make_Qualified_Expression
1211 Subtype_Mark
=> Index_Base_Name
,
1214 -- Construct "for L_J in Index_Base range L .. H"
1216 L_Iteration_Scheme
:=
1217 Make_Iteration_Scheme
1219 Loop_Parameter_Specification
=>
1220 Make_Loop_Parameter_Specification
1222 Defining_Identifier
=> L_J
,
1223 Discrete_Subtype_Definition
=> L_Range
));
1225 -- Construct the statements to execute in the loop body
1227 L_Body
:= Gen_Assign
(New_Reference_To
(L_J
, Loc
), Expr
);
1229 -- Construct the final loop
1231 Append_To
(S
, Make_Implicit_Loop_Statement
1233 Identifier
=> Empty
,
1234 Iteration_Scheme
=> L_Iteration_Scheme
,
1235 Statements
=> L_Body
));
1244 -- The code built is
1246 -- W_J : Index_Base := L;
1247 -- while W_J < H loop
1248 -- W_J := Index_Base'Succ (W);
1252 function Gen_While
(L
, H
: Node_Id
; Expr
: Node_Id
) return List_Id
is
1256 -- W_J : Base_Type := L;
1258 W_Iteration_Scheme
: Node_Id
;
1261 W_Index_Succ
: Node_Id
;
1262 -- Index_Base'Succ (J)
1264 W_Increment
: Node_Id
;
1265 -- W_J := Index_Base'Succ (W)
1267 W_Body
: constant List_Id
:= New_List
;
1268 -- The statements to execute in the loop
1270 S
: constant List_Id
:= New_List
;
1271 -- list of statement
1274 -- If loop bounds define an empty range or are equal return null
1276 if Empty_Range
(L
, H
) or else Equal
(L
, H
) then
1277 Append_To
(S
, Make_Null_Statement
(Loc
));
1281 -- Build the decl of W_J
1283 W_J
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
1285 Make_Object_Declaration
1287 Defining_Identifier
=> W_J
,
1288 Object_Definition
=> Index_Base_Name
,
1291 -- Theoretically we should do a New_Copy_Tree (L) here, but we know
1292 -- that in this particular case L is a fresh Expr generated by
1293 -- Add which we are the only ones to use.
1295 Append_To
(S
, W_Decl
);
1297 -- Construct " while W_J < H"
1299 W_Iteration_Scheme
:=
1300 Make_Iteration_Scheme
1302 Condition
=> Make_Op_Lt
1304 Left_Opnd
=> New_Reference_To
(W_J
, Loc
),
1305 Right_Opnd
=> New_Copy_Tree
(H
)));
1307 -- Construct the statements to execute in the loop body
1310 Make_Attribute_Reference
1312 Prefix
=> Index_Base_Name
,
1313 Attribute_Name
=> Name_Succ
,
1314 Expressions
=> New_List
(New_Reference_To
(W_J
, Loc
)));
1317 Make_OK_Assignment_Statement
1319 Name
=> New_Reference_To
(W_J
, Loc
),
1320 Expression
=> W_Index_Succ
);
1322 Append_To
(W_Body
, W_Increment
);
1323 Append_List_To
(W_Body
,
1324 Gen_Assign
(New_Reference_To
(W_J
, Loc
), Expr
));
1326 -- Construct the final loop
1328 Append_To
(S
, Make_Implicit_Loop_Statement
1330 Identifier
=> Empty
,
1331 Iteration_Scheme
=> W_Iteration_Scheme
,
1332 Statements
=> W_Body
));
1337 ---------------------
1338 -- Index_Base_Name --
1339 ---------------------
1341 function Index_Base_Name
return Node_Id
is
1343 return New_Reference_To
(Index_Base
, Sloc
(N
));
1344 end Index_Base_Name
;
1346 ------------------------------------
1347 -- Local_Compile_Time_Known_Value --
1348 ------------------------------------
1350 function Local_Compile_Time_Known_Value
(E
: Node_Id
) return Boolean is
1352 return Compile_Time_Known_Value
(E
)
1354 (Nkind
(E
) = N_Attribute_Reference
1355 and then Attribute_Name
(E
) = Name_Val
1356 and then Compile_Time_Known_Value
(First
(Expressions
(E
))));
1357 end Local_Compile_Time_Known_Value
;
1359 ----------------------
1360 -- Local_Expr_Value --
1361 ----------------------
1363 function Local_Expr_Value
(E
: Node_Id
) return Uint
is
1365 if Compile_Time_Known_Value
(E
) then
1366 return Expr_Value
(E
);
1368 return Expr_Value
(First
(Expressions
(E
)));
1370 end Local_Expr_Value
;
1372 -- Build_Array_Aggr_Code Variables
1379 Others_Expr
: Node_Id
:= Empty
;
1380 Others_Mbox_Present
: Boolean := False;
1382 Aggr_L
: constant Node_Id
:= Low_Bound
(Aggregate_Bounds
(N
));
1383 Aggr_H
: constant Node_Id
:= High_Bound
(Aggregate_Bounds
(N
));
1384 -- The aggregate bounds of this specific sub-aggregate. Note that if
1385 -- the code generated by Build_Array_Aggr_Code is executed then these
1386 -- bounds are OK. Otherwise a Constraint_Error would have been raised.
1388 Aggr_Low
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Aggr_L
);
1389 Aggr_High
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Aggr_H
);
1390 -- After Duplicate_Subexpr these are side-effect free
1395 Nb_Choices
: Nat
:= 0;
1396 Table
: Case_Table_Type
(1 .. Number_Of_Choices
(N
));
1397 -- Used to sort all the different choice values
1400 -- Number of elements in the positional aggregate
1402 New_Code
: constant List_Id
:= New_List
;
1404 -- Start of processing for Build_Array_Aggr_Code
1407 -- First before we start, a special case. if we have a bit packed
1408 -- array represented as a modular type, then clear the value to
1409 -- zero first, to ensure that unused bits are properly cleared.
1414 and then Is_Bit_Packed_Array
(Typ
)
1415 and then Is_Modular_Integer_Type
(Packed_Array_Type
(Typ
))
1417 Append_To
(New_Code
,
1418 Make_Assignment_Statement
(Loc
,
1419 Name
=> New_Copy_Tree
(Into
),
1421 Unchecked_Convert_To
(Typ
,
1422 Make_Integer_Literal
(Loc
, Uint_0
))));
1426 -- STEP 1: Process component associations
1427 -- For those associations that may generate a loop, initialize
1428 -- Loop_Actions to collect inserted actions that may be crated.
1430 if No
(Expressions
(N
)) then
1432 -- STEP 1 (a): Sort the discrete choices
1434 Assoc
:= First
(Component_Associations
(N
));
1435 while Present
(Assoc
) loop
1436 Choice
:= First
(Choices
(Assoc
));
1437 while Present
(Choice
) loop
1438 if Nkind
(Choice
) = N_Others_Choice
then
1439 Set_Loop_Actions
(Assoc
, New_List
);
1441 if Box_Present
(Assoc
) then
1442 Others_Mbox_Present
:= True;
1444 Others_Expr
:= Expression
(Assoc
);
1449 Get_Index_Bounds
(Choice
, Low
, High
);
1452 Set_Loop_Actions
(Assoc
, New_List
);
1455 Nb_Choices
:= Nb_Choices
+ 1;
1456 if Box_Present
(Assoc
) then
1457 Table
(Nb_Choices
) := (Choice_Lo
=> Low
,
1459 Choice_Node
=> Empty
);
1461 Table
(Nb_Choices
) := (Choice_Lo
=> Low
,
1463 Choice_Node
=> Expression
(Assoc
));
1471 -- If there is more than one set of choices these must be static
1472 -- and we can therefore sort them. Remember that Nb_Choices does not
1473 -- account for an others choice.
1475 if Nb_Choices
> 1 then
1476 Sort_Case_Table
(Table
);
1479 -- STEP 1 (b): take care of the whole set of discrete choices
1481 for J
in 1 .. Nb_Choices
loop
1482 Low
:= Table
(J
).Choice_Lo
;
1483 High
:= Table
(J
).Choice_Hi
;
1484 Expr
:= Table
(J
).Choice_Node
;
1485 Append_List
(Gen_Loop
(Low
, High
, Expr
), To
=> New_Code
);
1488 -- STEP 1 (c): generate the remaining loops to cover others choice
1489 -- We don't need to generate loops over empty gaps, but if there is
1490 -- a single empty range we must analyze the expression for semantics
1492 if Present
(Others_Expr
) or else Others_Mbox_Present
then
1494 First
: Boolean := True;
1497 for J
in 0 .. Nb_Choices
loop
1501 Low
:= Add
(1, To
=> Table
(J
).Choice_Hi
);
1504 if J
= Nb_Choices
then
1507 High
:= Add
(-1, To
=> Table
(J
+ 1).Choice_Lo
);
1510 -- If this is an expansion within an init proc, make
1511 -- sure that discriminant references are replaced by
1512 -- the corresponding discriminal.
1514 if Inside_Init_Proc
then
1515 if Is_Entity_Name
(Low
)
1516 and then Ekind
(Entity
(Low
)) = E_Discriminant
1518 Set_Entity
(Low
, Discriminal
(Entity
(Low
)));
1521 if Is_Entity_Name
(High
)
1522 and then Ekind
(Entity
(High
)) = E_Discriminant
1524 Set_Entity
(High
, Discriminal
(Entity
(High
)));
1529 or else not Empty_Range
(Low
, High
)
1533 (Gen_Loop
(Low
, High
, Others_Expr
), To
=> New_Code
);
1539 -- STEP 2: Process positional components
1542 -- STEP 2 (a): Generate the assignments for each positional element
1543 -- Note that here we have to use Aggr_L rather than Aggr_Low because
1544 -- Aggr_L is analyzed and Add wants an analyzed expression.
1546 Expr
:= First
(Expressions
(N
));
1549 while Present
(Expr
) loop
1550 Nb_Elements
:= Nb_Elements
+ 1;
1551 Append_List
(Gen_Assign
(Add
(Nb_Elements
, To
=> Aggr_L
), Expr
),
1556 -- STEP 2 (b): Generate final loop if an others choice is present
1557 -- Here Nb_Elements gives the offset of the last positional element.
1559 if Present
(Component_Associations
(N
)) then
1560 Assoc
:= Last
(Component_Associations
(N
));
1562 -- Ada 2005 (AI-287)
1564 if Box_Present
(Assoc
) then
1565 Append_List
(Gen_While
(Add
(Nb_Elements
, To
=> Aggr_L
),
1570 Expr
:= Expression
(Assoc
);
1572 Append_List
(Gen_While
(Add
(Nb_Elements
, To
=> Aggr_L
),
1581 end Build_Array_Aggr_Code
;
1583 ----------------------------
1584 -- Build_Record_Aggr_Code --
1585 ----------------------------
1587 function Build_Record_Aggr_Code
1591 Flist
: Node_Id
:= Empty
;
1592 Obj
: Entity_Id
:= Empty
;
1593 Is_Limited_Ancestor_Expansion
: Boolean := False) return List_Id
1595 Loc
: constant Source_Ptr
:= Sloc
(N
);
1596 L
: constant List_Id
:= New_List
;
1597 N_Typ
: constant Entity_Id
:= Etype
(N
);
1603 Comp_Type
: Entity_Id
;
1604 Selector
: Entity_Id
;
1605 Comp_Expr
: Node_Id
;
1608 Internal_Final_List
: Node_Id
;
1610 -- If this is an internal aggregate, the External_Final_List is an
1611 -- expression for the controller record of the enclosing type.
1612 -- If the current aggregate has several controlled components, this
1613 -- expression will appear in several calls to attach to the finali-
1614 -- zation list, and it must not be shared.
1616 External_Final_List
: Node_Id
;
1617 Ancestor_Is_Expression
: Boolean := False;
1618 Ancestor_Is_Subtype_Mark
: Boolean := False;
1620 Init_Typ
: Entity_Id
:= Empty
;
1622 Ctrl_Stuff_Done
: Boolean := False;
1624 function Get_Constraint_Association
(T
: Entity_Id
) return Node_Id
;
1625 -- Returns the first discriminant association in the constraint
1626 -- associated with T, if any, otherwise returns Empty.
1628 function Ancestor_Discriminant_Value
(Disc
: Entity_Id
) return Node_Id
;
1629 -- Returns the value that the given discriminant of an ancestor
1630 -- type should receive (in the absence of a conflict with the
1631 -- value provided by an ancestor part of an extension aggregate).
1633 procedure Check_Ancestor_Discriminants
(Anc_Typ
: Entity_Id
);
1634 -- Check that each of the discriminant values defined by the
1635 -- ancestor part of an extension aggregate match the corresponding
1636 -- values provided by either an association of the aggregate or
1637 -- by the constraint imposed by a parent type (RM95-4.3.2(8)).
1639 function Init_Controller
1644 Init_Pr
: Boolean) return List_Id
;
1645 -- returns the list of statements necessary to initialize the internal
1646 -- controller of the (possible) ancestor typ into target and attach
1647 -- it to finalization list F. Init_Pr conditions the call to the
1648 -- init proc since it may already be done due to ancestor initialization
1650 procedure Gen_Ctrl_Actions_For_Aggr
;
1651 -- Deal with the various controlled type data structure
1654 ---------------------------------
1655 -- Ancestor_Discriminant_Value --
1656 ---------------------------------
1658 function Ancestor_Discriminant_Value
(Disc
: Entity_Id
) return Node_Id
is
1660 Assoc_Elmt
: Elmt_Id
;
1661 Aggr_Comp
: Entity_Id
;
1662 Corresp_Disc
: Entity_Id
;
1663 Current_Typ
: Entity_Id
:= Base_Type
(Typ
);
1664 Parent_Typ
: Entity_Id
;
1665 Parent_Disc
: Entity_Id
;
1666 Save_Assoc
: Node_Id
:= Empty
;
1669 -- First check any discriminant associations to see if
1670 -- any of them provide a value for the discriminant.
1672 if Present
(Discriminant_Specifications
(Parent
(Current_Typ
))) then
1673 Assoc
:= First
(Component_Associations
(N
));
1674 while Present
(Assoc
) loop
1675 Aggr_Comp
:= Entity
(First
(Choices
(Assoc
)));
1677 if Ekind
(Aggr_Comp
) = E_Discriminant
then
1678 Save_Assoc
:= Expression
(Assoc
);
1680 Corresp_Disc
:= Corresponding_Discriminant
(Aggr_Comp
);
1681 while Present
(Corresp_Disc
) loop
1682 -- If found a corresponding discriminant then return
1683 -- the value given in the aggregate. (Note: this is
1684 -- not correct in the presence of side effects. ???)
1686 if Disc
= Corresp_Disc
then
1687 return Duplicate_Subexpr
(Expression
(Assoc
));
1691 Corresponding_Discriminant
(Corresp_Disc
);
1699 -- No match found in aggregate, so chain up parent types to find
1700 -- a constraint that defines the value of the discriminant.
1702 Parent_Typ
:= Etype
(Current_Typ
);
1703 while Current_Typ
/= Parent_Typ
loop
1704 if Has_Discriminants
(Parent_Typ
) then
1705 Parent_Disc
:= First_Discriminant
(Parent_Typ
);
1707 -- We either get the association from the subtype indication
1708 -- of the type definition itself, or from the discriminant
1709 -- constraint associated with the type entity (which is
1710 -- preferable, but it's not always present ???)
1712 if Is_Empty_Elmt_List
(
1713 Discriminant_Constraint
(Current_Typ
))
1715 Assoc
:= Get_Constraint_Association
(Current_Typ
);
1716 Assoc_Elmt
:= No_Elmt
;
1719 First_Elmt
(Discriminant_Constraint
(Current_Typ
));
1720 Assoc
:= Node
(Assoc_Elmt
);
1723 -- Traverse the discriminants of the parent type looking
1724 -- for one that corresponds.
1726 while Present
(Parent_Disc
) and then Present
(Assoc
) loop
1727 Corresp_Disc
:= Parent_Disc
;
1728 while Present
(Corresp_Disc
)
1729 and then Disc
/= Corresp_Disc
1732 Corresponding_Discriminant
(Corresp_Disc
);
1735 if Disc
= Corresp_Disc
then
1736 if Nkind
(Assoc
) = N_Discriminant_Association
then
1737 Assoc
:= Expression
(Assoc
);
1740 -- If the located association directly denotes
1741 -- a discriminant, then use the value of a saved
1742 -- association of the aggregate. This is a kludge
1743 -- to handle certain cases involving multiple
1744 -- discriminants mapped to a single discriminant
1745 -- of a descendant. It's not clear how to locate the
1746 -- appropriate discriminant value for such cases. ???
1748 if Is_Entity_Name
(Assoc
)
1749 and then Ekind
(Entity
(Assoc
)) = E_Discriminant
1751 Assoc
:= Save_Assoc
;
1754 return Duplicate_Subexpr
(Assoc
);
1757 Next_Discriminant
(Parent_Disc
);
1759 if No
(Assoc_Elmt
) then
1762 Next_Elmt
(Assoc_Elmt
);
1763 if Present
(Assoc_Elmt
) then
1764 Assoc
:= Node
(Assoc_Elmt
);
1772 Current_Typ
:= Parent_Typ
;
1773 Parent_Typ
:= Etype
(Current_Typ
);
1776 -- In some cases there's no ancestor value to locate (such as
1777 -- when an ancestor part given by an expression defines the
1778 -- discriminant value).
1781 end Ancestor_Discriminant_Value
;
1783 ----------------------------------
1784 -- Check_Ancestor_Discriminants --
1785 ----------------------------------
1787 procedure Check_Ancestor_Discriminants
(Anc_Typ
: Entity_Id
) is
1788 Discr
: Entity_Id
:= First_Discriminant
(Base_Type
(Anc_Typ
));
1789 Disc_Value
: Node_Id
;
1793 while Present
(Discr
) loop
1794 Disc_Value
:= Ancestor_Discriminant_Value
(Discr
);
1796 if Present
(Disc_Value
) then
1797 Cond
:= Make_Op_Ne
(Loc
,
1799 Make_Selected_Component
(Loc
,
1800 Prefix
=> New_Copy_Tree
(Target
),
1801 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)),
1802 Right_Opnd
=> Disc_Value
);
1805 Make_Raise_Constraint_Error
(Loc
,
1807 Reason
=> CE_Discriminant_Check_Failed
));
1810 Next_Discriminant
(Discr
);
1812 end Check_Ancestor_Discriminants
;
1814 --------------------------------
1815 -- Get_Constraint_Association --
1816 --------------------------------
1818 function Get_Constraint_Association
(T
: Entity_Id
) return Node_Id
is
1819 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(T
));
1820 Indic
: constant Node_Id
:= Subtype_Indication
(Typ_Def
);
1823 -- ??? Also need to cover case of a type mark denoting a subtype
1826 if Nkind
(Indic
) = N_Subtype_Indication
1827 and then Present
(Constraint
(Indic
))
1829 return First
(Constraints
(Constraint
(Indic
)));
1833 end Get_Constraint_Association
;
1835 ---------------------
1836 -- Init_controller --
1837 ---------------------
1839 function Init_Controller
1844 Init_Pr
: Boolean) return List_Id
1846 L
: constant List_Id
:= New_List
;
1852 -- init-proc (target._controller);
1853 -- initialize (target._controller);
1854 -- Attach_to_Final_List (target._controller, F);
1857 Make_Selected_Component
(Loc
,
1858 Prefix
=> Convert_To
(Typ
, New_Copy_Tree
(Target
)),
1859 Selector_Name
=> Make_Identifier
(Loc
, Name_uController
));
1860 Set_Assignment_OK
(Ref
);
1862 -- Ada 2005 (AI-287): Give support to default initialization of
1863 -- limited types and components.
1865 if (Nkind
(Target
) = N_Identifier
1866 and then Present
(Etype
(Target
))
1867 and then Is_Limited_Type
(Etype
(Target
)))
1869 (Nkind
(Target
) = N_Selected_Component
1870 and then Present
(Etype
(Selector_Name
(Target
)))
1871 and then Is_Limited_Type
(Etype
(Selector_Name
(Target
))))
1873 (Nkind
(Target
) = N_Unchecked_Type_Conversion
1874 and then Present
(Etype
(Target
))
1875 and then Is_Limited_Type
(Etype
(Target
)))
1877 (Nkind
(Target
) = N_Unchecked_Expression
1878 and then Nkind
(Expression
(Target
)) = N_Indexed_Component
1879 and then Present
(Etype
(Prefix
(Expression
(Target
))))
1880 and then Is_Limited_Type
(Etype
(Prefix
(Expression
(Target
)))))
1882 RC
:= RE_Limited_Record_Controller
;
1884 RC
:= RE_Record_Controller
;
1889 Build_Initialization_Call
(Loc
,
1892 In_Init_Proc
=> Within_Init_Proc
));
1896 Make_Procedure_Call_Statement
(Loc
,
1899 Find_Prim_Op
(RTE
(RC
), Name_Initialize
), Loc
),
1900 Parameter_Associations
=>
1901 New_List
(New_Copy_Tree
(Ref
))));
1905 Obj_Ref
=> New_Copy_Tree
(Ref
),
1907 With_Attach
=> Attach
));
1910 end Init_Controller
;
1912 -------------------------------
1913 -- Gen_Ctrl_Actions_For_Aggr --
1914 -------------------------------
1916 procedure Gen_Ctrl_Actions_For_Aggr
is
1919 and then Finalize_Storage_Only
(Typ
)
1920 and then (Is_Library_Level_Entity
(Obj
)
1921 or else Entity
(Constant_Value
(RTE
(RE_Garbage_Collected
))) =
1924 Attach
:= Make_Integer_Literal
(Loc
, 0);
1926 elsif Nkind
(Parent
(N
)) = N_Qualified_Expression
1927 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
1929 Attach
:= Make_Integer_Literal
(Loc
, 2);
1932 Attach
:= Make_Integer_Literal
(Loc
, 1);
1935 -- Determine the external finalization list. It is either the
1936 -- finalization list of the outer-scope or the one coming from
1937 -- an outer aggregate. When the target is not a temporary, the
1938 -- proper scope is the scope of the target rather than the
1939 -- potentially transient current scope.
1941 if Controlled_Type
(Typ
) then
1942 if Present
(Flist
) then
1943 External_Final_List
:= New_Copy_Tree
(Flist
);
1945 elsif Is_Entity_Name
(Target
)
1946 and then Present
(Scope
(Entity
(Target
)))
1949 := Find_Final_List
(Scope
(Entity
(Target
)));
1952 External_Final_List
:= Find_Final_List
(Current_Scope
);
1956 External_Final_List
:= Empty
;
1959 -- Initialize and attach the outer object in the is_controlled case
1961 if Is_Controlled
(Typ
) then
1962 if Ancestor_Is_Subtype_Mark
then
1963 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
1964 Set_Assignment_OK
(Ref
);
1966 Make_Procedure_Call_Statement
(Loc
,
1969 (Find_Prim_Op
(Init_Typ
, Name_Initialize
), Loc
),
1970 Parameter_Associations
=> New_List
(New_Copy_Tree
(Ref
))));
1973 if not Has_Controlled_Component
(Typ
) then
1974 Ref
:= New_Copy_Tree
(Target
);
1975 Set_Assignment_OK
(Ref
);
1979 Flist_Ref
=> New_Copy_Tree
(External_Final_List
),
1980 With_Attach
=> Attach
));
1984 -- In the Has_Controlled component case, all the intermediate
1985 -- controllers must be initialized
1987 if Has_Controlled_Component
(Typ
)
1988 and not Is_Limited_Ancestor_Expansion
1991 Inner_Typ
: Entity_Id
;
1992 Outer_Typ
: Entity_Id
;
1997 Outer_Typ
:= Base_Type
(Typ
);
1999 -- Find outer type with a controller
2001 while Outer_Typ
/= Init_Typ
2002 and then not Has_New_Controlled_Component
(Outer_Typ
)
2004 Outer_Typ
:= Etype
(Outer_Typ
);
2007 -- Attach it to the outer record controller to the
2008 -- external final list
2010 if Outer_Typ
= Init_Typ
then
2015 F
=> External_Final_List
,
2020 Inner_Typ
:= Init_Typ
;
2027 F
=> External_Final_List
,
2031 Inner_Typ
:= Etype
(Outer_Typ
);
2033 not Is_Tagged_Type
(Typ
) or else Inner_Typ
= Outer_Typ
;
2036 -- The outer object has to be attached as well
2038 if Is_Controlled
(Typ
) then
2039 Ref
:= New_Copy_Tree
(Target
);
2040 Set_Assignment_OK
(Ref
);
2044 Flist_Ref
=> New_Copy_Tree
(External_Final_List
),
2045 With_Attach
=> New_Copy_Tree
(Attach
)));
2048 -- Initialize the internal controllers for tagged types with
2049 -- more than one controller.
2051 while not At_Root
and then Inner_Typ
/= Init_Typ
loop
2052 if Has_New_Controlled_Component
(Inner_Typ
) then
2054 Make_Selected_Component
(Loc
,
2056 Convert_To
(Outer_Typ
, New_Copy_Tree
(Target
)),
2058 Make_Identifier
(Loc
, Name_uController
));
2060 Make_Selected_Component
(Loc
,
2062 Selector_Name
=> Make_Identifier
(Loc
, Name_F
));
2069 Attach
=> Make_Integer_Literal
(Loc
, 1),
2071 Outer_Typ
:= Inner_Typ
;
2076 At_Root
:= Inner_Typ
= Etype
(Inner_Typ
);
2077 Inner_Typ
:= Etype
(Inner_Typ
);
2080 -- If not done yet attach the controller of the ancestor part
2082 if Outer_Typ
/= Init_Typ
2083 and then Inner_Typ
= Init_Typ
2084 and then Has_Controlled_Component
(Init_Typ
)
2087 Make_Selected_Component
(Loc
,
2088 Prefix
=> Convert_To
(Outer_Typ
, New_Copy_Tree
(Target
)),
2090 Make_Identifier
(Loc
, Name_uController
));
2092 Make_Selected_Component
(Loc
,
2094 Selector_Name
=> Make_Identifier
(Loc
, Name_F
));
2096 Attach
:= Make_Integer_Literal
(Loc
, 1);
2103 Init_Pr
=> Ancestor_Is_Expression
));
2107 end Gen_Ctrl_Actions_For_Aggr
;
2109 -- Start of processing for Build_Record_Aggr_Code
2112 -- Deal with the ancestor part of extension aggregates
2113 -- or with the discriminants of the root type
2115 if Nkind
(N
) = N_Extension_Aggregate
then
2117 A
: constant Node_Id
:= Ancestor_Part
(N
);
2121 -- If the ancestor part is a subtype mark "T", we generate
2123 -- init-proc (T(tmp)); if T is constrained and
2124 -- init-proc (S(tmp)); where S applies an appropriate
2125 -- constraint if T is unconstrained
2127 if Is_Entity_Name
(A
) and then Is_Type
(Entity
(A
)) then
2128 Ancestor_Is_Subtype_Mark
:= True;
2130 if Is_Constrained
(Entity
(A
)) then
2131 Init_Typ
:= Entity
(A
);
2133 -- For an ancestor part given by an unconstrained type
2134 -- mark, create a subtype constrained by appropriate
2135 -- corresponding discriminant values coming from either
2136 -- associations of the aggregate or a constraint on
2137 -- a parent type. The subtype will be used to generate
2138 -- the correct default value for the ancestor part.
2140 elsif Has_Discriminants
(Entity
(A
)) then
2142 Anc_Typ
: constant Entity_Id
:= Entity
(A
);
2143 Anc_Constr
: constant List_Id
:= New_List
;
2144 Discrim
: Entity_Id
;
2145 Disc_Value
: Node_Id
;
2146 New_Indic
: Node_Id
;
2147 Subt_Decl
: Node_Id
;
2150 Discrim
:= First_Discriminant
(Anc_Typ
);
2151 while Present
(Discrim
) loop
2152 Disc_Value
:= Ancestor_Discriminant_Value
(Discrim
);
2153 Append_To
(Anc_Constr
, Disc_Value
);
2154 Next_Discriminant
(Discrim
);
2158 Make_Subtype_Indication
(Loc
,
2159 Subtype_Mark
=> New_Occurrence_Of
(Anc_Typ
, Loc
),
2161 Make_Index_Or_Discriminant_Constraint
(Loc
,
2162 Constraints
=> Anc_Constr
));
2164 Init_Typ
:= Create_Itype
(Ekind
(Anc_Typ
), N
);
2167 Make_Subtype_Declaration
(Loc
,
2168 Defining_Identifier
=> Init_Typ
,
2169 Subtype_Indication
=> New_Indic
);
2171 -- Itypes must be analyzed with checks off
2172 -- Declaration must have a parent for proper
2173 -- handling of subsidiary actions.
2175 Set_Parent
(Subt_Decl
, N
);
2176 Analyze
(Subt_Decl
, Suppress
=> All_Checks
);
2180 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2181 Set_Assignment_OK
(Ref
);
2183 if Has_Default_Init_Comps
(N
)
2184 or else Has_Task
(Base_Type
(Init_Typ
))
2187 Build_Initialization_Call
(Loc
,
2190 In_Init_Proc
=> Within_Init_Proc
,
2191 With_Default_Init
=> True));
2194 Build_Initialization_Call
(Loc
,
2197 In_Init_Proc
=> Within_Init_Proc
));
2200 if Is_Constrained
(Entity
(A
))
2201 and then Has_Discriminants
(Entity
(A
))
2203 Check_Ancestor_Discriminants
(Entity
(A
));
2206 -- Ada 2005 (AI-287): If the ancestor part is a limited type,
2207 -- a recursive call expands the ancestor.
2209 elsif Is_Limited_Type
(Etype
(A
)) then
2210 Ancestor_Is_Expression
:= True;
2213 Build_Record_Aggr_Code
(
2214 N
=> Expression
(A
),
2215 Typ
=> Etype
(Expression
(A
)),
2219 Is_Limited_Ancestor_Expansion
=> True));
2221 -- If the ancestor part is an expression "E", we generate
2225 Ancestor_Is_Expression
:= True;
2226 Init_Typ
:= Etype
(A
);
2228 -- If the ancestor part is an aggregate, force its full
2229 -- expansion, which was delayed.
2231 if Nkind
(A
) = N_Qualified_Expression
2232 and then (Nkind
(Expression
(A
)) = N_Aggregate
2234 Nkind
(Expression
(A
)) = N_Extension_Aggregate
)
2236 Set_Analyzed
(A
, False);
2237 Set_Analyzed
(Expression
(A
), False);
2240 Ref
:= Convert_To
(Init_Typ
, New_Copy_Tree
(Target
));
2241 Set_Assignment_OK
(Ref
);
2243 -- Make the assignment without usual controlled actions since
2244 -- we only want the post adjust but not the pre finalize here
2245 -- Add manual adjust when necessary
2247 Assign
:= New_List
(
2248 Make_OK_Assignment_Statement
(Loc
,
2251 Set_No_Ctrl_Actions
(First
(Assign
));
2253 -- Assign the tag now to make sure that the dispatching call in
2254 -- the subsequent deep_adjust works properly (unless Java_VM,
2255 -- where tags are implicit).
2259 Make_OK_Assignment_Statement
(Loc
,
2261 Make_Selected_Component
(Loc
,
2262 Prefix
=> New_Copy_Tree
(Target
),
2265 (First_Tag_Component
(Base_Type
(Typ
)), Loc
)),
2268 Unchecked_Convert_To
(RTE
(RE_Tag
),
2271 (Access_Disp_Table
(Base_Type
(Typ
)))),
2274 Set_Assignment_OK
(Name
(Instr
));
2275 Append_To
(Assign
, Instr
);
2278 -- Call Adjust manually
2280 if Controlled_Type
(Etype
(A
)) then
2281 Append_List_To
(Assign
,
2283 Ref
=> New_Copy_Tree
(Ref
),
2285 Flist_Ref
=> New_Reference_To
(
2286 RTE
(RE_Global_Final_List
), Loc
),
2287 With_Attach
=> Make_Integer_Literal
(Loc
, 0)));
2291 Make_Unsuppress_Block
(Loc
, Name_Discriminant_Check
, Assign
));
2293 if Has_Discriminants
(Init_Typ
) then
2294 Check_Ancestor_Discriminants
(Init_Typ
);
2299 -- Normal case (not an extension aggregate)
2302 -- Generate the discriminant expressions, component by component.
2303 -- If the base type is an unchecked union, the discriminants are
2304 -- unknown to the back-end and absent from a value of the type, so
2305 -- assignments for them are not emitted.
2307 if Has_Discriminants
(Typ
)
2308 and then not Is_Unchecked_Union
(Base_Type
(Typ
))
2310 -- ??? The discriminants of the object not inherited in the type
2311 -- of the object should be initialized here
2315 -- Generate discriminant init values
2318 Discriminant
: Entity_Id
;
2319 Discriminant_Value
: Node_Id
;
2322 Discriminant
:= First_Stored_Discriminant
(Typ
);
2324 while Present
(Discriminant
) loop
2327 Make_Selected_Component
(Loc
,
2328 Prefix
=> New_Copy_Tree
(Target
),
2329 Selector_Name
=> New_Occurrence_Of
(Discriminant
, Loc
));
2331 Discriminant_Value
:=
2332 Get_Discriminant_Value
(
2335 Discriminant_Constraint
(N_Typ
));
2338 Make_OK_Assignment_Statement
(Loc
,
2340 Expression
=> New_Copy_Tree
(Discriminant_Value
));
2342 Set_No_Ctrl_Actions
(Instr
);
2343 Append_To
(L
, Instr
);
2345 Next_Stored_Discriminant
(Discriminant
);
2351 -- Generate the assignments, component by component
2353 -- tmp.comp1 := Expr1_From_Aggr;
2354 -- tmp.comp2 := Expr2_From_Aggr;
2357 Comp
:= First
(Component_Associations
(N
));
2358 while Present
(Comp
) loop
2359 Selector
:= Entity
(First
(Choices
(Comp
)));
2361 -- Ada 2005 (AI-287): For each default-initialized component genarate
2362 -- a call to the corresponding IP subprogram if available.
2364 if Box_Present
(Comp
)
2365 and then Has_Non_Null_Base_Init_Proc
(Etype
(Selector
))
2367 -- Ada 2005 (AI-287): If the component type has tasks then
2368 -- generate the activation chain and master entities (except
2369 -- in case of an allocator because in that case these entities
2370 -- are generated by Build_Task_Allocate_Block_With_Init_Stmts).
2373 Ctype
: constant Entity_Id
:= Etype
(Selector
);
2374 Inside_Allocator
: Boolean := False;
2375 P
: Node_Id
:= Parent
(N
);
2378 if Is_Task_Type
(Ctype
) or else Has_Task
(Ctype
) then
2379 while Present
(P
) loop
2380 if Nkind
(P
) = N_Allocator
then
2381 Inside_Allocator
:= True;
2388 if not Inside_Init_Proc
and not Inside_Allocator
then
2389 Build_Activation_Chain_Entity
(N
);
2395 Build_Initialization_Call
(Loc
,
2396 Id_Ref
=> Make_Selected_Component
(Loc
,
2397 Prefix
=> New_Copy_Tree
(Target
),
2398 Selector_Name
=> New_Occurrence_Of
(Selector
,
2400 Typ
=> Etype
(Selector
),
2401 With_Default_Init
=> True));
2406 -- Prepare for component assignment
2408 if Ekind
(Selector
) /= E_Discriminant
2409 or else Nkind
(N
) = N_Extension_Aggregate
2412 -- All the discriminants have now been assigned
2413 -- This is now a good moment to initialize and attach all the
2414 -- controllers. Their position may depend on the discriminants.
2416 if Ekind
(Selector
) /= E_Discriminant
2417 and then not Ctrl_Stuff_Done
2419 Gen_Ctrl_Actions_For_Aggr
;
2420 Ctrl_Stuff_Done
:= True;
2423 Comp_Type
:= Etype
(Selector
);
2425 Make_Selected_Component
(Loc
,
2426 Prefix
=> New_Copy_Tree
(Target
),
2427 Selector_Name
=> New_Occurrence_Of
(Selector
, Loc
));
2429 if Nkind
(Expression
(Comp
)) = N_Qualified_Expression
then
2430 Expr_Q
:= Expression
(Expression
(Comp
));
2432 Expr_Q
:= Expression
(Comp
);
2435 -- The controller is the one of the parent type defining
2436 -- the component (in case of inherited components).
2438 if Controlled_Type
(Comp_Type
) then
2439 Internal_Final_List
:=
2440 Make_Selected_Component
(Loc
,
2441 Prefix
=> Convert_To
(
2442 Scope
(Original_Record_Component
(Selector
)),
2443 New_Copy_Tree
(Target
)),
2445 Make_Identifier
(Loc
, Name_uController
));
2447 Internal_Final_List
:=
2448 Make_Selected_Component
(Loc
,
2449 Prefix
=> Internal_Final_List
,
2450 Selector_Name
=> Make_Identifier
(Loc
, Name_F
));
2452 -- The internal final list can be part of a constant object
2454 Set_Assignment_OK
(Internal_Final_List
);
2457 Internal_Final_List
:= Empty
;
2460 -- Now either create the assignment or generate the code for the
2461 -- inner aggregate top-down.
2463 if Is_Delayed_Aggregate
(Expr_Q
) then
2465 Late_Expansion
(Expr_Q
, Comp_Type
, Comp_Expr
,
2466 Internal_Final_List
));
2470 Make_OK_Assignment_Statement
(Loc
,
2472 Expression
=> Expression
(Comp
));
2474 Set_No_Ctrl_Actions
(Instr
);
2475 Append_To
(L
, Instr
);
2477 -- Adjust the tag if tagged (because of possible view
2478 -- conversions), unless compiling for the Java VM
2479 -- where tags are implicit.
2481 -- tmp.comp._tag := comp_typ'tag;
2483 if Is_Tagged_Type
(Comp_Type
) and then not Java_VM
then
2485 Make_OK_Assignment_Statement
(Loc
,
2487 Make_Selected_Component
(Loc
,
2488 Prefix
=> New_Copy_Tree
(Comp_Expr
),
2491 (First_Tag_Component
(Comp_Type
), Loc
)),
2494 Unchecked_Convert_To
(RTE
(RE_Tag
),
2496 (Node
(First_Elmt
(Access_Disp_Table
(Comp_Type
))),
2499 Append_To
(L
, Instr
);
2502 -- Adjust and Attach the component to the proper controller
2503 -- Adjust (tmp.comp);
2504 -- Attach_To_Final_List (tmp.comp,
2505 -- comp_typ (tmp)._record_controller.f)
2507 if Controlled_Type
(Comp_Type
) then
2510 Ref
=> New_Copy_Tree
(Comp_Expr
),
2512 Flist_Ref
=> Internal_Final_List
,
2513 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
2519 elsif Ekind
(Selector
) = E_Discriminant
2520 and then Nkind
(N
) /= N_Extension_Aggregate
2521 and then Nkind
(Parent
(N
)) = N_Component_Association
2522 and then Is_Constrained
(Typ
)
2524 -- We must check that the discriminant value imposed by the
2525 -- context is the same as the value given in the subaggregate,
2526 -- because after the expansion into assignments there is no
2527 -- record on which to perform a regular discriminant check.
2534 D_Val
:= First_Elmt
(Discriminant_Constraint
(Typ
));
2535 Disc
:= First_Discriminant
(Typ
);
2537 while Chars
(Disc
) /= Chars
(Selector
) loop
2538 Next_Discriminant
(Disc
);
2542 pragma Assert
(Present
(D_Val
));
2545 Make_Raise_Constraint_Error
(Loc
,
2548 Left_Opnd
=> New_Copy_Tree
(Node
(D_Val
)),
2549 Right_Opnd
=> Expression
(Comp
)),
2550 Reason
=> CE_Discriminant_Check_Failed
));
2559 -- If the type is tagged, the tag needs to be initialized (unless
2560 -- compiling for the Java VM where tags are implicit). It is done
2561 -- late in the initialization process because in some cases, we call
2562 -- the init proc of an ancestor which will not leave out the right tag
2564 if Ancestor_Is_Expression
then
2567 elsif Is_Tagged_Type
(Typ
) and then not Java_VM
then
2569 Make_OK_Assignment_Statement
(Loc
,
2571 Make_Selected_Component
(Loc
,
2572 Prefix
=> New_Copy_Tree
(Target
),
2575 (First_Tag_Component
(Base_Type
(Typ
)), Loc
)),
2578 Unchecked_Convert_To
(RTE
(RE_Tag
),
2580 (Node
(First_Elmt
(Access_Disp_Table
(Base_Type
(Typ
)))),
2583 Append_To
(L
, Instr
);
2586 -- If the controllers have not been initialized yet (by lack of non-
2587 -- discriminant components), let's do it now.
2589 if not Ctrl_Stuff_Done
then
2590 Gen_Ctrl_Actions_For_Aggr
;
2591 Ctrl_Stuff_Done
:= True;
2595 end Build_Record_Aggr_Code
;
2597 -------------------------------
2598 -- Convert_Aggr_In_Allocator --
2599 -------------------------------
2601 procedure Convert_Aggr_In_Allocator
(Decl
, Aggr
: Node_Id
) is
2602 Loc
: constant Source_Ptr
:= Sloc
(Aggr
);
2603 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2604 Temp
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2606 Occ
: constant Node_Id
:=
2607 Unchecked_Convert_To
(Typ
,
2608 Make_Explicit_Dereference
(Loc
,
2609 New_Reference_To
(Temp
, Loc
)));
2611 Access_Type
: constant Entity_Id
:= Etype
(Temp
);
2614 if Is_Array_Type
(Typ
) then
2615 Convert_Array_Aggr_In_Allocator
(Decl
, Aggr
, Occ
);
2617 elsif Has_Default_Init_Comps
(Aggr
) then
2619 L
: constant List_Id
:= New_List
;
2620 Init_Stmts
: List_Id
;
2623 Init_Stmts
:= Late_Expansion
(Aggr
, Typ
, Occ
,
2624 Find_Final_List
(Access_Type
),
2625 Associated_Final_Chain
(Base_Type
(Access_Type
)));
2627 Build_Task_Allocate_Block_With_Init_Stmts
(L
, Aggr
, Init_Stmts
);
2628 Insert_Actions_After
(Decl
, L
);
2632 Insert_Actions_After
(Decl
,
2633 Late_Expansion
(Aggr
, Typ
, Occ
,
2634 Find_Final_List
(Access_Type
),
2635 Associated_Final_Chain
(Base_Type
(Access_Type
))));
2637 end Convert_Aggr_In_Allocator
;
2639 --------------------------------
2640 -- Convert_Aggr_In_Assignment --
2641 --------------------------------
2643 procedure Convert_Aggr_In_Assignment
(N
: Node_Id
) is
2644 Aggr
: Node_Id
:= Expression
(N
);
2645 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2646 Occ
: constant Node_Id
:= New_Copy_Tree
(Name
(N
));
2649 if Nkind
(Aggr
) = N_Qualified_Expression
then
2650 Aggr
:= Expression
(Aggr
);
2653 Insert_Actions_After
(N
,
2654 Late_Expansion
(Aggr
, Typ
, Occ
,
2655 Find_Final_List
(Typ
, New_Copy_Tree
(Occ
))));
2656 end Convert_Aggr_In_Assignment
;
2658 ---------------------------------
2659 -- Convert_Aggr_In_Object_Decl --
2660 ---------------------------------
2662 procedure Convert_Aggr_In_Object_Decl
(N
: Node_Id
) is
2663 Obj
: constant Entity_Id
:= Defining_Identifier
(N
);
2664 Aggr
: Node_Id
:= Expression
(N
);
2665 Loc
: constant Source_Ptr
:= Sloc
(Aggr
);
2666 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2667 Occ
: constant Node_Id
:= New_Occurrence_Of
(Obj
, Loc
);
2669 function Discriminants_Ok
return Boolean;
2670 -- If the object type is constrained, the discriminants in the
2671 -- aggregate must be checked against the discriminants of the subtype.
2672 -- This cannot be done using Apply_Discriminant_Checks because after
2673 -- expansion there is no aggregate left to check.
2675 ----------------------
2676 -- Discriminants_Ok --
2677 ----------------------
2679 function Discriminants_Ok
return Boolean is
2680 Cond
: Node_Id
:= Empty
;
2689 D
:= First_Discriminant
(Typ
);
2690 Disc1
:= First_Elmt
(Discriminant_Constraint
(Typ
));
2691 Disc2
:= First_Elmt
(Discriminant_Constraint
(Etype
(Obj
)));
2693 while Present
(Disc1
) and then Present
(Disc2
) loop
2694 Val1
:= Node
(Disc1
);
2695 Val2
:= Node
(Disc2
);
2697 if not Is_OK_Static_Expression
(Val1
)
2698 or else not Is_OK_Static_Expression
(Val2
)
2700 Check
:= Make_Op_Ne
(Loc
,
2701 Left_Opnd
=> Duplicate_Subexpr
(Val1
),
2702 Right_Opnd
=> Duplicate_Subexpr
(Val2
));
2708 Cond
:= Make_Or_Else
(Loc
,
2710 Right_Opnd
=> Check
);
2713 elsif Expr_Value
(Val1
) /= Expr_Value
(Val2
) then
2714 Apply_Compile_Time_Constraint_Error
(Aggr
,
2715 Msg
=> "incorrect value for discriminant&?",
2716 Reason
=> CE_Discriminant_Check_Failed
,
2721 Next_Discriminant
(D
);
2726 -- If any discriminant constraint is non-static, emit a check
2728 if Present
(Cond
) then
2730 Make_Raise_Constraint_Error
(Loc
,
2732 Reason
=> CE_Discriminant_Check_Failed
));
2736 end Discriminants_Ok
;
2738 -- Start of processing for Convert_Aggr_In_Object_Decl
2741 Set_Assignment_OK
(Occ
);
2743 if Nkind
(Aggr
) = N_Qualified_Expression
then
2744 Aggr
:= Expression
(Aggr
);
2747 if Has_Discriminants
(Typ
)
2748 and then Typ
/= Etype
(Obj
)
2749 and then Is_Constrained
(Etype
(Obj
))
2750 and then not Discriminants_Ok
2755 if Requires_Transient_Scope
(Typ
) then
2756 Establish_Transient_Scope
(Aggr
, Sec_Stack
=>
2757 Is_Controlled
(Typ
) or else Has_Controlled_Component
(Typ
));
2760 Insert_Actions_After
(N
, Late_Expansion
(Aggr
, Typ
, Occ
, Obj
=> Obj
));
2761 Set_No_Initialization
(N
);
2762 Initialize_Discriminants
(N
, Typ
);
2763 end Convert_Aggr_In_Object_Decl
;
2765 -------------------------------------
2766 -- Convert_array_Aggr_In_Allocator --
2767 -------------------------------------
2769 procedure Convert_Array_Aggr_In_Allocator
2774 Aggr_Code
: List_Id
;
2775 Typ
: constant Entity_Id
:= Etype
(Aggr
);
2776 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
2779 -- The target is an explicit dereference of the allocated object.
2780 -- Generate component assignments to it, as for an aggregate that
2781 -- appears on the right-hand side of an assignment statement.
2784 Build_Array_Aggr_Code
(Aggr
,
2786 Index
=> First_Index
(Typ
),
2788 Scalar_Comp
=> Is_Scalar_Type
(Ctyp
));
2790 Insert_Actions_After
(Decl
, Aggr_Code
);
2791 end Convert_Array_Aggr_In_Allocator
;
2793 ----------------------------
2794 -- Convert_To_Assignments --
2795 ----------------------------
2797 procedure Convert_To_Assignments
(N
: Node_Id
; Typ
: Entity_Id
) is
2798 Loc
: constant Source_Ptr
:= Sloc
(N
);
2802 Target_Expr
: Node_Id
;
2803 Parent_Kind
: Node_Kind
;
2804 Unc_Decl
: Boolean := False;
2805 Parent_Node
: Node_Id
;
2808 Parent_Node
:= Parent
(N
);
2809 Parent_Kind
:= Nkind
(Parent_Node
);
2811 if Parent_Kind
= N_Qualified_Expression
then
2813 -- Check if we are in a unconstrained declaration because in this
2814 -- case the current delayed expansion mechanism doesn't work when
2815 -- the declared object size depend on the initializing expr.
2818 Parent_Node
:= Parent
(Parent_Node
);
2819 Parent_Kind
:= Nkind
(Parent_Node
);
2821 if Parent_Kind
= N_Object_Declaration
then
2823 not Is_Entity_Name
(Object_Definition
(Parent_Node
))
2824 or else Has_Discriminants
2825 (Entity
(Object_Definition
(Parent_Node
)))
2826 or else Is_Class_Wide_Type
2827 (Entity
(Object_Definition
(Parent_Node
)));
2832 -- Just set the Delay flag in the following cases where the
2833 -- transformation will be done top down from above
2835 -- - internal aggregate (transformed when expanding the parent)
2836 -- - allocators (see Convert_Aggr_In_Allocator)
2837 -- - object decl (see Convert_Aggr_In_Object_Decl)
2838 -- - safe assignments (see Convert_Aggr_Assignments)
2839 -- so far only the assignments in the init procs are taken
2842 if Parent_Kind
= N_Aggregate
2843 or else Parent_Kind
= N_Extension_Aggregate
2844 or else Parent_Kind
= N_Component_Association
2845 or else Parent_Kind
= N_Allocator
2846 or else (Parent_Kind
= N_Object_Declaration
and then not Unc_Decl
)
2847 or else (Parent_Kind
= N_Assignment_Statement
2848 and then Inside_Init_Proc
)
2850 Set_Expansion_Delayed
(N
);
2854 if Requires_Transient_Scope
(Typ
) then
2855 Establish_Transient_Scope
(N
, Sec_Stack
=>
2856 Is_Controlled
(Typ
) or else Has_Controlled_Component
(Typ
));
2859 -- Create the temporary
2861 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
2864 Make_Object_Declaration
(Loc
,
2865 Defining_Identifier
=> Temp
,
2866 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
2868 Set_No_Initialization
(Instr
);
2869 Insert_Action
(N
, Instr
);
2870 Initialize_Discriminants
(Instr
, Typ
);
2871 Target_Expr
:= New_Occurrence_Of
(Temp
, Loc
);
2873 Insert_Actions
(N
, Build_Record_Aggr_Code
(N
, Typ
, Target_Expr
));
2874 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
2875 Analyze_And_Resolve
(N
, Typ
);
2876 end Convert_To_Assignments
;
2878 ---------------------------
2879 -- Convert_To_Positional --
2880 ---------------------------
2882 procedure Convert_To_Positional
2884 Max_Others_Replicate
: Nat
:= 5;
2885 Handle_Bit_Packed
: Boolean := False)
2887 Typ
: constant Entity_Id
:= Etype
(N
);
2892 Ixb
: Node_Id
) return Boolean;
2893 -- Convert the aggregate into a purely positional form if possible.
2894 -- On entry the bounds of all dimensions are known to be static,
2895 -- and the total number of components is safe enough to expand.
2897 function Is_Flat
(N
: Node_Id
; Dims
: Int
) return Boolean;
2898 -- Return True iff the array N is flat (which is not rivial
2899 -- in the case of multidimensionsl aggregates).
2908 Ixb
: Node_Id
) return Boolean
2910 Loc
: constant Source_Ptr
:= Sloc
(N
);
2911 Blo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Ixb
));
2912 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Ix
));
2913 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Ix
));
2918 if Nkind
(Original_Node
(N
)) = N_String_Literal
then
2922 -- Only handle bounds starting at the base type low bound
2923 -- for now since the compiler isn't able to handle different low
2924 -- bounds yet. Case such as new String'(3..5 => ' ') will get
2925 -- the wrong bounds, though it seems that the aggregate should
2926 -- retain the bounds set on its Etype (see C64103E and CC1311B).
2928 Lov
:= Expr_Value
(Lo
);
2929 Hiv
:= Expr_Value
(Hi
);
2932 or else not Compile_Time_Known_Value
(Blo
)
2933 or else (Lov
/= Expr_Value
(Blo
))
2938 -- Determine if set of alternatives is suitable for conversion
2939 -- and build an array containing the values in sequence.
2942 Vals
: array (UI_To_Int
(Lov
) .. UI_To_Int
(Hiv
))
2943 of Node_Id
:= (others => Empty
);
2944 -- The values in the aggregate sorted appropriately
2947 -- Same data as Vals in list form
2950 -- Used to validate Max_Others_Replicate limit
2953 Num
: Int
:= UI_To_Int
(Lov
);
2958 if Present
(Expressions
(N
)) then
2959 Elmt
:= First
(Expressions
(N
));
2961 while Present
(Elmt
) loop
2962 if Nkind
(Elmt
) = N_Aggregate
2963 and then Present
(Next_Index
(Ix
))
2965 not Flatten
(Elmt
, Next_Index
(Ix
), Next_Index
(Ixb
))
2970 Vals
(Num
) := Relocate_Node
(Elmt
);
2977 if No
(Component_Associations
(N
)) then
2981 Elmt
:= First
(Component_Associations
(N
));
2983 if Nkind
(Expression
(Elmt
)) = N_Aggregate
then
2984 if Present
(Next_Index
(Ix
))
2987 (Expression
(Elmt
), Next_Index
(Ix
), Next_Index
(Ixb
))
2993 Component_Loop
: while Present
(Elmt
) loop
2994 Choice
:= First
(Choices
(Elmt
));
2995 Choice_Loop
: while Present
(Choice
) loop
2997 -- If we have an others choice, fill in the missing elements
2998 -- subject to the limit established by Max_Others_Replicate.
3000 if Nkind
(Choice
) = N_Others_Choice
then
3003 for J
in Vals
'Range loop
3004 if No
(Vals
(J
)) then
3005 Vals
(J
) := New_Copy_Tree
(Expression
(Elmt
));
3006 Rep_Count
:= Rep_Count
+ 1;
3008 -- Check for maximum others replication. Note that
3009 -- we skip this test if either of the restrictions
3010 -- No_Elaboration_Code or No_Implicit_Loops is
3011 -- active, or if this is a preelaborable unit.
3014 P
: constant Entity_Id
:=
3015 Cunit_Entity
(Current_Sem_Unit
);
3018 if Restriction_Active
(No_Elaboration_Code
)
3019 or else Restriction_Active
(No_Implicit_Loops
)
3020 or else Is_Preelaborated
(P
)
3021 or else (Ekind
(P
) = E_Package_Body
3023 Is_Preelaborated
(Spec_Entity
(P
)))
3027 elsif Rep_Count
> Max_Others_Replicate
then
3034 exit Component_Loop
;
3036 -- Case of a subtype mark
3038 elsif Nkind
(Choice
) = N_Identifier
3039 and then Is_Type
(Entity
(Choice
))
3041 Lo
:= Type_Low_Bound
(Etype
(Choice
));
3042 Hi
:= Type_High_Bound
(Etype
(Choice
));
3044 -- Case of subtype indication
3046 elsif Nkind
(Choice
) = N_Subtype_Indication
then
3047 Lo
:= Low_Bound
(Range_Expression
(Constraint
(Choice
)));
3048 Hi
:= High_Bound
(Range_Expression
(Constraint
(Choice
)));
3052 elsif Nkind
(Choice
) = N_Range
then
3053 Lo
:= Low_Bound
(Choice
);
3054 Hi
:= High_Bound
(Choice
);
3056 -- Normal subexpression case
3058 else pragma Assert
(Nkind
(Choice
) in N_Subexpr
);
3059 if not Compile_Time_Known_Value
(Choice
) then
3063 Vals
(UI_To_Int
(Expr_Value
(Choice
))) :=
3064 New_Copy_Tree
(Expression
(Elmt
));
3069 -- Range cases merge with Lo,Hi said
3071 if not Compile_Time_Known_Value
(Lo
)
3073 not Compile_Time_Known_Value
(Hi
)
3077 for J
in UI_To_Int
(Expr_Value
(Lo
)) ..
3078 UI_To_Int
(Expr_Value
(Hi
))
3080 Vals
(J
) := New_Copy_Tree
(Expression
(Elmt
));
3086 end loop Choice_Loop
;
3089 end loop Component_Loop
;
3091 -- If we get here the conversion is possible
3094 for J
in Vals
'Range loop
3095 Append
(Vals
(J
), Vlist
);
3098 Rewrite
(N
, Make_Aggregate
(Loc
, Expressions
=> Vlist
));
3099 Set_Aggregate_Bounds
(N
, Aggregate_Bounds
(Original_Node
(N
)));
3108 function Is_Flat
(N
: Node_Id
; Dims
: Int
) return Boolean is
3115 elsif Nkind
(N
) = N_Aggregate
then
3116 if Present
(Component_Associations
(N
)) then
3120 Elmt
:= First
(Expressions
(N
));
3122 while Present
(Elmt
) loop
3123 if not Is_Flat
(Elmt
, Dims
- 1) then
3137 -- Start of processing for Convert_To_Positional
3140 -- Ada 2005 (AI-287): Do not convert in case of default initialized
3141 -- components because in this case will need to call the corresponding
3144 if Has_Default_Init_Comps
(N
) then
3148 if Is_Flat
(N
, Number_Dimensions
(Typ
)) then
3152 if Is_Bit_Packed_Array
(Typ
)
3153 and then not Handle_Bit_Packed
3158 -- Do not convert to positional if controlled components are
3159 -- involved since these require special processing
3161 if Has_Controlled_Component
(Typ
) then
3165 if Aggr_Size_OK
(Typ
)
3167 Flatten
(N
, First_Index
(Typ
), First_Index
(Base_Type
(Typ
)))
3169 Analyze_And_Resolve
(N
, Typ
);
3171 end Convert_To_Positional
;
3173 ----------------------------
3174 -- Expand_Array_Aggregate --
3175 ----------------------------
3177 -- Array aggregate expansion proceeds as follows:
3179 -- 1. If requested we generate code to perform all the array aggregate
3180 -- bound checks, specifically
3182 -- (a) Check that the index range defined by aggregate bounds is
3183 -- compatible with corresponding index subtype.
3185 -- (b) If an others choice is present check that no aggregate
3186 -- index is outside the bounds of the index constraint.
3188 -- (c) For multidimensional arrays make sure that all subaggregates
3189 -- corresponding to the same dimension have the same bounds.
3191 -- 2. Check for packed array aggregate which can be converted to a
3192 -- constant so that the aggregate disappeares completely.
3194 -- 3. Check case of nested aggregate. Generally nested aggregates are
3195 -- handled during the processing of the parent aggregate.
3197 -- 4. Check if the aggregate can be statically processed. If this is the
3198 -- case pass it as is to Gigi. Note that a necessary condition for
3199 -- static processing is that the aggregate be fully positional.
3201 -- 5. If in place aggregate expansion is possible (i.e. no need to create
3202 -- a temporary) then mark the aggregate as such and return. Otherwise
3203 -- create a new temporary and generate the appropriate initialization
3206 procedure Expand_Array_Aggregate
(N
: Node_Id
) is
3207 Loc
: constant Source_Ptr
:= Sloc
(N
);
3209 Typ
: constant Entity_Id
:= Etype
(N
);
3210 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
3211 -- Typ is the correct constrained array subtype of the aggregate
3212 -- Ctyp is the corresponding component type.
3214 Aggr_Dimension
: constant Pos
:= Number_Dimensions
(Typ
);
3215 -- Number of aggregate index dimensions
3217 Aggr_Low
: array (1 .. Aggr_Dimension
) of Node_Id
;
3218 Aggr_High
: array (1 .. Aggr_Dimension
) of Node_Id
;
3219 -- Low and High bounds of the constraint for each aggregate index
3221 Aggr_Index_Typ
: array (1 .. Aggr_Dimension
) of Entity_Id
;
3222 -- The type of each index
3224 Maybe_In_Place_OK
: Boolean;
3225 -- If the type is neither controlled nor packed and the aggregate
3226 -- is the expression in an assignment, assignment in place may be
3227 -- possible, provided other conditions are met on the LHS.
3229 Others_Present
: array (1 .. Aggr_Dimension
) of Boolean :=
3231 -- If Others_Present (J) is True, then there is an others choice
3232 -- in one of the sub-aggregates of N at dimension J.
3234 procedure Build_Constrained_Type
(Positional
: Boolean);
3235 -- If the subtype is not static or unconstrained, build a constrained
3236 -- type using the computable sizes of the aggregate and its sub-
3239 procedure Check_Bounds
(Aggr_Bounds
: Node_Id
; Index_Bounds
: Node_Id
);
3240 -- Checks that the bounds of Aggr_Bounds are within the bounds defined
3243 procedure Check_Same_Aggr_Bounds
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3244 -- Checks that in a multi-dimensional array aggregate all subaggregates
3245 -- corresponding to the same dimension have the same bounds.
3246 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3247 -- corresponding to the sub-aggregate.
3249 procedure Compute_Others_Present
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3250 -- Computes the values of array Others_Present. Sub_Aggr is the
3251 -- array sub-aggregate we start the computation from. Dim is the
3252 -- dimension corresponding to the sub-aggregate.
3254 function Has_Address_Clause
(D
: Node_Id
) return Boolean;
3255 -- If the aggregate is the expression in an object declaration, it
3256 -- cannot be expanded in place. This function does a lookahead in the
3257 -- current declarative part to find an address clause for the object
3260 function In_Place_Assign_OK
return Boolean;
3261 -- Simple predicate to determine whether an aggregate assignment can
3262 -- be done in place, because none of the new values can depend on the
3263 -- components of the target of the assignment.
3265 procedure Others_Check
(Sub_Aggr
: Node_Id
; Dim
: Pos
);
3266 -- Checks that if an others choice is present in any sub-aggregate no
3267 -- aggregate index is outside the bounds of the index constraint.
3268 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3269 -- corresponding to the sub-aggregate.
3271 ----------------------------
3272 -- Build_Constrained_Type --
3273 ----------------------------
3275 procedure Build_Constrained_Type
(Positional
: Boolean) is
3276 Loc
: constant Source_Ptr
:= Sloc
(N
);
3277 Agg_Type
: Entity_Id
;
3280 Typ
: constant Entity_Id
:= Etype
(N
);
3281 Indices
: constant List_Id
:= New_List
;
3287 Make_Defining_Identifier
(
3288 Loc
, New_Internal_Name
('A'));
3290 -- If the aggregate is purely positional, all its subaggregates
3291 -- have the same size. We collect the dimensions from the first
3292 -- subaggregate at each level.
3297 for D
in 1 .. Number_Dimensions
(Typ
) loop
3298 Comp
:= First
(Expressions
(Sub_Agg
));
3303 while Present
(Comp
) loop
3310 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
3312 Make_Integer_Literal
(Loc
, Num
)),
3317 -- We know the aggregate type is unconstrained and the
3318 -- aggregate is not processable by the back end, therefore
3319 -- not necessarily positional. Retrieve the bounds of each
3320 -- dimension as computed earlier.
3322 for D
in 1 .. Number_Dimensions
(Typ
) loop
3325 Low_Bound
=> Aggr_Low
(D
),
3326 High_Bound
=> Aggr_High
(D
)),
3332 Make_Full_Type_Declaration
(Loc
,
3333 Defining_Identifier
=> Agg_Type
,
3335 Make_Constrained_Array_Definition
(Loc
,
3336 Discrete_Subtype_Definitions
=> Indices
,
3337 Component_Definition
=>
3338 Make_Component_Definition
(Loc
,
3339 Aliased_Present
=> False,
3340 Subtype_Indication
=>
3341 New_Occurrence_Of
(Component_Type
(Typ
), Loc
))));
3343 Insert_Action
(N
, Decl
);
3345 Set_Etype
(N
, Agg_Type
);
3346 Set_Is_Itype
(Agg_Type
);
3347 Freeze_Itype
(Agg_Type
, N
);
3348 end Build_Constrained_Type
;
3354 procedure Check_Bounds
(Aggr_Bounds
: Node_Id
; Index_Bounds
: Node_Id
) is
3361 Cond
: Node_Id
:= Empty
;
3364 Get_Index_Bounds
(Aggr_Bounds
, Aggr_Lo
, Aggr_Hi
);
3365 Get_Index_Bounds
(Index_Bounds
, Ind_Lo
, Ind_Hi
);
3367 -- Generate the following test:
3369 -- [constraint_error when
3370 -- Aggr_Lo <= Aggr_Hi and then
3371 -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
3373 -- As an optimization try to see if some tests are trivially vacuos
3374 -- because we are comparing an expression against itself.
3376 if Aggr_Lo
= Ind_Lo
and then Aggr_Hi
= Ind_Hi
then
3379 elsif Aggr_Hi
= Ind_Hi
then
3382 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3383 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Lo
));
3385 elsif Aggr_Lo
= Ind_Lo
then
3388 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
),
3389 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Hi
));
3396 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3397 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ind_Lo
)),
3401 Left_Opnd
=> Duplicate_Subexpr
(Aggr_Hi
),
3402 Right_Opnd
=> Duplicate_Subexpr
(Ind_Hi
)));
3405 if Present
(Cond
) then
3410 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3411 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
)),
3413 Right_Opnd
=> Cond
);
3415 Set_Analyzed
(Left_Opnd
(Left_Opnd
(Cond
)), False);
3416 Set_Analyzed
(Right_Opnd
(Left_Opnd
(Cond
)), False);
3418 Make_Raise_Constraint_Error
(Loc
,
3420 Reason
=> CE_Length_Check_Failed
));
3424 ----------------------------
3425 -- Check_Same_Aggr_Bounds --
3426 ----------------------------
3428 procedure Check_Same_Aggr_Bounds
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
3429 Sub_Lo
: constant Node_Id
:= Low_Bound
(Aggregate_Bounds
(Sub_Aggr
));
3430 Sub_Hi
: constant Node_Id
:= High_Bound
(Aggregate_Bounds
(Sub_Aggr
));
3431 -- The bounds of this specific sub-aggregate
3433 Aggr_Lo
: constant Node_Id
:= Aggr_Low
(Dim
);
3434 Aggr_Hi
: constant Node_Id
:= Aggr_High
(Dim
);
3435 -- The bounds of the aggregate for this dimension
3437 Ind_Typ
: constant Entity_Id
:= Aggr_Index_Typ
(Dim
);
3438 -- The index type for this dimension.xxx
3440 Cond
: Node_Id
:= Empty
;
3446 -- If index checks are on generate the test
3448 -- [constraint_error when
3449 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
3451 -- As an optimization try to see if some tests are trivially vacuos
3452 -- because we are comparing an expression against itself. Also for
3453 -- the first dimension the test is trivially vacuous because there
3454 -- is just one aggregate for dimension 1.
3456 if Index_Checks_Suppressed
(Ind_Typ
) then
3460 or else (Aggr_Lo
= Sub_Lo
and then Aggr_Hi
= Sub_Hi
)
3464 elsif Aggr_Hi
= Sub_Hi
then
3467 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3468 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Lo
));
3470 elsif Aggr_Lo
= Sub_Lo
then
3473 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Hi
),
3474 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Hi
));
3481 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Aggr_Lo
),
3482 Right_Opnd
=> Duplicate_Subexpr_Move_Checks
(Sub_Lo
)),
3486 Left_Opnd
=> Duplicate_Subexpr
(Aggr_Hi
),
3487 Right_Opnd
=> Duplicate_Subexpr
(Sub_Hi
)));
3490 if Present
(Cond
) then
3492 Make_Raise_Constraint_Error
(Loc
,
3494 Reason
=> CE_Length_Check_Failed
));
3497 -- Now look inside the sub-aggregate to see if there is more work
3499 if Dim
< Aggr_Dimension
then
3501 -- Process positional components
3503 if Present
(Expressions
(Sub_Aggr
)) then
3504 Expr
:= First
(Expressions
(Sub_Aggr
));
3505 while Present
(Expr
) loop
3506 Check_Same_Aggr_Bounds
(Expr
, Dim
+ 1);
3511 -- Process component associations
3513 if Present
(Component_Associations
(Sub_Aggr
)) then
3514 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
3515 while Present
(Assoc
) loop
3516 Expr
:= Expression
(Assoc
);
3517 Check_Same_Aggr_Bounds
(Expr
, Dim
+ 1);
3522 end Check_Same_Aggr_Bounds
;
3524 ----------------------------
3525 -- Compute_Others_Present --
3526 ----------------------------
3528 procedure Compute_Others_Present
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
3533 if Present
(Component_Associations
(Sub_Aggr
)) then
3534 Assoc
:= Last
(Component_Associations
(Sub_Aggr
));
3536 if Nkind
(First
(Choices
(Assoc
))) = N_Others_Choice
then
3537 Others_Present
(Dim
) := True;
3541 -- Now look inside the sub-aggregate to see if there is more work
3543 if Dim
< Aggr_Dimension
then
3545 -- Process positional components
3547 if Present
(Expressions
(Sub_Aggr
)) then
3548 Expr
:= First
(Expressions
(Sub_Aggr
));
3549 while Present
(Expr
) loop
3550 Compute_Others_Present
(Expr
, Dim
+ 1);
3555 -- Process component associations
3557 if Present
(Component_Associations
(Sub_Aggr
)) then
3558 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
3559 while Present
(Assoc
) loop
3560 Expr
:= Expression
(Assoc
);
3561 Compute_Others_Present
(Expr
, Dim
+ 1);
3566 end Compute_Others_Present
;
3568 ------------------------
3569 -- Has_Address_Clause --
3570 ------------------------
3572 function Has_Address_Clause
(D
: Node_Id
) return Boolean is
3573 Id
: constant Entity_Id
:= Defining_Identifier
(D
);
3574 Decl
: Node_Id
:= Next
(D
);
3577 while Present
(Decl
) loop
3578 if Nkind
(Decl
) = N_At_Clause
3579 and then Chars
(Identifier
(Decl
)) = Chars
(Id
)
3583 elsif Nkind
(Decl
) = N_Attribute_Definition_Clause
3584 and then Chars
(Decl
) = Name_Address
3585 and then Chars
(Name
(Decl
)) = Chars
(Id
)
3594 end Has_Address_Clause
;
3596 ------------------------
3597 -- In_Place_Assign_OK --
3598 ------------------------
3600 function In_Place_Assign_OK
return Boolean is
3608 function Is_Others_Aggregate
(Aggr
: Node_Id
) return Boolean;
3609 -- Aggregates that consist of a single Others choice are safe
3610 -- if the single expression is.
3612 function Safe_Aggregate
(Aggr
: Node_Id
) return Boolean;
3613 -- Check recursively that each component of a (sub)aggregate does
3614 -- not depend on the variable being assigned to.
3616 function Safe_Component
(Expr
: Node_Id
) return Boolean;
3617 -- Verify that an expression cannot depend on the variable being
3618 -- assigned to. Room for improvement here (but less than before).
3620 -------------------------
3621 -- Is_Others_Aggregate --
3622 -------------------------
3624 function Is_Others_Aggregate
(Aggr
: Node_Id
) return Boolean is
3626 return No
(Expressions
(Aggr
))
3628 (First
(Choices
(First
(Component_Associations
(Aggr
)))))
3630 end Is_Others_Aggregate
;
3632 --------------------
3633 -- Safe_Aggregate --
3634 --------------------
3636 function Safe_Aggregate
(Aggr
: Node_Id
) return Boolean is
3640 if Present
(Expressions
(Aggr
)) then
3641 Expr
:= First
(Expressions
(Aggr
));
3643 while Present
(Expr
) loop
3644 if Nkind
(Expr
) = N_Aggregate
then
3645 if not Safe_Aggregate
(Expr
) then
3649 elsif not Safe_Component
(Expr
) then
3657 if Present
(Component_Associations
(Aggr
)) then
3658 Expr
:= First
(Component_Associations
(Aggr
));
3660 while Present
(Expr
) loop
3661 if Nkind
(Expression
(Expr
)) = N_Aggregate
then
3662 if not Safe_Aggregate
(Expression
(Expr
)) then
3666 elsif not Safe_Component
(Expression
(Expr
)) then
3677 --------------------
3678 -- Safe_Component --
3679 --------------------
3681 function Safe_Component
(Expr
: Node_Id
) return Boolean is
3682 Comp
: Node_Id
:= Expr
;
3684 function Check_Component
(Comp
: Node_Id
) return Boolean;
3685 -- Do the recursive traversal, after copy
3687 ---------------------
3688 -- Check_Component --
3689 ---------------------
3691 function Check_Component
(Comp
: Node_Id
) return Boolean is
3693 if Is_Overloaded
(Comp
) then
3697 return Compile_Time_Known_Value
(Comp
)
3699 or else (Is_Entity_Name
(Comp
)
3700 and then Present
(Entity
(Comp
))
3701 and then No
(Renamed_Object
(Entity
(Comp
))))
3703 or else (Nkind
(Comp
) = N_Attribute_Reference
3704 and then Check_Component
(Prefix
(Comp
)))
3706 or else (Nkind
(Comp
) in N_Binary_Op
3707 and then Check_Component
(Left_Opnd
(Comp
))
3708 and then Check_Component
(Right_Opnd
(Comp
)))
3710 or else (Nkind
(Comp
) in N_Unary_Op
3711 and then Check_Component
(Right_Opnd
(Comp
)))
3713 or else (Nkind
(Comp
) = N_Selected_Component
3714 and then Check_Component
(Prefix
(Comp
)))
3716 or else (Nkind
(Comp
) = N_Unchecked_Type_Conversion
3717 and then Check_Component
(Expression
(Comp
)));
3718 end Check_Component
;
3720 -- Start of processing for Safe_Component
3723 -- If the component appears in an association that may
3724 -- correspond to more than one element, it is not analyzed
3725 -- before the expansion into assignments, to avoid side effects.
3726 -- We analyze, but do not resolve the copy, to obtain sufficient
3727 -- entity information for the checks that follow. If component is
3728 -- overloaded we assume an unsafe function call.
3730 if not Analyzed
(Comp
) then
3731 if Is_Overloaded
(Expr
) then
3734 elsif Nkind
(Expr
) = N_Aggregate
3735 and then not Is_Others_Aggregate
(Expr
)
3739 elsif Nkind
(Expr
) = N_Allocator
then
3741 -- For now, too complex to analyze
3746 Comp
:= New_Copy_Tree
(Expr
);
3747 Set_Parent
(Comp
, Parent
(Expr
));
3751 if Nkind
(Comp
) = N_Aggregate
then
3752 return Safe_Aggregate
(Comp
);
3754 return Check_Component
(Comp
);
3758 -- Start of processing for In_Place_Assign_OK
3761 if Present
(Component_Associations
(N
)) then
3763 -- On assignment, sliding can take place, so we cannot do the
3764 -- assignment in place unless the bounds of the aggregate are
3765 -- statically equal to those of the target.
3767 -- If the aggregate is given by an others choice, the bounds
3768 -- are derived from the left-hand side, and the assignment is
3769 -- safe if the expression is.
3771 if Is_Others_Aggregate
(N
) then
3774 (Expression
(First
(Component_Associations
(N
))));
3777 Aggr_In
:= First_Index
(Etype
(N
));
3778 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
3779 Obj_In
:= First_Index
(Etype
(Name
(Parent
(N
))));
3782 -- Context is an allocator. Check bounds of aggregate
3783 -- against given type in qualified expression.
3785 pragma Assert
(Nkind
(Parent
(Parent
(N
))) = N_Allocator
);
3787 First_Index
(Etype
(Entity
(Subtype_Mark
(Parent
(N
)))));
3790 while Present
(Aggr_In
) loop
3791 Get_Index_Bounds
(Aggr_In
, Aggr_Lo
, Aggr_Hi
);
3792 Get_Index_Bounds
(Obj_In
, Obj_Lo
, Obj_Hi
);
3794 if not Compile_Time_Known_Value
(Aggr_Lo
)
3795 or else not Compile_Time_Known_Value
(Aggr_Hi
)
3796 or else not Compile_Time_Known_Value
(Obj_Lo
)
3797 or else not Compile_Time_Known_Value
(Obj_Hi
)
3798 or else Expr_Value
(Aggr_Lo
) /= Expr_Value
(Obj_Lo
)
3799 or else Expr_Value
(Aggr_Hi
) /= Expr_Value
(Obj_Hi
)
3804 Next_Index
(Aggr_In
);
3805 Next_Index
(Obj_In
);
3809 -- Now check the component values themselves
3811 return Safe_Aggregate
(N
);
3812 end In_Place_Assign_OK
;
3818 procedure Others_Check
(Sub_Aggr
: Node_Id
; Dim
: Pos
) is
3819 Aggr_Lo
: constant Node_Id
:= Aggr_Low
(Dim
);
3820 Aggr_Hi
: constant Node_Id
:= Aggr_High
(Dim
);
3821 -- The bounds of the aggregate for this dimension
3823 Ind_Typ
: constant Entity_Id
:= Aggr_Index_Typ
(Dim
);
3824 -- The index type for this dimension
3826 Need_To_Check
: Boolean := False;
3828 Choices_Lo
: Node_Id
:= Empty
;
3829 Choices_Hi
: Node_Id
:= Empty
;
3830 -- The lowest and highest discrete choices for a named sub-aggregate
3832 Nb_Choices
: Int
:= -1;
3833 -- The number of discrete non-others choices in this sub-aggregate
3835 Nb_Elements
: Uint
:= Uint_0
;
3836 -- The number of elements in a positional aggregate
3838 Cond
: Node_Id
:= Empty
;
3845 -- Check if we have an others choice. If we do make sure that this
3846 -- sub-aggregate contains at least one element in addition to the
3849 if Range_Checks_Suppressed
(Ind_Typ
) then
3850 Need_To_Check
:= False;
3852 elsif Present
(Expressions
(Sub_Aggr
))
3853 and then Present
(Component_Associations
(Sub_Aggr
))
3855 Need_To_Check
:= True;
3857 elsif Present
(Component_Associations
(Sub_Aggr
)) then
3858 Assoc
:= Last
(Component_Associations
(Sub_Aggr
));
3860 if Nkind
(First
(Choices
(Assoc
))) /= N_Others_Choice
then
3861 Need_To_Check
:= False;
3864 -- Count the number of discrete choices. Start with -1
3865 -- because the others choice does not count.
3868 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
3869 while Present
(Assoc
) loop
3870 Choice
:= First
(Choices
(Assoc
));
3871 while Present
(Choice
) loop
3872 Nb_Choices
:= Nb_Choices
+ 1;
3879 -- If there is only an others choice nothing to do
3881 Need_To_Check
:= (Nb_Choices
> 0);
3885 Need_To_Check
:= False;
3888 -- If we are dealing with a positional sub-aggregate with an
3889 -- others choice then compute the number or positional elements.
3891 if Need_To_Check
and then Present
(Expressions
(Sub_Aggr
)) then
3892 Expr
:= First
(Expressions
(Sub_Aggr
));
3893 Nb_Elements
:= Uint_0
;
3894 while Present
(Expr
) loop
3895 Nb_Elements
:= Nb_Elements
+ 1;
3899 -- If the aggregate contains discrete choices and an others choice
3900 -- compute the smallest and largest discrete choice values.
3902 elsif Need_To_Check
then
3903 Compute_Choices_Lo_And_Choices_Hi
: declare
3905 Table
: Case_Table_Type
(1 .. Nb_Choices
);
3906 -- Used to sort all the different choice values
3913 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
3914 while Present
(Assoc
) loop
3915 Choice
:= First
(Choices
(Assoc
));
3916 while Present
(Choice
) loop
3917 if Nkind
(Choice
) = N_Others_Choice
then
3921 Get_Index_Bounds
(Choice
, Low
, High
);
3922 Table
(J
).Choice_Lo
:= Low
;
3923 Table
(J
).Choice_Hi
:= High
;
3932 -- Sort the discrete choices
3934 Sort_Case_Table
(Table
);
3936 Choices_Lo
:= Table
(1).Choice_Lo
;
3937 Choices_Hi
:= Table
(Nb_Choices
).Choice_Hi
;
3938 end Compute_Choices_Lo_And_Choices_Hi
;
3941 -- If no others choice in this sub-aggregate, or the aggregate
3942 -- comprises only an others choice, nothing to do.
3944 if not Need_To_Check
then
3947 -- If we are dealing with an aggregate containing an others
3948 -- choice and positional components, we generate the following test:
3950 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
3951 -- Ind_Typ'Pos (Aggr_Hi)
3953 -- raise Constraint_Error;
3956 elsif Nb_Elements
> Uint_0
then
3962 Make_Attribute_Reference
(Loc
,
3963 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
3964 Attribute_Name
=> Name_Pos
,
3967 (Duplicate_Subexpr_Move_Checks
(Aggr_Lo
))),
3968 Right_Opnd
=> Make_Integer_Literal
(Loc
, Nb_Elements
- 1)),
3971 Make_Attribute_Reference
(Loc
,
3972 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
3973 Attribute_Name
=> Name_Pos
,
3974 Expressions
=> New_List
(
3975 Duplicate_Subexpr_Move_Checks
(Aggr_Hi
))));
3977 -- If we are dealing with an aggregate containing an others
3978 -- choice and discrete choices we generate the following test:
3980 -- [constraint_error when
3981 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
3989 Duplicate_Subexpr_Move_Checks
(Choices_Lo
),
3991 Duplicate_Subexpr_Move_Checks
(Aggr_Lo
)),
3996 Duplicate_Subexpr
(Choices_Hi
),
3998 Duplicate_Subexpr
(Aggr_Hi
)));
4001 if Present
(Cond
) then
4003 Make_Raise_Constraint_Error
(Loc
,
4005 Reason
=> CE_Length_Check_Failed
));
4008 -- Now look inside the sub-aggregate to see if there is more work
4010 if Dim
< Aggr_Dimension
then
4012 -- Process positional components
4014 if Present
(Expressions
(Sub_Aggr
)) then
4015 Expr
:= First
(Expressions
(Sub_Aggr
));
4016 while Present
(Expr
) loop
4017 Others_Check
(Expr
, Dim
+ 1);
4022 -- Process component associations
4024 if Present
(Component_Associations
(Sub_Aggr
)) then
4025 Assoc
:= First
(Component_Associations
(Sub_Aggr
));
4026 while Present
(Assoc
) loop
4027 Expr
:= Expression
(Assoc
);
4028 Others_Check
(Expr
, Dim
+ 1);
4035 -- Remaining Expand_Array_Aggregate variables
4038 -- Holds the temporary aggregate value
4041 -- Holds the declaration of Tmp
4043 Aggr_Code
: List_Id
;
4044 Parent_Node
: Node_Id
;
4045 Parent_Kind
: Node_Kind
;
4047 -- Start of processing for Expand_Array_Aggregate
4050 -- Do not touch the special aggregates of attributes used for Asm calls
4052 if Is_RTE
(Ctyp
, RE_Asm_Input_Operand
)
4053 or else Is_RTE
(Ctyp
, RE_Asm_Output_Operand
)
4058 -- If the semantic analyzer has determined that aggregate N will raise
4059 -- Constraint_Error at run-time, then the aggregate node has been
4060 -- replaced with an N_Raise_Constraint_Error node and we should
4063 pragma Assert
(not Raises_Constraint_Error
(N
));
4067 -- Check that the index range defined by aggregate bounds is
4068 -- compatible with corresponding index subtype.
4070 Index_Compatibility_Check
: declare
4071 Aggr_Index_Range
: Node_Id
:= First_Index
(Typ
);
4072 -- The current aggregate index range
4074 Index_Constraint
: Node_Id
:= First_Index
(Etype
(Typ
));
4075 -- The corresponding index constraint against which we have to
4076 -- check the above aggregate index range.
4079 Compute_Others_Present
(N
, 1);
4081 for J
in 1 .. Aggr_Dimension
loop
4082 -- There is no need to emit a check if an others choice is
4083 -- present for this array aggregate dimension since in this
4084 -- case one of N's sub-aggregates has taken its bounds from the
4085 -- context and these bounds must have been checked already. In
4086 -- addition all sub-aggregates corresponding to the same
4087 -- dimension must all have the same bounds (checked in (c) below).
4089 if not Range_Checks_Suppressed
(Etype
(Index_Constraint
))
4090 and then not Others_Present
(J
)
4092 -- We don't use Checks.Apply_Range_Check here because it
4093 -- emits a spurious check. Namely it checks that the range
4094 -- defined by the aggregate bounds is non empty. But we know
4095 -- this already if we get here.
4097 Check_Bounds
(Aggr_Index_Range
, Index_Constraint
);
4100 -- Save the low and high bounds of the aggregate index as well
4101 -- as the index type for later use in checks (b) and (c) below.
4103 Aggr_Low
(J
) := Low_Bound
(Aggr_Index_Range
);
4104 Aggr_High
(J
) := High_Bound
(Aggr_Index_Range
);
4106 Aggr_Index_Typ
(J
) := Etype
(Index_Constraint
);
4108 Next_Index
(Aggr_Index_Range
);
4109 Next_Index
(Index_Constraint
);
4111 end Index_Compatibility_Check
;
4115 -- If an others choice is present check that no aggregate
4116 -- index is outside the bounds of the index constraint.
4118 Others_Check
(N
, 1);
4122 -- For multidimensional arrays make sure that all subaggregates
4123 -- corresponding to the same dimension have the same bounds.
4125 if Aggr_Dimension
> 1 then
4126 Check_Same_Aggr_Bounds
(N
, 1);
4131 -- Here we test for is packed array aggregate that we can handle
4132 -- at compile time. If so, return with transformation done. Note
4133 -- that we do this even if the aggregate is nested, because once
4134 -- we have done this processing, there is no more nested aggregate!
4136 if Packed_Array_Aggregate_Handled
(N
) then
4140 -- At this point we try to convert to positional form
4142 Convert_To_Positional
(N
);
4144 -- if the result is no longer an aggregate (e.g. it may be a string
4145 -- literal, or a temporary which has the needed value), then we are
4146 -- done, since there is no longer a nested aggregate.
4148 if Nkind
(N
) /= N_Aggregate
then
4151 -- We are also done if the result is an analyzed aggregate
4152 -- This case could use more comments ???
4155 and then N
/= Original_Node
(N
)
4160 -- Now see if back end processing is possible
4162 if Backend_Processing_Possible
(N
) then
4164 -- If the aggregate is static but the constraints are not, build
4165 -- a static subtype for the aggregate, so that Gigi can place it
4166 -- in static memory. Perform an unchecked_conversion to the non-
4167 -- static type imposed by the context.
4170 Itype
: constant Entity_Id
:= Etype
(N
);
4172 Needs_Type
: Boolean := False;
4175 Index
:= First_Index
(Itype
);
4177 while Present
(Index
) loop
4178 if not Is_Static_Subtype
(Etype
(Index
)) then
4187 Build_Constrained_Type
(Positional
=> True);
4188 Rewrite
(N
, Unchecked_Convert_To
(Itype
, N
));
4198 -- Delay expansion for nested aggregates it will be taken care of
4199 -- when the parent aggregate is expanded
4201 Parent_Node
:= Parent
(N
);
4202 Parent_Kind
:= Nkind
(Parent_Node
);
4204 if Parent_Kind
= N_Qualified_Expression
then
4205 Parent_Node
:= Parent
(Parent_Node
);
4206 Parent_Kind
:= Nkind
(Parent_Node
);
4209 if Parent_Kind
= N_Aggregate
4210 or else Parent_Kind
= N_Extension_Aggregate
4211 or else Parent_Kind
= N_Component_Association
4212 or else (Parent_Kind
= N_Object_Declaration
4213 and then Controlled_Type
(Typ
))
4214 or else (Parent_Kind
= N_Assignment_Statement
4215 and then Inside_Init_Proc
)
4217 Set_Expansion_Delayed
(N
);
4223 -- Look if in place aggregate expansion is possible
4225 -- For object declarations we build the aggregate in place, unless
4226 -- the array is bit-packed or the component is controlled.
4228 -- For assignments we do the assignment in place if all the component
4229 -- associations have compile-time known values. For other cases we
4230 -- create a temporary. The analysis for safety of on-line assignment
4231 -- is delicate, i.e. we don't know how to do it fully yet ???
4233 -- For allocators we assign to the designated object in place if the
4234 -- aggregate meets the same conditions as other in-place assignments.
4235 -- In this case the aggregate may not come from source but was created
4236 -- for default initialization, e.g. with Initialize_Scalars.
4238 if Requires_Transient_Scope
(Typ
) then
4239 Establish_Transient_Scope
4240 (N
, Sec_Stack
=> Has_Controlled_Component
(Typ
));
4243 if Has_Default_Init_Comps
(N
) then
4244 Maybe_In_Place_OK
:= False;
4246 elsif Is_Bit_Packed_Array
(Typ
)
4247 or else Has_Controlled_Component
(Typ
)
4249 Maybe_In_Place_OK
:= False;
4252 Maybe_In_Place_OK
:=
4253 (Nkind
(Parent
(N
)) = N_Assignment_Statement
4254 and then Comes_From_Source
(N
)
4255 and then In_Place_Assign_OK
)
4258 (Nkind
(Parent
(Parent
(N
))) = N_Allocator
4259 and then In_Place_Assign_OK
);
4262 if not Has_Default_Init_Comps
(N
)
4263 and then Comes_From_Source
(Parent
(N
))
4264 and then Nkind
(Parent
(N
)) = N_Object_Declaration
4266 Must_Slide
(Etype
(Defining_Identifier
(Parent
(N
))), Typ
)
4267 and then N
= Expression
(Parent
(N
))
4268 and then not Is_Bit_Packed_Array
(Typ
)
4269 and then not Has_Controlled_Component
(Typ
)
4270 and then not Has_Address_Clause
(Parent
(N
))
4272 Tmp
:= Defining_Identifier
(Parent
(N
));
4273 Set_No_Initialization
(Parent
(N
));
4274 Set_Expression
(Parent
(N
), Empty
);
4276 -- Set the type of the entity, for use in the analysis of the
4277 -- subsequent indexed assignments. If the nominal type is not
4278 -- constrained, build a subtype from the known bounds of the
4279 -- aggregate. If the declaration has a subtype mark, use it,
4280 -- otherwise use the itype of the aggregate.
4282 if not Is_Constrained
(Typ
) then
4283 Build_Constrained_Type
(Positional
=> False);
4284 elsif Is_Entity_Name
(Object_Definition
(Parent
(N
)))
4285 and then Is_Constrained
(Entity
(Object_Definition
(Parent
(N
))))
4287 Set_Etype
(Tmp
, Entity
(Object_Definition
(Parent
(N
))));
4289 Set_Size_Known_At_Compile_Time
(Typ
, False);
4290 Set_Etype
(Tmp
, Typ
);
4293 elsif Maybe_In_Place_OK
4294 and then Nkind
(Parent
(N
)) = N_Qualified_Expression
4295 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
4297 Set_Expansion_Delayed
(N
);
4300 -- In the remaining cases the aggregate is the RHS of an assignment
4302 elsif Maybe_In_Place_OK
4303 and then Is_Entity_Name
(Name
(Parent
(N
)))
4305 Tmp
:= Entity
(Name
(Parent
(N
)));
4307 if Etype
(Tmp
) /= Etype
(N
) then
4308 Apply_Length_Check
(N
, Etype
(Tmp
));
4310 if Nkind
(N
) = N_Raise_Constraint_Error
then
4312 -- Static error, nothing further to expand
4318 elsif Maybe_In_Place_OK
4319 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
4320 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
4322 Tmp
:= Name
(Parent
(N
));
4324 if Etype
(Tmp
) /= Etype
(N
) then
4325 Apply_Length_Check
(N
, Etype
(Tmp
));
4328 elsif Maybe_In_Place_OK
4329 and then Nkind
(Name
(Parent
(N
))) = N_Slice
4330 and then Safe_Slice_Assignment
(N
)
4332 -- Safe_Slice_Assignment rewrites assignment as a loop
4338 -- In place aggregate expansion is not possible
4341 Maybe_In_Place_OK
:= False;
4342 Tmp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
4344 Make_Object_Declaration
4346 Defining_Identifier
=> Tmp
,
4347 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
4348 Set_No_Initialization
(Tmp_Decl
, True);
4350 -- If we are within a loop, the temporary will be pushed on the
4351 -- stack at each iteration. If the aggregate is the expression for
4352 -- an allocator, it will be immediately copied to the heap and can
4353 -- be reclaimed at once. We create a transient scope around the
4354 -- aggregate for this purpose.
4356 if Ekind
(Current_Scope
) = E_Loop
4357 and then Nkind
(Parent
(Parent
(N
))) = N_Allocator
4359 Establish_Transient_Scope
(N
, False);
4362 Insert_Action
(N
, Tmp_Decl
);
4365 -- Construct and insert the aggregate code. We can safely suppress
4366 -- index checks because this code is guaranteed not to raise CE
4367 -- on index checks. However we should *not* suppress all checks.
4373 if Nkind
(Tmp
) = N_Defining_Identifier
then
4374 Target
:= New_Reference_To
(Tmp
, Loc
);
4378 if Has_Default_Init_Comps
(N
) then
4380 -- Ada 2005 (AI-287): This case has not been analyzed???
4382 raise Program_Error
;
4385 -- Name in assignment is explicit dereference
4387 Target
:= New_Copy
(Tmp
);
4391 Build_Array_Aggr_Code
(N
,
4393 Index
=> First_Index
(Typ
),
4395 Scalar_Comp
=> Is_Scalar_Type
(Ctyp
));
4398 if Comes_From_Source
(Tmp
) then
4399 Insert_Actions_After
(Parent
(N
), Aggr_Code
);
4402 Insert_Actions
(N
, Aggr_Code
);
4405 -- If the aggregate has been assigned in place, remove the original
4408 if Nkind
(Parent
(N
)) = N_Assignment_Statement
4409 and then Maybe_In_Place_OK
4411 Rewrite
(Parent
(N
), Make_Null_Statement
(Loc
));
4413 elsif Nkind
(Parent
(N
)) /= N_Object_Declaration
4414 or else Tmp
/= Defining_Identifier
(Parent
(N
))
4416 Rewrite
(N
, New_Occurrence_Of
(Tmp
, Loc
));
4417 Analyze_And_Resolve
(N
, Typ
);
4419 end Expand_Array_Aggregate
;
4421 ------------------------
4422 -- Expand_N_Aggregate --
4423 ------------------------
4425 procedure Expand_N_Aggregate
(N
: Node_Id
) is
4427 if Is_Record_Type
(Etype
(N
)) then
4428 Expand_Record_Aggregate
(N
);
4430 Expand_Array_Aggregate
(N
);
4434 when RE_Not_Available
=>
4436 end Expand_N_Aggregate
;
4438 ----------------------------------
4439 -- Expand_N_Extension_Aggregate --
4440 ----------------------------------
4442 -- If the ancestor part is an expression, add a component association for
4443 -- the parent field. If the type of the ancestor part is not the direct
4444 -- parent of the expected type, build recursively the needed ancestors.
4445 -- If the ancestor part is a subtype_mark, replace aggregate with a decla-
4446 -- ration for a temporary of the expected type, followed by individual
4447 -- assignments to the given components.
4449 procedure Expand_N_Extension_Aggregate
(N
: Node_Id
) is
4450 Loc
: constant Source_Ptr
:= Sloc
(N
);
4451 A
: constant Node_Id
:= Ancestor_Part
(N
);
4452 Typ
: constant Entity_Id
:= Etype
(N
);
4455 -- If the ancestor is a subtype mark, an init proc must be called
4456 -- on the resulting object which thus has to be materialized in
4459 if Is_Entity_Name
(A
) and then Is_Type
(Entity
(A
)) then
4460 Convert_To_Assignments
(N
, Typ
);
4462 -- The extension aggregate is transformed into a record aggregate
4463 -- of the following form (c1 and c2 are inherited components)
4465 -- (Exp with c3 => a, c4 => b)
4466 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b)
4471 -- No tag is needed in the case of Java_VM
4474 Expand_Record_Aggregate
(N
,
4477 Expand_Record_Aggregate
(N
,
4480 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
),
4486 when RE_Not_Available
=>
4488 end Expand_N_Extension_Aggregate
;
4490 -----------------------------
4491 -- Expand_Record_Aggregate --
4492 -----------------------------
4494 procedure Expand_Record_Aggregate
4496 Orig_Tag
: Node_Id
:= Empty
;
4497 Parent_Expr
: Node_Id
:= Empty
)
4499 Loc
: constant Source_Ptr
:= Sloc
(N
);
4500 Comps
: constant List_Id
:= Component_Associations
(N
);
4501 Typ
: constant Entity_Id
:= Etype
(N
);
4502 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
4504 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
return Boolean;
4505 -- Checks the presence of a nested aggregate which needs Late_Expansion
4506 -- or the presence of tagged components which may need tag adjustment.
4508 --------------------------------------------------
4509 -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
4510 --------------------------------------------------
4512 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
return Boolean is
4522 while Present
(C
) loop
4523 if Nkind
(Expression
(C
)) = N_Qualified_Expression
then
4524 Expr_Q
:= Expression
(Expression
(C
));
4526 Expr_Q
:= Expression
(C
);
4529 -- Return true if the aggregate has any associations for
4530 -- tagged components that may require tag adjustment.
4531 -- These are cases where the source expression may have
4532 -- a tag that could differ from the component tag (e.g.,
4533 -- can occur for type conversions and formal parameters).
4534 -- (Tag adjustment is not needed if Java_VM because object
4535 -- tags are implicit in the JVM.)
4537 if Is_Tagged_Type
(Etype
(Expr_Q
))
4538 and then (Nkind
(Expr_Q
) = N_Type_Conversion
4539 or else (Is_Entity_Name
(Expr_Q
)
4540 and then Ekind
(Entity
(Expr_Q
)) in Formal_Kind
))
4541 and then not Java_VM
4546 if Is_Delayed_Aggregate
(Expr_Q
) then
4554 end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
;
4556 -- Remaining Expand_Record_Aggregate variables
4558 Tag_Value
: Node_Id
;
4562 -- Start of processing for Expand_Record_Aggregate
4565 -- If the aggregate is to be assigned to an atomic variable, we
4566 -- have to prevent a piecemeal assignment even if the aggregate
4567 -- is to be expanded. We create a temporary for the aggregate, and
4568 -- assign the temporary instead, so that the back end can generate
4569 -- an atomic move for it.
4572 and then (Nkind
(Parent
(N
)) = N_Object_Declaration
4573 or else Nkind
(Parent
(N
)) = N_Assignment_Statement
)
4574 and then Comes_From_Source
(Parent
(N
))
4576 Expand_Atomic_Aggregate
(N
, Typ
);
4580 -- Gigi doesn't handle properly temporaries of variable size
4581 -- so we generate it in the front-end
4583 if not Size_Known_At_Compile_Time
(Typ
) then
4584 Convert_To_Assignments
(N
, Typ
);
4586 -- Temporaries for controlled aggregates need to be attached to a
4587 -- final chain in order to be properly finalized, so it has to
4588 -- be created in the front-end
4590 elsif Is_Controlled
(Typ
)
4591 or else Has_Controlled_Component
(Base_Type
(Typ
))
4593 Convert_To_Assignments
(N
, Typ
);
4595 -- Ada 2005 (AI-287): In case of default initialized components we
4596 -- convert the aggregate into assignments.
4598 elsif Has_Default_Init_Comps
(N
) then
4599 Convert_To_Assignments
(N
, Typ
);
4601 elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
then
4602 Convert_To_Assignments
(N
, Typ
);
4604 -- If an ancestor is private, some components are not inherited and
4605 -- we cannot expand into a record aggregate
4607 elsif Has_Private_Ancestor
(Typ
) then
4608 Convert_To_Assignments
(N
, Typ
);
4610 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
4611 -- is not able to handle the aggregate for Late_Request.
4613 elsif Is_Tagged_Type
(Typ
) and then Has_Discriminants
(Typ
) then
4614 Convert_To_Assignments
(N
, Typ
);
4616 -- If some components are mutable, the size of the aggregate component
4617 -- may be disctinct from the default size of the type component, so
4618 -- we need to expand to insure that the back-end copies the proper
4619 -- size of the data.
4621 elsif Has_Mutable_Components
(Typ
) then
4622 Convert_To_Assignments
(N
, Typ
);
4624 -- If the type involved has any non-bit aligned components, then
4625 -- we are not sure that the back end can handle this case correctly.
4627 elsif Type_May_Have_Bit_Aligned_Components
(Typ
) then
4628 Convert_To_Assignments
(N
, Typ
);
4630 -- In all other cases we generate a proper aggregate that
4631 -- can be handled by gigi.
4634 -- If no discriminants, nothing special to do
4636 if not Has_Discriminants
(Typ
) then
4639 -- Case of discriminants present
4641 elsif Is_Derived_Type
(Typ
) then
4643 -- For untagged types, non-stored discriminants are replaced
4644 -- with stored discriminants, which are the ones that gigi uses
4645 -- to describe the type and its components.
4647 Generate_Aggregate_For_Derived_Type
: declare
4648 Constraints
: constant List_Id
:= New_List
;
4649 First_Comp
: Node_Id
;
4650 Discriminant
: Entity_Id
;
4652 Num_Disc
: Int
:= 0;
4653 Num_Gird
: Int
:= 0;
4655 procedure Prepend_Stored_Values
(T
: Entity_Id
);
4656 -- Scan the list of stored discriminants of the type, and
4657 -- add their values to the aggregate being built.
4659 ---------------------------
4660 -- Prepend_Stored_Values --
4661 ---------------------------
4663 procedure Prepend_Stored_Values
(T
: Entity_Id
) is
4665 Discriminant
:= First_Stored_Discriminant
(T
);
4667 while Present
(Discriminant
) loop
4669 Make_Component_Association
(Loc
,
4671 New_List
(New_Occurrence_Of
(Discriminant
, Loc
)),
4675 Get_Discriminant_Value
(
4678 Discriminant_Constraint
(Typ
))));
4680 if No
(First_Comp
) then
4681 Prepend_To
(Component_Associations
(N
), New_Comp
);
4683 Insert_After
(First_Comp
, New_Comp
);
4686 First_Comp
:= New_Comp
;
4687 Next_Stored_Discriminant
(Discriminant
);
4689 end Prepend_Stored_Values
;
4691 -- Start of processing for Generate_Aggregate_For_Derived_Type
4694 -- Remove the associations for the discriminant of
4695 -- the derived type.
4697 First_Comp
:= First
(Component_Associations
(N
));
4699 while Present
(First_Comp
) loop
4703 if Ekind
(Entity
(First
(Choices
(Comp
)))) =
4707 Num_Disc
:= Num_Disc
+ 1;
4711 -- Insert stored discriminant associations in the correct
4712 -- order. If there are more stored discriminants than new
4713 -- discriminants, there is at least one new discriminant
4714 -- that constrains more than one of the stored discriminants.
4715 -- In this case we need to construct a proper subtype of
4716 -- the parent type, in order to supply values to all the
4717 -- components. Otherwise there is one-one correspondence
4718 -- between the constraints and the stored discriminants.
4720 First_Comp
:= Empty
;
4722 Discriminant
:= First_Stored_Discriminant
(Base_Type
(Typ
));
4724 while Present
(Discriminant
) loop
4725 Num_Gird
:= Num_Gird
+ 1;
4726 Next_Stored_Discriminant
(Discriminant
);
4729 -- Case of more stored discriminants than new discriminants
4731 if Num_Gird
> Num_Disc
then
4733 -- Create a proper subtype of the parent type, which is
4734 -- the proper implementation type for the aggregate, and
4735 -- convert it to the intended target type.
4737 Discriminant
:= First_Stored_Discriminant
(Base_Type
(Typ
));
4739 while Present
(Discriminant
) loop
4742 Get_Discriminant_Value
(
4745 Discriminant_Constraint
(Typ
)));
4746 Append
(New_Comp
, Constraints
);
4747 Next_Stored_Discriminant
(Discriminant
);
4751 Make_Subtype_Declaration
(Loc
,
4752 Defining_Identifier
=>
4753 Make_Defining_Identifier
(Loc
,
4754 New_Internal_Name
('T')),
4755 Subtype_Indication
=>
4756 Make_Subtype_Indication
(Loc
,
4758 New_Occurrence_Of
(Etype
(Base_Type
(Typ
)), Loc
),
4760 Make_Index_Or_Discriminant_Constraint
4761 (Loc
, Constraints
)));
4763 Insert_Action
(N
, Decl
);
4764 Prepend_Stored_Values
(Base_Type
(Typ
));
4766 Set_Etype
(N
, Defining_Identifier
(Decl
));
4769 Rewrite
(N
, Unchecked_Convert_To
(Typ
, N
));
4772 -- Case where we do not have fewer new discriminants than
4773 -- stored discriminants, so in this case we can simply
4774 -- use the stored discriminants of the subtype.
4777 Prepend_Stored_Values
(Typ
);
4779 end Generate_Aggregate_For_Derived_Type
;
4782 if Is_Tagged_Type
(Typ
) then
4784 -- The tagged case, _parent and _tag component must be created
4786 -- Reset null_present unconditionally. tagged records always have
4787 -- at least one field (the tag or the parent)
4789 Set_Null_Record_Present
(N
, False);
4791 -- When the current aggregate comes from the expansion of an
4792 -- extension aggregate, the parent expr is replaced by an
4793 -- aggregate formed by selected components of this expr
4795 if Present
(Parent_Expr
)
4796 and then Is_Empty_List
(Comps
)
4798 Comp
:= First_Entity
(Typ
);
4799 while Present
(Comp
) loop
4801 -- Skip all entities that aren't discriminants or components
4803 if Ekind
(Comp
) /= E_Discriminant
4804 and then Ekind
(Comp
) /= E_Component
4808 -- Skip all expander-generated components
4811 not Comes_From_Source
(Original_Record_Component
(Comp
))
4817 Make_Selected_Component
(Loc
,
4819 Unchecked_Convert_To
(Typ
,
4820 Duplicate_Subexpr
(Parent_Expr
, True)),
4822 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
4825 Make_Component_Association
(Loc
,
4827 New_List
(New_Occurrence_Of
(Comp
, Loc
)),
4831 Analyze_And_Resolve
(New_Comp
, Etype
(Comp
));
4838 -- Compute the value for the Tag now, if the type is a root it
4839 -- will be included in the aggregate right away, otherwise it will
4840 -- be propagated to the parent aggregate
4842 if Present
(Orig_Tag
) then
4843 Tag_Value
:= Orig_Tag
;
4849 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
4852 -- For a derived type, an aggregate for the parent is formed with
4853 -- all the inherited components.
4855 if Is_Derived_Type
(Typ
) then
4858 First_Comp
: Node_Id
;
4859 Parent_Comps
: List_Id
;
4860 Parent_Aggr
: Node_Id
;
4861 Parent_Name
: Node_Id
;
4864 -- Remove the inherited component association from the
4865 -- aggregate and store them in the parent aggregate
4867 First_Comp
:= First
(Component_Associations
(N
));
4868 Parent_Comps
:= New_List
;
4870 while Present
(First_Comp
)
4871 and then Scope
(Original_Record_Component
(
4872 Entity
(First
(Choices
(First_Comp
))))) /= Base_Typ
4877 Append
(Comp
, Parent_Comps
);
4880 Parent_Aggr
:= Make_Aggregate
(Loc
,
4881 Component_Associations
=> Parent_Comps
);
4882 Set_Etype
(Parent_Aggr
, Etype
(Base_Type
(Typ
)));
4884 -- Find the _parent component
4886 Comp
:= First_Component
(Typ
);
4887 while Chars
(Comp
) /= Name_uParent
loop
4888 Comp
:= Next_Component
(Comp
);
4891 Parent_Name
:= New_Occurrence_Of
(Comp
, Loc
);
4893 -- Insert the parent aggregate
4895 Prepend_To
(Component_Associations
(N
),
4896 Make_Component_Association
(Loc
,
4897 Choices
=> New_List
(Parent_Name
),
4898 Expression
=> Parent_Aggr
));
4900 -- Expand recursively the parent propagating the right Tag
4902 Expand_Record_Aggregate
(
4903 Parent_Aggr
, Tag_Value
, Parent_Expr
);
4906 -- For a root type, the tag component is added (unless compiling
4907 -- for the Java VM, where tags are implicit).
4909 elsif not Java_VM
then
4911 Tag_Name
: constant Node_Id
:=
4913 (First_Tag_Component
(Typ
), Loc
);
4914 Typ_Tag
: constant Entity_Id
:= RTE
(RE_Tag
);
4915 Conv_Node
: constant Node_Id
:=
4916 Unchecked_Convert_To
(Typ_Tag
, Tag_Value
);
4919 Set_Etype
(Conv_Node
, Typ_Tag
);
4920 Prepend_To
(Component_Associations
(N
),
4921 Make_Component_Association
(Loc
,
4922 Choices
=> New_List
(Tag_Name
),
4923 Expression
=> Conv_Node
));
4928 end Expand_Record_Aggregate
;
4930 ----------------------------
4931 -- Has_Default_Init_Comps --
4932 ----------------------------
4934 function Has_Default_Init_Comps
(N
: Node_Id
) return Boolean is
4935 Comps
: constant List_Id
:= Component_Associations
(N
);
4939 pragma Assert
(Nkind
(N
) = N_Aggregate
4940 or else Nkind
(N
) = N_Extension_Aggregate
);
4946 -- Check if any direct component has default initialized components
4949 while Present
(C
) loop
4950 if Box_Present
(C
) then
4957 -- Recursive call in case of aggregate expression
4960 while Present
(C
) loop
4961 Expr
:= Expression
(C
);
4964 and then (Nkind
(Expr
) = N_Aggregate
4965 or else Nkind
(Expr
) = N_Extension_Aggregate
)
4966 and then Has_Default_Init_Comps
(Expr
)
4975 end Has_Default_Init_Comps
;
4977 --------------------------
4978 -- Is_Delayed_Aggregate --
4979 --------------------------
4981 function Is_Delayed_Aggregate
(N
: Node_Id
) return Boolean is
4982 Node
: Node_Id
:= N
;
4983 Kind
: Node_Kind
:= Nkind
(Node
);
4986 if Kind
= N_Qualified_Expression
then
4987 Node
:= Expression
(Node
);
4988 Kind
:= Nkind
(Node
);
4991 if Kind
/= N_Aggregate
and then Kind
/= N_Extension_Aggregate
then
4994 return Expansion_Delayed
(Node
);
4996 end Is_Delayed_Aggregate
;
4998 --------------------
4999 -- Late_Expansion --
5000 --------------------
5002 function Late_Expansion
5006 Flist
: Node_Id
:= Empty
;
5007 Obj
: Entity_Id
:= Empty
) return List_Id
5010 if Is_Record_Type
(Etype
(N
)) then
5011 return Build_Record_Aggr_Code
(N
, Typ
, Target
, Flist
, Obj
);
5013 else pragma Assert
(Is_Array_Type
(Etype
(N
)));
5015 Build_Array_Aggr_Code
5017 Ctype
=> Component_Type
(Etype
(N
)),
5018 Index
=> First_Index
(Typ
),
5020 Scalar_Comp
=> Is_Scalar_Type
(Component_Type
(Typ
)),
5026 ----------------------------------
5027 -- Make_OK_Assignment_Statement --
5028 ----------------------------------
5030 function Make_OK_Assignment_Statement
5033 Expression
: Node_Id
) return Node_Id
5036 Set_Assignment_OK
(Name
);
5037 return Make_Assignment_Statement
(Sloc
, Name
, Expression
);
5038 end Make_OK_Assignment_Statement
;
5040 -----------------------
5041 -- Number_Of_Choices --
5042 -----------------------
5044 function Number_Of_Choices
(N
: Node_Id
) return Nat
is
5048 Nb_Choices
: Nat
:= 0;
5051 if Present
(Expressions
(N
)) then
5055 Assoc
:= First
(Component_Associations
(N
));
5056 while Present
(Assoc
) loop
5058 Choice
:= First
(Choices
(Assoc
));
5059 while Present
(Choice
) loop
5061 if Nkind
(Choice
) /= N_Others_Choice
then
5062 Nb_Choices
:= Nb_Choices
+ 1;
5072 end Number_Of_Choices
;
5074 ------------------------------------
5075 -- Packed_Array_Aggregate_Handled --
5076 ------------------------------------
5078 -- The current version of this procedure will handle at compile time
5079 -- any array aggregate that meets these conditions:
5081 -- One dimensional, bit packed
5082 -- Underlying packed type is modular type
5083 -- Bounds are within 32-bit Int range
5084 -- All bounds and values are static
5086 function Packed_Array_Aggregate_Handled
(N
: Node_Id
) return Boolean is
5087 Loc
: constant Source_Ptr
:= Sloc
(N
);
5088 Typ
: constant Entity_Id
:= Etype
(N
);
5089 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
5091 Not_Handled
: exception;
5092 -- Exception raised if this aggregate cannot be handled
5095 -- For now, handle only one dimensional bit packed arrays
5097 if not Is_Bit_Packed_Array
(Typ
)
5098 or else Number_Dimensions
(Typ
) > 1
5099 or else not Is_Modular_Integer_Type
(Packed_Array_Type
(Typ
))
5105 Csiz
: constant Nat
:= UI_To_Int
(Component_Size
(Typ
));
5109 -- Bounds of index type
5113 -- Values of bounds if compile time known
5115 function Get_Component_Val
(N
: Node_Id
) return Uint
;
5116 -- Given a expression value N of the component type Ctyp, returns
5117 -- A value of Csiz (component size) bits representing this value.
5118 -- If the value is non-static or any other reason exists why the
5119 -- value cannot be returned, then Not_Handled is raised.
5121 -----------------------
5122 -- Get_Component_Val --
5123 -----------------------
5125 function Get_Component_Val
(N
: Node_Id
) return Uint
is
5129 -- We have to analyze the expression here before doing any further
5130 -- processing here. The analysis of such expressions is deferred
5131 -- till expansion to prevent some problems of premature analysis.
5133 Analyze_And_Resolve
(N
, Ctyp
);
5135 -- Must have a compile time value. String literals have to
5136 -- be converted into temporaries as well, because they cannot
5137 -- easily be converted into their bit representation.
5139 if not Compile_Time_Known_Value
(N
)
5140 or else Nkind
(N
) = N_String_Literal
5145 Val
:= Expr_Rep_Value
(N
);
5147 -- Adjust for bias, and strip proper number of bits
5149 if Has_Biased_Representation
(Ctyp
) then
5150 Val
:= Val
- Expr_Value
(Type_Low_Bound
(Ctyp
));
5153 return Val
mod Uint_2
** Csiz
;
5154 end Get_Component_Val
;
5156 -- Here we know we have a one dimensional bit packed array
5159 Get_Index_Bounds
(First_Index
(Typ
), Lo
, Hi
);
5161 -- Cannot do anything if bounds are dynamic
5163 if not Compile_Time_Known_Value
(Lo
)
5165 not Compile_Time_Known_Value
(Hi
)
5170 -- Or are silly out of range of int bounds
5172 Lob
:= Expr_Value
(Lo
);
5173 Hib
:= Expr_Value
(Hi
);
5175 if not UI_Is_In_Int_Range
(Lob
)
5177 not UI_Is_In_Int_Range
(Hib
)
5182 -- At this stage we have a suitable aggregate for handling
5183 -- at compile time (the only remaining checks, are that the
5184 -- values of expressions in the aggregate are compile time
5185 -- known (check performed by Get_Component_Val), and that
5186 -- any subtypes or ranges are statically known.
5188 -- If the aggregate is not fully positional at this stage,
5189 -- then convert it to positional form. Either this will fail,
5190 -- in which case we can do nothing, or it will succeed, in
5191 -- which case we have succeeded in handling the aggregate,
5192 -- or it will stay an aggregate, in which case we have failed
5193 -- to handle this case.
5195 if Present
(Component_Associations
(N
)) then
5196 Convert_To_Positional
5197 (N
, Max_Others_Replicate
=> 64, Handle_Bit_Packed
=> True);
5198 return Nkind
(N
) /= N_Aggregate
;
5201 -- Otherwise we are all positional, so convert to proper value
5204 Lov
: constant Int
:= UI_To_Int
(Lob
);
5205 Hiv
: constant Int
:= UI_To_Int
(Hib
);
5207 Len
: constant Nat
:= Int
'Max (0, Hiv
- Lov
+ 1);
5208 -- The length of the array (number of elements)
5210 Aggregate_Val
: Uint
;
5211 -- Value of aggregate. The value is set in the low order
5212 -- bits of this value. For the little-endian case, the
5213 -- values are stored from low-order to high-order and
5214 -- for the big-endian case the values are stored from
5215 -- high-order to low-order. Note that gigi will take care
5216 -- of the conversions to left justify the value in the big
5217 -- endian case (because of left justified modular type
5218 -- processing), so we do not have to worry about that here.
5221 -- Integer literal for resulting constructed value
5224 -- Shift count from low order for next value
5227 -- Shift increment for loop
5230 -- Next expression from positional parameters of aggregate
5233 -- For little endian, we fill up the low order bits of the
5234 -- target value. For big endian we fill up the high order
5235 -- bits of the target value (which is a left justified
5238 if Bytes_Big_Endian
xor Debug_Flag_8
then
5239 Shift
:= Csiz
* (Len
- 1);
5246 -- Loop to set the values
5249 Aggregate_Val
:= Uint_0
;
5251 Expr
:= First
(Expressions
(N
));
5252 Aggregate_Val
:= Get_Component_Val
(Expr
) * Uint_2
** Shift
;
5254 for J
in 2 .. Len
loop
5255 Shift
:= Shift
+ Incr
;
5258 Aggregate_Val
+ Get_Component_Val
(Expr
) * Uint_2
** Shift
;
5262 -- Now we can rewrite with the proper value
5265 Make_Integer_Literal
(Loc
,
5266 Intval
=> Aggregate_Val
);
5267 Set_Print_In_Hex
(Lit
);
5269 -- Construct the expression using this literal. Note that it is
5270 -- important to qualify the literal with its proper modular type
5271 -- since universal integer does not have the required range and
5272 -- also this is a left justified modular type, which is important
5273 -- in the big-endian case.
5276 Unchecked_Convert_To
(Typ
,
5277 Make_Qualified_Expression
(Loc
,
5279 New_Occurrence_Of
(Packed_Array_Type
(Typ
), Loc
),
5280 Expression
=> Lit
)));
5282 Analyze_And_Resolve
(N
, Typ
);
5290 end Packed_Array_Aggregate_Handled
;
5292 ----------------------------
5293 -- Has_Mutable_Components --
5294 ----------------------------
5296 function Has_Mutable_Components
(Typ
: Entity_Id
) return Boolean is
5300 Comp
:= First_Component
(Typ
);
5302 while Present
(Comp
) loop
5303 if Is_Record_Type
(Etype
(Comp
))
5304 and then Has_Discriminants
(Etype
(Comp
))
5305 and then not Is_Constrained
(Etype
(Comp
))
5310 Next_Component
(Comp
);
5314 end Has_Mutable_Components
;
5316 ------------------------------
5317 -- Initialize_Discriminants --
5318 ------------------------------
5320 procedure Initialize_Discriminants
(N
: Node_Id
; Typ
: Entity_Id
) is
5321 Loc
: constant Source_Ptr
:= Sloc
(N
);
5322 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
5323 Par
: constant Entity_Id
:= Etype
(Bas
);
5324 Decl
: constant Node_Id
:= Parent
(Par
);
5328 if Is_Tagged_Type
(Bas
)
5329 and then Is_Derived_Type
(Bas
)
5330 and then Has_Discriminants
(Par
)
5331 and then Has_Discriminants
(Bas
)
5332 and then Number_Discriminants
(Bas
) /= Number_Discriminants
(Par
)
5333 and then Nkind
(Decl
) = N_Full_Type_Declaration
5334 and then Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
5336 (Variant_Part
(Component_List
(Type_Definition
(Decl
))))
5337 and then Nkind
(N
) /= N_Extension_Aggregate
5340 -- Call init proc to set discriminants.
5341 -- There should eventually be a special procedure for this ???
5343 Ref
:= New_Reference_To
(Defining_Identifier
(N
), Loc
);
5344 Insert_Actions_After
(N
,
5345 Build_Initialization_Call
(Sloc
(N
), Ref
, Typ
));
5347 end Initialize_Discriminants
;
5354 (Obj_Type
: Entity_Id
;
5355 Typ
: Entity_Id
) return Boolean
5357 L1
, L2
, H1
, H2
: Node_Id
;
5359 -- No sliding if the type of the object is not established yet, if
5360 -- it is an unconstrained type whose actual subtype comes from the
5361 -- aggregate, or if the two types are identical.
5363 if not Is_Array_Type
(Obj_Type
) then
5366 elsif not Is_Constrained
(Obj_Type
) then
5369 elsif Typ
= Obj_Type
then
5373 -- Sliding can only occur along the first dimension
5375 Get_Index_Bounds
(First_Index
(Typ
), L1
, H1
);
5376 Get_Index_Bounds
(First_Index
(Obj_Type
), L2
, H2
);
5378 if not Is_Static_Expression
(L1
)
5379 or else not Is_Static_Expression
(L2
)
5380 or else not Is_Static_Expression
(H1
)
5381 or else not Is_Static_Expression
(H2
)
5385 return Expr_Value
(L1
) /= Expr_Value
(L2
)
5386 or else Expr_Value
(H1
) /= Expr_Value
(H2
);
5391 ---------------------------
5392 -- Safe_Slice_Assignment --
5393 ---------------------------
5395 function Safe_Slice_Assignment
(N
: Node_Id
) return Boolean is
5396 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
5397 Pref
: constant Node_Id
:= Prefix
(Name
(Parent
(N
)));
5398 Range_Node
: constant Node_Id
:= Discrete_Range
(Name
(Parent
(N
)));
5406 -- Generate: for J in Range loop Pref (J) := Expr; end loop;
5408 if Comes_From_Source
(N
)
5409 and then No
(Expressions
(N
))
5410 and then Nkind
(First
(Choices
(First
(Component_Associations
(N
)))))
5414 Expression
(First
(Component_Associations
(N
)));
5415 L_J
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
5418 Make_Iteration_Scheme
(Loc
,
5419 Loop_Parameter_Specification
=>
5420 Make_Loop_Parameter_Specification
5422 Defining_Identifier
=> L_J
,
5423 Discrete_Subtype_Definition
=> Relocate_Node
(Range_Node
)));
5426 Make_Assignment_Statement
(Loc
,
5428 Make_Indexed_Component
(Loc
,
5429 Prefix
=> Relocate_Node
(Pref
),
5430 Expressions
=> New_List
(New_Occurrence_Of
(L_J
, Loc
))),
5431 Expression
=> Relocate_Node
(Expr
));
5433 -- Construct the final loop
5436 Make_Implicit_Loop_Statement
5437 (Node
=> Parent
(N
),
5438 Identifier
=> Empty
,
5439 Iteration_Scheme
=> L_Iter
,
5440 Statements
=> New_List
(L_Body
));
5442 -- Set type of aggregate to be type of lhs in assignment,
5443 -- to suppress redundant length checks.
5445 Set_Etype
(N
, Etype
(Name
(Parent
(N
))));
5447 Rewrite
(Parent
(N
), Stat
);
5448 Analyze
(Parent
(N
));
5454 end Safe_Slice_Assignment
;
5456 ---------------------
5457 -- Sort_Case_Table --
5458 ---------------------
5460 procedure Sort_Case_Table
(Case_Table
: in out Case_Table_Type
) is
5461 L
: constant Int
:= Case_Table
'First;
5462 U
: constant Int
:= Case_Table
'Last;
5471 T
:= Case_Table
(K
+ 1);
5475 and then Expr_Value
(Case_Table
(J
- 1).Choice_Lo
) >
5476 Expr_Value
(T
.Choice_Lo
)
5478 Case_Table
(J
) := Case_Table
(J
- 1);
5482 Case_Table
(J
) := T
;
5485 end Sort_Case_Table
;