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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 procedure Convert_Array_Aggr_In_Allocator
165 -- If the aggregate appears within an allocator and can be expanded in
166 -- place, this routine generates the individual assignments to components
167 -- of the designated object. This is an optimization over the general
168 -- case, where a temporary is first created on the stack and then used to
169 -- construct the allocated object on the heap.
171 procedure Convert_To_Positional
173 Max_Others_Replicate : Nat := 5;
174 Handle_Bit_Packed : Boolean := False);
175 -- If possible, convert named notation to positional notation. This
176 -- conversion is possible only in some static cases. If the conversion is
177 -- possible, then N is rewritten with the analyzed converted aggregate.
178 -- The parameter Max_Others_Replicate controls the maximum number of
179 -- values corresponding to an others choice that will be converted to
180 -- positional notation (the default of 5 is the normal limit, and reflects
181 -- the fact that normally the loop is better than a lot of separate
182 -- assignments). Note that this limit gets overridden in any case if
183 -- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
184 -- set. The parameter Handle_Bit_Packed is usually set False (since we do
185 -- not expect the back end to handle bit packed arrays, so the normal case
186 -- of conversion is pointless), but in the special case of a call from
187 -- Packed_Array_Aggregate_Handled, we set this parameter to True, since
188 -- these are cases we handle in there.
190 procedure Expand_Array_Aggregate (N : Node_Id);
191 -- This is the top-level routine to perform array aggregate expansion.
192 -- N is the N_Aggregate node to be expanded.
194 function Backend_Processing_Possible (N : Node_Id) return Boolean;
195 -- This function checks if array aggregate N can be processed directly
196 -- by Gigi. If this is the case True is returned.
198 function Build_Array_Aggr_Code
203 Scalar_Comp : Boolean;
204 Indices : List_Id := No_List;
205 Flist : Node_Id := Empty) return List_Id;
206 -- This recursive routine returns a list of statements containing the
207 -- loops and assignments that are needed for the expansion of the array
210 -- N is the (sub-)aggregate node to be expanded into code. This node
211 -- has been fully analyzed, and its Etype is properly set.
213 -- Index is the index node corresponding to the array sub-aggregate N.
215 -- Into is the target expression into which we are copying the aggregate.
216 -- Note that this node may not have been analyzed yet, and so the Etype
217 -- field may not be set.
219 -- Scalar_Comp is True if the component type of the aggregate is scalar.
221 -- Indices is the current list of expressions used to index the
222 -- object we are writing into.
224 -- Flist is an expression representing the finalization list on which
225 -- to attach the controlled components if any.
227 function Number_Of_Choices (N : Node_Id) return Nat;
228 -- Returns the number of discrete choices (not including the others choice
229 -- if present) contained in (sub-)aggregate N.
231 function Late_Expansion
235 Flist : Node_Id := Empty;
236 Obj : Entity_Id := Empty) return List_Id;
237 -- N is a nested (record or array) aggregate that has been marked with
238 -- 'Delay_Expansion'. Typ is the expected type of the aggregate and Target
239 -- is a (duplicable) expression that will hold the result of the aggregate
240 -- expansion. Flist is the finalization list to be used to attach
241 -- controlled components. 'Obj' when non empty, carries the original
242 -- object being initialized in order to know if it needs to be attached to
243 -- the previous parameter which may not be the case in the case where
244 -- Finalize_Storage_Only is set. Basically this procedure is used to
245 -- implement top-down expansions of nested aggregates. This is necessary
246 -- for avoiding temporaries at each level as well as for propagating the
247 -- right internal finalization list.
249 function Make_OK_Assignment_Statement
252 Expression : Node_Id) return Node_Id;
253 -- This is like Make_Assignment_Statement, except that Assignment_OK
254 -- is set in the left operand. All assignments built by this unit
255 -- use this routine. This is needed to deal with assignments to
256 -- initialized constants that are done in place.
258 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
259 -- Given an array aggregate, this function handles the case of a packed
260 -- array aggregate with all constant values, where the aggregate can be
261 -- evaluated at compile time. If this is possible, then N is rewritten
262 -- to be its proper compile time value with all the components properly
263 -- assembled. The expression is analyzed and resolved and True is
264 -- returned. If this transformation is not possible, N is unchanged
265 -- and False is returned
267 function Safe_Slice_Assignment (N : Node_Id) return Boolean;
268 -- If a slice assignment has an aggregate with a single others_choice,
269 -- the assignment can be done in place even if bounds are not static,
270 -- by converting it into a loop over the discrete range of the slice.
272 ---------------------------------
273 -- Backend_Processing_Possible --
274 ---------------------------------
276 -- Backend processing by Gigi/gcc is possible only if all the following
277 -- conditions are met:
279 -- 1. N is fully positional
281 -- 2. N is not a bit-packed array aggregate;
283 -- 3. The size of N's array type must be known at compile time. Note
284 -- that this implies that the component size is also known
286 -- 4. The array type of N does not follow the Fortran layout convention
287 -- or if it does it must be 1 dimensional.
289 -- 5. The array component type is tagged, which may necessitate
290 -- reassignment of proper tags.
292 -- 6. The array component type might have unaligned bit components
294 function Backend_Processing_Possible (N : Node_Id) return Boolean is
295 Typ : constant Entity_Id := Etype (N);
296 -- Typ is the correct constrained array subtype of the aggregate
298 function Static_Check (N : Node_Id; Index : Node_Id) return Boolean;
299 -- Recursively checks that N is fully positional, returns true if so
305 function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is
309 -- Check for component associations
311 if Present (Component_Associations (N)) then
315 -- Recurse to check subaggregates, which may appear in qualified
316 -- expressions. If delayed, the front-end will have to expand.
318 Expr := First (Expressions (N));
320 while Present (Expr) loop
322 if Is_Delayed_Aggregate (Expr) then
326 if Present (Next_Index (Index))
327 and then not Static_Check (Expr, Next_Index (Index))
338 -- Start of processing for Backend_Processing_Possible
341 -- Checks 2 (array must not be bit packed)
343 if Is_Bit_Packed_Array (Typ) then
347 -- Checks 4 (array must not be multi-dimensional Fortran case)
349 if Convention (Typ) = Convention_Fortran
350 and then Number_Dimensions (Typ) > 1
355 -- Checks 3 (size of array must be known at compile time)
357 if not Size_Known_At_Compile_Time (Typ) then
361 -- Checks 1 (aggregate must be fully positional)
363 if not Static_Check (N, First_Index (Typ)) then
367 -- Checks 5 (if the component type is tagged, then we may need
368 -- to do tag adjustments; perhaps this should be refined to check for
369 -- any component associations that actually need tag adjustment,
370 -- along the lines of the test that is carried out in
371 -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps for record aggregates
372 -- with tagged components, but not clear whether it's worthwhile ???;
373 -- in the case of the JVM, object tags are handled implicitly)
375 if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then
379 -- Checks 6 (component type must not have bit aligned components)
381 if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then
385 -- Backend processing is possible
387 Set_Compile_Time_Known_Aggregate (N, True);
388 Set_Size_Known_At_Compile_Time (Etype (N), True);
390 end Backend_Processing_Possible;
392 ---------------------------
393 -- Build_Array_Aggr_Code --
394 ---------------------------
396 -- The code that we generate from a one dimensional aggregate is
398 -- 1. If the sub-aggregate contains discrete choices we
400 -- (a) Sort the discrete choices
402 -- (b) Otherwise for each discrete choice that specifies a range we
403 -- emit a loop. If a range specifies a maximum of three values, or
404 -- we are dealing with an expression we emit a sequence of
405 -- assignments instead of a loop.
407 -- (c) Generate the remaining loops to cover the others choice if any
409 -- 2. If the aggregate contains positional elements we
411 -- (a) translate the positional elements in a series of assignments
413 -- (b) Generate a final loop to cover the others choice if any.
414 -- Note that this final loop has to be a while loop since the case
416 -- L : Integer := Integer'Last;
417 -- H : Integer := Integer'Last;
418 -- A : array (L .. H) := (1, others =>0);
420 -- cannot be handled by a for loop. Thus for the following
422 -- array (L .. H) := (.. positional elements.., others =>E);
424 -- we always generate something like:
426 -- J : Index_Type := Index_Of_Last_Positional_Element;
428 -- J := Index_Base'Succ (J)
432 function Build_Array_Aggr_Code
437 Scalar_Comp : Boolean;
438 Indices : List_Id := No_List;
439 Flist : Node_Id := Empty) return List_Id
441 Loc : constant Source_Ptr := Sloc (N);
442 Index_Base : constant Entity_Id := Base_Type (Etype (Index));
443 Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base);
444 Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);
446 function Add (Val : Int; To : Node_Id) return Node_Id;
447 -- Returns an expression where Val is added to expression To, unless
448 -- To+Val is provably out of To's base type range. To must be an
449 -- already analyzed expression.
451 function Empty_Range (L, H : Node_Id) return Boolean;
452 -- Returns True if the range defined by L .. H is certainly empty
454 function Equal (L, H : Node_Id) return Boolean;
455 -- Returns True if L = H for sure
457 function Index_Base_Name return Node_Id;
458 -- Returns a new reference to the index type name
460 function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
461 -- Ind must be a side-effect free expression. If the input aggregate
462 -- N to Build_Loop contains no sub-aggregates, then this function
463 -- returns the assignment statement:
465 -- Into (Indices, Ind) := Expr;
467 -- Otherwise we call Build_Code recursively
469 -- Ada 2005 (AI-287): In case of default initialized component, Expr
470 -- is empty and we generate a call to the corresponding IP subprogram.
472 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
473 -- Nodes L and H must be side-effect free expressions.
474 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
475 -- This routine returns the for loop statement
477 -- for J in Index_Base'(L) .. Index_Base'(H) loop
478 -- Into (Indices, J) := Expr;
481 -- Otherwise we call Build_Code recursively.
482 -- As an optimization if the loop covers 3 or less scalar elements we
483 -- generate a sequence of assignments.
485 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
486 -- Nodes L and H must be side-effect free expressions.
487 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
488 -- This routine returns the while loop statement
490 -- J : Index_Base := L;
492 -- J := Index_Base'Succ (J);
493 -- Into (Indices, J) := Expr;
496 -- Otherwise we call Build_Code recursively
498 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
499 function Local_Expr_Value (E : Node_Id) return Uint;
500 -- These two Local routines are used to replace the corresponding ones
501 -- in sem_eval because while processing the bounds of an aggregate with
502 -- discrete choices whose index type is an enumeration, we build static
503 -- expressions not recognized by Compile_Time_Known_Value as such since
504 -- they have not yet been analyzed and resolved. All the expressions in
505 -- question are things like Index_Base_Name'Val (Const) which we can
506 -- easily recognize as being constant.
512 function Add (Val : Int; To : Node_Id) return Node_Id is
517 U_Val : constant Uint := UI_From_Int (Val);
520 -- Note: do not try to optimize the case of Val = 0, because
521 -- we need to build a new node with the proper Sloc value anyway.
523 -- First test if we can do constant folding
525 if Local_Compile_Time_Known_Value (To) then
526 U_To := Local_Expr_Value (To) + Val;
528 -- Determine if our constant is outside the range of the index.
529 -- If so return an Empty node. This empty node will be caught
530 -- by Empty_Range below.
532 if Compile_Time_Known_Value (Index_Base_L)
533 and then U_To < Expr_Value (Index_Base_L)
537 elsif Compile_Time_Known_Value (Index_Base_H)
538 and then U_To > Expr_Value (Index_Base_H)
543 Expr_Pos := Make_Integer_Literal (Loc, U_To);
544 Set_Is_Static_Expression (Expr_Pos);
546 if not Is_Enumeration_Type (Index_Base) then
549 -- If we are dealing with enumeration return
550 -- Index_Base'Val (Expr_Pos)
554 Make_Attribute_Reference
556 Prefix => Index_Base_Name,
557 Attribute_Name => Name_Val,
558 Expressions => New_List (Expr_Pos));
564 -- If we are here no constant folding possible
566 if not Is_Enumeration_Type (Index_Base) then
569 Left_Opnd => Duplicate_Subexpr (To),
570 Right_Opnd => Make_Integer_Literal (Loc, U_Val));
572 -- If we are dealing with enumeration return
573 -- Index_Base'Val (Index_Base'Pos (To) + Val)
577 Make_Attribute_Reference
579 Prefix => Index_Base_Name,
580 Attribute_Name => Name_Pos,
581 Expressions => New_List (Duplicate_Subexpr (To)));
586 Right_Opnd => Make_Integer_Literal (Loc, U_Val));
589 Make_Attribute_Reference
591 Prefix => Index_Base_Name,
592 Attribute_Name => Name_Val,
593 Expressions => New_List (Expr_Pos));
603 function Empty_Range (L, H : Node_Id) return Boolean is
604 Is_Empty : Boolean := False;
609 -- First check if L or H were already detected as overflowing the
610 -- index base range type by function Add above. If this is so Add
611 -- returns the empty node.
613 if No (L) or else No (H) then
620 -- L > H range is empty
626 -- B_L > H range must be empty
632 -- L > B_H range must be empty
636 High := Index_Base_H;
639 if Local_Compile_Time_Known_Value (Low)
640 and then Local_Compile_Time_Known_Value (High)
643 UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High));
656 function Equal (L, H : Node_Id) return Boolean is
661 elsif Local_Compile_Time_Known_Value (L)
662 and then Local_Compile_Time_Known_Value (H)
664 return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H));
674 function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
675 L : constant List_Id := New_List;
679 New_Indices : List_Id;
680 Indexed_Comp : Node_Id;
682 Comp_Type : Entity_Id := Empty;
684 function Add_Loop_Actions (Lis : List_Id) return List_Id;
685 -- Collect insert_actions generated in the construction of a
686 -- loop, and prepend them to the sequence of assignments to
687 -- complete the eventual body of the loop.
689 ----------------------
690 -- Add_Loop_Actions --
691 ----------------------
693 function Add_Loop_Actions (Lis : List_Id) return List_Id is
697 -- Ada 2005 (AI-287): Do nothing else in case of default
698 -- initialized component.
700 if not Present (Expr) then
703 elsif Nkind (Parent (Expr)) = N_Component_Association
704 and then Present (Loop_Actions (Parent (Expr)))
706 Append_List (Lis, Loop_Actions (Parent (Expr)));
707 Res := Loop_Actions (Parent (Expr));
708 Set_Loop_Actions (Parent (Expr), No_List);
714 end Add_Loop_Actions;
716 -- Start of processing for Gen_Assign
720 New_Indices := New_List;
722 New_Indices := New_Copy_List_Tree (Indices);
725 Append_To (New_Indices, Ind);
727 if Present (Flist) then
728 F := New_Copy_Tree (Flist);
730 elsif Present (Etype (N)) and then Controlled_Type (Etype (N)) then
731 if Is_Entity_Name (Into)
732 and then Present (Scope (Entity (Into)))
734 F := Find_Final_List (Scope (Entity (Into)));
736 F := Find_Final_List (Current_Scope);
742 if Present (Next_Index (Index)) then
745 Build_Array_Aggr_Code
748 Index => Next_Index (Index),
750 Scalar_Comp => Scalar_Comp,
751 Indices => New_Indices,
755 -- If we get here then we are at a bottom-level (sub-)aggregate
759 (Make_Indexed_Component (Loc,
760 Prefix => New_Copy_Tree (Into),
761 Expressions => New_Indices));
763 Set_Assignment_OK (Indexed_Comp);
765 -- Ada 2005 (AI-287): In case of default initialized component, Expr
766 -- is not present (and therefore we also initialize Expr_Q to empty).
768 if not Present (Expr) then
770 elsif Nkind (Expr) = N_Qualified_Expression then
771 Expr_Q := Expression (Expr);
776 if Present (Etype (N))
777 and then Etype (N) /= Any_Composite
779 Comp_Type := Component_Type (Etype (N));
780 pragma Assert (Comp_Type = Ctype); -- AI-287
782 elsif Present (Next (First (New_Indices))) then
784 -- Ada 2005 (AI-287): Do nothing in case of default initialized
785 -- component because we have received the component type in
786 -- the formal parameter Ctype.
788 -- ??? Some assert pragmas have been added to check if this new
789 -- formal can be used to replace this code in all cases.
791 if Present (Expr) then
793 -- This is a multidimensional array. Recover the component
794 -- type from the outermost aggregate, because subaggregates
795 -- do not have an assigned type.
798 P : Node_Id := Parent (Expr);
801 while Present (P) loop
802 if Nkind (P) = N_Aggregate
803 and then Present (Etype (P))
805 Comp_Type := Component_Type (Etype (P));
813 pragma Assert (Comp_Type = Ctype); -- AI-287
818 -- Ada 2005 (AI-287): We only analyze the expression in case of non-
819 -- default initialized components (otherwise Expr_Q is not present).
822 and then (Nkind (Expr_Q) = N_Aggregate
823 or else Nkind (Expr_Q) = N_Extension_Aggregate)
825 -- At this stage the Expression may not have been
826 -- analyzed yet because the array aggregate code has not
827 -- been updated to use the Expansion_Delayed flag and
828 -- avoid analysis altogether to solve the same problem
829 -- (see Resolve_Aggr_Expr). So let us do the analysis of
830 -- non-array aggregates now in order to get the value of
831 -- Expansion_Delayed flag for the inner aggregate ???
833 if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then
834 Analyze_And_Resolve (Expr_Q, Comp_Type);
837 if Is_Delayed_Aggregate (Expr_Q) then
839 -- This is either a subaggregate of a multidimentional array,
840 -- or a component of an array type whose component type is
841 -- also an array. In the latter case, the expression may have
842 -- component associations that provide different bounds from
843 -- those of the component type, and sliding must occur. Instead
844 -- of decomposing the current aggregate assignment, force the
845 -- re-analysis of the assignment, so that a temporary will be
846 -- generated in the usual fashion, and sliding will take place.
848 if Nkind (Parent (N)) = N_Assignment_Statement
849 and then Is_Array_Type (Comp_Type)
850 and then Present (Component_Associations (Expr_Q))
851 and then Must_Slide (Comp_Type, Etype (Expr_Q))
853 Set_Expansion_Delayed (Expr_Q, False);
854 Set_Analyzed (Expr_Q, False);
860 Expr_Q, Etype (Expr_Q), Indexed_Comp, F));
865 -- Ada 2005 (AI-287): In case of default initialized component, call
866 -- the initialization subprogram associated with the component type.
868 if not Present (Expr) then
870 if Present (Base_Init_Proc (Etype (Ctype)))
871 or else Has_Task (Base_Type (Ctype))
874 Build_Initialization_Call (Loc,
875 Id_Ref => Indexed_Comp,
877 With_Default_Init => True));
881 -- Now generate the assignment with no associated controlled
882 -- actions since the target of the assignment may not have
883 -- been initialized, it is not possible to Finalize it as
884 -- expected by normal controlled assignment. The rest of the
885 -- controlled actions are done manually with the proper
886 -- finalization list coming from the context.
889 Make_OK_Assignment_Statement (Loc,
890 Name => Indexed_Comp,
891 Expression => New_Copy_Tree (Expr));
893 if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
894 Set_No_Ctrl_Actions (A);
899 -- Adjust the tag if tagged (because of possible view
900 -- conversions), unless compiling for the Java VM
901 -- where tags are implicit.
903 if Present (Comp_Type)
904 and then Is_Tagged_Type (Comp_Type)
908 Make_OK_Assignment_Statement (Loc,
910 Make_Selected_Component (Loc,
911 Prefix => New_Copy_Tree (Indexed_Comp),
914 (First_Tag_Component (Comp_Type), Loc)),
917 Unchecked_Convert_To (RTE (RE_Tag),
919 (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
925 -- Adjust and Attach the component to the proper final list
926 -- which can be the controller of the outer record object or
927 -- the final list associated with the scope
929 if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
932 Ref => New_Copy_Tree (Indexed_Comp),
935 With_Attach => Make_Integer_Literal (Loc, 1)));
939 return Add_Loop_Actions (L);
946 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
950 -- Index_Base'(L) .. Index_Base'(H)
952 L_Iteration_Scheme : Node_Id;
953 -- L_J in Index_Base'(L) .. Index_Base'(H)
956 -- The statements to execute in the loop
958 S : constant List_Id := New_List;
959 -- List of statements
962 -- Copy of expression tree, used for checking purposes
965 -- If loop bounds define an empty range return the null statement
967 if Empty_Range (L, H) then
968 Append_To (S, Make_Null_Statement (Loc));
970 -- Ada 2005 (AI-287): Nothing else need to be done in case of
971 -- default initialized component.
973 if not Present (Expr) then
977 -- The expression must be type-checked even though no component
978 -- of the aggregate will have this value. This is done only for
979 -- actual components of the array, not for subaggregates. Do
980 -- the check on a copy, because the expression may be shared
981 -- among several choices, some of which might be non-null.
983 if Present (Etype (N))
984 and then Is_Array_Type (Etype (N))
985 and then No (Next_Index (Index))
987 Expander_Mode_Save_And_Set (False);
988 Tcopy := New_Copy_Tree (Expr);
989 Set_Parent (Tcopy, N);
990 Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
991 Expander_Mode_Restore;
997 -- If loop bounds are the same then generate an assignment
999 elsif Equal (L, H) then
1000 return Gen_Assign (New_Copy_Tree (L), Expr);
1002 -- If H - L <= 2 then generate a sequence of assignments
1003 -- when we are processing the bottom most aggregate and it contains
1004 -- scalar components.
1006 elsif No (Next_Index (Index))
1007 and then Scalar_Comp
1008 and then Local_Compile_Time_Known_Value (L)
1009 and then Local_Compile_Time_Known_Value (H)
1010 and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
1013 Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
1014 Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
1016 if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then
1017 Append_List_To (S, Gen_Assign (Add (2, To => L), Expr));
1023 -- Otherwise construct the loop, starting with the loop index L_J
1025 L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
1027 -- Construct "L .. H"
1032 Low_Bound => Make_Qualified_Expression
1034 Subtype_Mark => Index_Base_Name,
1036 High_Bound => Make_Qualified_Expression
1038 Subtype_Mark => Index_Base_Name,
1041 -- Construct "for L_J in Index_Base range L .. H"
1043 L_Iteration_Scheme :=
1044 Make_Iteration_Scheme
1046 Loop_Parameter_Specification =>
1047 Make_Loop_Parameter_Specification
1049 Defining_Identifier => L_J,
1050 Discrete_Subtype_Definition => L_Range));
1052 -- Construct the statements to execute in the loop body
1054 L_Body := Gen_Assign (New_Reference_To (L_J, Loc), Expr);
1056 -- Construct the final loop
1058 Append_To (S, Make_Implicit_Loop_Statement
1060 Identifier => Empty,
1061 Iteration_Scheme => L_Iteration_Scheme,
1062 Statements => L_Body));
1071 -- The code built is
1073 -- W_J : Index_Base := L;
1074 -- while W_J < H loop
1075 -- W_J := Index_Base'Succ (W);
1079 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is
1083 -- W_J : Base_Type := L;
1085 W_Iteration_Scheme : Node_Id;
1088 W_Index_Succ : Node_Id;
1089 -- Index_Base'Succ (J)
1091 W_Increment : Node_Id;
1092 -- W_J := Index_Base'Succ (W)
1094 W_Body : constant List_Id := New_List;
1095 -- The statements to execute in the loop
1097 S : constant List_Id := New_List;
1098 -- list of statement
1101 -- If loop bounds define an empty range or are equal return null
1103 if Empty_Range (L, H) or else Equal (L, H) then
1104 Append_To (S, Make_Null_Statement (Loc));
1108 -- Build the decl of W_J
1110 W_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
1112 Make_Object_Declaration
1114 Defining_Identifier => W_J,
1115 Object_Definition => Index_Base_Name,
1118 -- Theoretically we should do a New_Copy_Tree (L) here, but we know
1119 -- that in this particular case L is a fresh Expr generated by
1120 -- Add which we are the only ones to use.
1122 Append_To (S, W_Decl);
1124 -- Construct " while W_J < H"
1126 W_Iteration_Scheme :=
1127 Make_Iteration_Scheme
1129 Condition => Make_Op_Lt
1131 Left_Opnd => New_Reference_To (W_J, Loc),
1132 Right_Opnd => New_Copy_Tree (H)));
1134 -- Construct the statements to execute in the loop body
1137 Make_Attribute_Reference
1139 Prefix => Index_Base_Name,
1140 Attribute_Name => Name_Succ,
1141 Expressions => New_List (New_Reference_To (W_J, Loc)));
1144 Make_OK_Assignment_Statement
1146 Name => New_Reference_To (W_J, Loc),
1147 Expression => W_Index_Succ);
1149 Append_To (W_Body, W_Increment);
1150 Append_List_To (W_Body,
1151 Gen_Assign (New_Reference_To (W_J, Loc), Expr));
1153 -- Construct the final loop
1155 Append_To (S, Make_Implicit_Loop_Statement
1157 Identifier => Empty,
1158 Iteration_Scheme => W_Iteration_Scheme,
1159 Statements => W_Body));
1164 ---------------------
1165 -- Index_Base_Name --
1166 ---------------------
1168 function Index_Base_Name return Node_Id is
1170 return New_Reference_To (Index_Base, Sloc (N));
1171 end Index_Base_Name;
1173 ------------------------------------
1174 -- Local_Compile_Time_Known_Value --
1175 ------------------------------------
1177 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is
1179 return Compile_Time_Known_Value (E)
1181 (Nkind (E) = N_Attribute_Reference
1182 and then Attribute_Name (E) = Name_Val
1183 and then Compile_Time_Known_Value (First (Expressions (E))));
1184 end Local_Compile_Time_Known_Value;
1186 ----------------------
1187 -- Local_Expr_Value --
1188 ----------------------
1190 function Local_Expr_Value (E : Node_Id) return Uint is
1192 if Compile_Time_Known_Value (E) then
1193 return Expr_Value (E);
1195 return Expr_Value (First (Expressions (E)));
1197 end Local_Expr_Value;
1199 -- Build_Array_Aggr_Code Variables
1206 Others_Expr : Node_Id := Empty;
1207 Others_Mbox_Present : Boolean := False;
1209 Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
1210 Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
1211 -- The aggregate bounds of this specific sub-aggregate. Note that if
1212 -- the code generated by Build_Array_Aggr_Code is executed then these
1213 -- bounds are OK. Otherwise a Constraint_Error would have been raised.
1215 Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L);
1216 Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
1217 -- After Duplicate_Subexpr these are side-effect free
1222 Nb_Choices : Nat := 0;
1223 Table : Case_Table_Type (1 .. Number_Of_Choices (N));
1224 -- Used to sort all the different choice values
1227 -- Number of elements in the positional aggregate
1229 New_Code : constant List_Id := New_List;
1231 -- Start of processing for Build_Array_Aggr_Code
1234 -- First before we start, a special case. if we have a bit packed
1235 -- array represented as a modular type, then clear the value to
1236 -- zero first, to ensure that unused bits are properly cleared.
1241 and then Is_Bit_Packed_Array (Typ)
1242 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ))
1244 Append_To (New_Code,
1245 Make_Assignment_Statement (Loc,
1246 Name => New_Copy_Tree (Into),
1248 Unchecked_Convert_To (Typ,
1249 Make_Integer_Literal (Loc, Uint_0))));
1253 -- STEP 1: Process component associations
1254 -- For those associations that may generate a loop, initialize
1255 -- Loop_Actions to collect inserted actions that may be crated.
1257 if No (Expressions (N)) then
1259 -- STEP 1 (a): Sort the discrete choices
1261 Assoc := First (Component_Associations (N));
1262 while Present (Assoc) loop
1263 Choice := First (Choices (Assoc));
1264 while Present (Choice) loop
1265 if Nkind (Choice) = N_Others_Choice then
1266 Set_Loop_Actions (Assoc, New_List);
1268 if Box_Present (Assoc) then
1269 Others_Mbox_Present := True;
1271 Others_Expr := Expression (Assoc);
1276 Get_Index_Bounds (Choice, Low, High);
1279 Set_Loop_Actions (Assoc, New_List);
1282 Nb_Choices := Nb_Choices + 1;
1283 if Box_Present (Assoc) then
1284 Table (Nb_Choices) := (Choice_Lo => Low,
1286 Choice_Node => Empty);
1288 Table (Nb_Choices) := (Choice_Lo => Low,
1290 Choice_Node => Expression (Assoc));
1298 -- If there is more than one set of choices these must be static
1299 -- and we can therefore sort them. Remember that Nb_Choices does not
1300 -- account for an others choice.
1302 if Nb_Choices > 1 then
1303 Sort_Case_Table (Table);
1306 -- STEP 1 (b): take care of the whole set of discrete choices
1308 for J in 1 .. Nb_Choices loop
1309 Low := Table (J).Choice_Lo;
1310 High := Table (J).Choice_Hi;
1311 Expr := Table (J).Choice_Node;
1312 Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
1315 -- STEP 1 (c): generate the remaining loops to cover others choice
1316 -- We don't need to generate loops over empty gaps, but if there is
1317 -- a single empty range we must analyze the expression for semantics
1319 if Present (Others_Expr) or else Others_Mbox_Present then
1321 First : Boolean := True;
1324 for J in 0 .. Nb_Choices loop
1328 Low := Add (1, To => Table (J).Choice_Hi);
1331 if J = Nb_Choices then
1334 High := Add (-1, To => Table (J + 1).Choice_Lo);
1337 -- If this is an expansion within an init proc, make
1338 -- sure that discriminant references are replaced by
1339 -- the corresponding discriminal.
1341 if Inside_Init_Proc then
1342 if Is_Entity_Name (Low)
1343 and then Ekind (Entity (Low)) = E_Discriminant
1345 Set_Entity (Low, Discriminal (Entity (Low)));
1348 if Is_Entity_Name (High)
1349 and then Ekind (Entity (High)) = E_Discriminant
1351 Set_Entity (High, Discriminal (Entity (High)));
1356 or else not Empty_Range (Low, High)
1360 (Gen_Loop (Low, High, Others_Expr), To => New_Code);
1366 -- STEP 2: Process positional components
1369 -- STEP 2 (a): Generate the assignments for each positional element
1370 -- Note that here we have to use Aggr_L rather than Aggr_Low because
1371 -- Aggr_L is analyzed and Add wants an analyzed expression.
1373 Expr := First (Expressions (N));
1376 while Present (Expr) loop
1377 Nb_Elements := Nb_Elements + 1;
1378 Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr),
1383 -- STEP 2 (b): Generate final loop if an others choice is present
1384 -- Here Nb_Elements gives the offset of the last positional element.
1386 if Present (Component_Associations (N)) then
1387 Assoc := Last (Component_Associations (N));
1389 -- Ada 2005 (AI-287)
1391 if Box_Present (Assoc) then
1392 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1397 Expr := Expression (Assoc);
1399 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1408 end Build_Array_Aggr_Code;
1410 ----------------------------
1411 -- Build_Record_Aggr_Code --
1412 ----------------------------
1414 function Build_Record_Aggr_Code
1418 Flist : Node_Id := Empty;
1419 Obj : Entity_Id := Empty;
1420 Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id
1422 Loc : constant Source_Ptr := Sloc (N);
1423 L : constant List_Id := New_List;
1424 Start_L : constant List_Id := New_List;
1425 N_Typ : constant Entity_Id := Etype (N);
1431 Comp_Type : Entity_Id;
1432 Selector : Entity_Id;
1433 Comp_Expr : Node_Id;
1436 Internal_Final_List : Node_Id;
1438 -- If this is an internal aggregate, the External_Final_List is an
1439 -- expression for the controller record of the enclosing type.
1440 -- If the current aggregate has several controlled components, this
1441 -- expression will appear in several calls to attach to the finali-
1442 -- zation list, and it must not be shared.
1444 External_Final_List : Node_Id;
1445 Ancestor_Is_Expression : Boolean := False;
1446 Ancestor_Is_Subtype_Mark : Boolean := False;
1448 Init_Typ : Entity_Id := Empty;
1451 function Get_Constraint_Association (T : Entity_Id) return Node_Id;
1452 -- Returns the first discriminant association in the constraint
1453 -- associated with T, if any, otherwise returns Empty.
1455 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
1456 -- Returns the value that the given discriminant of an ancestor
1457 -- type should receive (in the absence of a conflict with the
1458 -- value provided by an ancestor part of an extension aggregate).
1460 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id);
1461 -- Check that each of the discriminant values defined by the
1462 -- ancestor part of an extension aggregate match the corresponding
1463 -- values provided by either an association of the aggregate or
1464 -- by the constraint imposed by a parent type (RM95-4.3.2(8)).
1466 function Init_Controller
1471 Init_Pr : Boolean) return List_Id;
1472 -- returns the list of statements necessary to initialize the internal
1473 -- controller of the (possible) ancestor typ into target and attach
1474 -- it to finalization list F. Init_Pr conditions the call to the
1475 -- init proc since it may already be done due to ancestor initialization
1477 ---------------------------------
1478 -- Ancestor_Discriminant_Value --
1479 ---------------------------------
1481 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is
1483 Assoc_Elmt : Elmt_Id;
1484 Aggr_Comp : Entity_Id;
1485 Corresp_Disc : Entity_Id;
1486 Current_Typ : Entity_Id := Base_Type (Typ);
1487 Parent_Typ : Entity_Id;
1488 Parent_Disc : Entity_Id;
1489 Save_Assoc : Node_Id := Empty;
1492 -- First check any discriminant associations to see if
1493 -- any of them provide a value for the discriminant.
1495 if Present (Discriminant_Specifications (Parent (Current_Typ))) then
1496 Assoc := First (Component_Associations (N));
1497 while Present (Assoc) loop
1498 Aggr_Comp := Entity (First (Choices (Assoc)));
1500 if Ekind (Aggr_Comp) = E_Discriminant then
1501 Save_Assoc := Expression (Assoc);
1503 Corresp_Disc := Corresponding_Discriminant (Aggr_Comp);
1504 while Present (Corresp_Disc) loop
1505 -- If found a corresponding discriminant then return
1506 -- the value given in the aggregate. (Note: this is
1507 -- not correct in the presence of side effects. ???)
1509 if Disc = Corresp_Disc then
1510 return Duplicate_Subexpr (Expression (Assoc));
1514 Corresponding_Discriminant (Corresp_Disc);
1522 -- No match found in aggregate, so chain up parent types to find
1523 -- a constraint that defines the value of the discriminant.
1525 Parent_Typ := Etype (Current_Typ);
1526 while Current_Typ /= Parent_Typ loop
1527 if Has_Discriminants (Parent_Typ) then
1528 Parent_Disc := First_Discriminant (Parent_Typ);
1530 -- We either get the association from the subtype indication
1531 -- of the type definition itself, or from the discriminant
1532 -- constraint associated with the type entity (which is
1533 -- preferable, but it's not always present ???)
1535 if Is_Empty_Elmt_List (
1536 Discriminant_Constraint (Current_Typ))
1538 Assoc := Get_Constraint_Association (Current_Typ);
1539 Assoc_Elmt := No_Elmt;
1542 First_Elmt (Discriminant_Constraint (Current_Typ));
1543 Assoc := Node (Assoc_Elmt);
1546 -- Traverse the discriminants of the parent type looking
1547 -- for one that corresponds.
1549 while Present (Parent_Disc) and then Present (Assoc) loop
1550 Corresp_Disc := Parent_Disc;
1551 while Present (Corresp_Disc)
1552 and then Disc /= Corresp_Disc
1555 Corresponding_Discriminant (Corresp_Disc);
1558 if Disc = Corresp_Disc then
1559 if Nkind (Assoc) = N_Discriminant_Association then
1560 Assoc := Expression (Assoc);
1563 -- If the located association directly denotes
1564 -- a discriminant, then use the value of a saved
1565 -- association of the aggregate. This is a kludge
1566 -- to handle certain cases involving multiple
1567 -- discriminants mapped to a single discriminant
1568 -- of a descendant. It's not clear how to locate the
1569 -- appropriate discriminant value for such cases. ???
1571 if Is_Entity_Name (Assoc)
1572 and then Ekind (Entity (Assoc)) = E_Discriminant
1574 Assoc := Save_Assoc;
1577 return Duplicate_Subexpr (Assoc);
1580 Next_Discriminant (Parent_Disc);
1582 if No (Assoc_Elmt) then
1585 Next_Elmt (Assoc_Elmt);
1586 if Present (Assoc_Elmt) then
1587 Assoc := Node (Assoc_Elmt);
1595 Current_Typ := Parent_Typ;
1596 Parent_Typ := Etype (Current_Typ);
1599 -- In some cases there's no ancestor value to locate (such as
1600 -- when an ancestor part given by an expression defines the
1601 -- discriminant value).
1604 end Ancestor_Discriminant_Value;
1606 ----------------------------------
1607 -- Check_Ancestor_Discriminants --
1608 ----------------------------------
1610 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is
1611 Discr : Entity_Id := First_Discriminant (Base_Type (Anc_Typ));
1612 Disc_Value : Node_Id;
1616 while Present (Discr) loop
1617 Disc_Value := Ancestor_Discriminant_Value (Discr);
1619 if Present (Disc_Value) then
1620 Cond := Make_Op_Ne (Loc,
1622 Make_Selected_Component (Loc,
1623 Prefix => New_Copy_Tree (Target),
1624 Selector_Name => New_Occurrence_Of (Discr, Loc)),
1625 Right_Opnd => Disc_Value);
1628 Make_Raise_Constraint_Error (Loc,
1630 Reason => CE_Discriminant_Check_Failed));
1633 Next_Discriminant (Discr);
1635 end Check_Ancestor_Discriminants;
1637 --------------------------------
1638 -- Get_Constraint_Association --
1639 --------------------------------
1641 function Get_Constraint_Association (T : Entity_Id) return Node_Id is
1642 Typ_Def : constant Node_Id := Type_Definition (Parent (T));
1643 Indic : constant Node_Id := Subtype_Indication (Typ_Def);
1646 -- ??? Also need to cover case of a type mark denoting a subtype
1649 if Nkind (Indic) = N_Subtype_Indication
1650 and then Present (Constraint (Indic))
1652 return First (Constraints (Constraint (Indic)));
1656 end Get_Constraint_Association;
1658 ---------------------
1659 -- Init_controller --
1660 ---------------------
1662 function Init_Controller
1667 Init_Pr : Boolean) return List_Id
1669 L : constant List_Id := New_List;
1674 -- init-proc (target._controller);
1675 -- initialize (target._controller);
1676 -- Attach_to_Final_List (target._controller, F);
1679 Make_Selected_Component (Loc,
1680 Prefix => Convert_To (Typ, New_Copy_Tree (Target)),
1681 Selector_Name => Make_Identifier (Loc, Name_uController));
1682 Set_Assignment_OK (Ref);
1684 -- Ada 2005 (AI-287): Give support to default initialization of
1685 -- limited types and components.
1687 if (Nkind (Target) = N_Identifier
1688 and then Present (Etype (Target))
1689 and then Is_Limited_Type (Etype (Target)))
1691 (Nkind (Target) = N_Selected_Component
1692 and then Present (Etype (Selector_Name (Target)))
1693 and then Is_Limited_Type (Etype (Selector_Name (Target))))
1695 (Nkind (Target) = N_Unchecked_Type_Conversion
1696 and then Present (Etype (Target))
1697 and then Is_Limited_Type (Etype (Target)))
1699 (Nkind (Target) = N_Unchecked_Expression
1700 and then Nkind (Expression (Target)) = N_Indexed_Component
1701 and then Present (Etype (Prefix (Expression (Target))))
1702 and then Is_Limited_Type (Etype (Prefix (Expression (Target)))))
1706 Build_Initialization_Call (Loc,
1708 Typ => RTE (RE_Limited_Record_Controller),
1709 In_Init_Proc => Within_Init_Proc));
1713 Make_Procedure_Call_Statement (Loc,
1717 (RTE (RE_Limited_Record_Controller), Name_Initialize),
1719 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
1724 Build_Initialization_Call (Loc,
1726 Typ => RTE (RE_Record_Controller),
1727 In_Init_Proc => Within_Init_Proc));
1731 Make_Procedure_Call_Statement (Loc,
1735 (RTE (RE_Record_Controller), Name_Initialize),
1737 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
1743 Obj_Ref => New_Copy_Tree (Ref),
1745 With_Attach => Attach));
1747 end Init_Controller;
1749 -- Start of processing for Build_Record_Aggr_Code
1752 -- Deal with the ancestor part of extension aggregates
1753 -- or with the discriminants of the root type
1755 if Nkind (N) = N_Extension_Aggregate then
1757 A : constant Node_Id := Ancestor_Part (N);
1760 -- If the ancestor part is a subtype mark "T", we generate
1762 -- init-proc (T(tmp)); if T is constrained and
1763 -- init-proc (S(tmp)); where S applies an appropriate
1764 -- constraint if T is unconstrained
1766 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
1767 Ancestor_Is_Subtype_Mark := True;
1769 if Is_Constrained (Entity (A)) then
1770 Init_Typ := Entity (A);
1772 -- For an ancestor part given by an unconstrained type
1773 -- mark, create a subtype constrained by appropriate
1774 -- corresponding discriminant values coming from either
1775 -- associations of the aggregate or a constraint on
1776 -- a parent type. The subtype will be used to generate
1777 -- the correct default value for the ancestor part.
1779 elsif Has_Discriminants (Entity (A)) then
1781 Anc_Typ : constant Entity_Id := Entity (A);
1782 Anc_Constr : constant List_Id := New_List;
1783 Discrim : Entity_Id;
1784 Disc_Value : Node_Id;
1785 New_Indic : Node_Id;
1786 Subt_Decl : Node_Id;
1789 Discrim := First_Discriminant (Anc_Typ);
1790 while Present (Discrim) loop
1791 Disc_Value := Ancestor_Discriminant_Value (Discrim);
1792 Append_To (Anc_Constr, Disc_Value);
1793 Next_Discriminant (Discrim);
1797 Make_Subtype_Indication (Loc,
1798 Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc),
1800 Make_Index_Or_Discriminant_Constraint (Loc,
1801 Constraints => Anc_Constr));
1803 Init_Typ := Create_Itype (Ekind (Anc_Typ), N);
1806 Make_Subtype_Declaration (Loc,
1807 Defining_Identifier => Init_Typ,
1808 Subtype_Indication => New_Indic);
1810 -- Itypes must be analyzed with checks off
1811 -- Declaration must have a parent for proper
1812 -- handling of subsidiary actions.
1814 Set_Parent (Subt_Decl, N);
1815 Analyze (Subt_Decl, Suppress => All_Checks);
1819 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
1820 Set_Assignment_OK (Ref);
1822 if Has_Default_Init_Comps (N)
1823 or else Has_Task (Base_Type (Init_Typ))
1825 Append_List_To (Start_L,
1826 Build_Initialization_Call (Loc,
1829 In_Init_Proc => Within_Init_Proc,
1830 With_Default_Init => True));
1832 Append_List_To (Start_L,
1833 Build_Initialization_Call (Loc,
1836 In_Init_Proc => Within_Init_Proc));
1839 if Is_Constrained (Entity (A))
1840 and then Has_Discriminants (Entity (A))
1842 Check_Ancestor_Discriminants (Entity (A));
1845 -- Ada 2005 (AI-287): If the ancestor part is a limited type,
1846 -- a recursive call expands the ancestor.
1848 elsif Is_Limited_Type (Etype (A)) then
1849 Ancestor_Is_Expression := True;
1851 Append_List_To (Start_L,
1852 Build_Record_Aggr_Code (
1853 N => Expression (A),
1854 Typ => Etype (Expression (A)),
1858 Is_Limited_Ancestor_Expansion => True));
1860 -- If the ancestor part is an expression "E", we generate
1864 Ancestor_Is_Expression := True;
1865 Init_Typ := Etype (A);
1867 -- Assign the tag before doing the assignment to make sure
1868 -- that the dispatching call in the subsequent deep_adjust
1869 -- works properly (unless Java_VM, where tags are implicit).
1873 Make_OK_Assignment_Statement (Loc,
1875 Make_Selected_Component (Loc,
1876 Prefix => New_Copy_Tree (Target),
1879 (First_Tag_Component (Base_Type (Typ)), Loc)),
1882 Unchecked_Convert_To (RTE (RE_Tag),
1885 (Access_Disp_Table (Base_Type (Typ)))),
1888 Set_Assignment_OK (Name (Instr));
1889 Append_To (L, Instr);
1892 -- If the ancestor part is an aggregate, force its full
1893 -- expansion, which was delayed.
1895 if Nkind (A) = N_Qualified_Expression
1896 and then (Nkind (Expression (A)) = N_Aggregate
1898 Nkind (Expression (A)) = N_Extension_Aggregate)
1900 Set_Analyzed (A, False);
1901 Set_Analyzed (Expression (A), False);
1904 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
1905 Set_Assignment_OK (Ref);
1907 Make_Unsuppress_Block (Loc,
1908 Name_Discriminant_Check,
1910 Make_OK_Assignment_Statement (Loc,
1912 Expression => A))));
1914 if Has_Discriminants (Init_Typ) then
1915 Check_Ancestor_Discriminants (Init_Typ);
1920 -- Normal case (not an extension aggregate)
1923 -- Generate the discriminant expressions, component by component.
1924 -- If the base type is an unchecked union, the discriminants are
1925 -- unknown to the back-end and absent from a value of the type, so
1926 -- assignments for them are not emitted.
1928 if Has_Discriminants (Typ)
1929 and then not Is_Unchecked_Union (Base_Type (Typ))
1931 -- ??? The discriminants of the object not inherited in the type
1932 -- of the object should be initialized here
1936 -- Generate discriminant init values
1939 Discriminant : Entity_Id;
1940 Discriminant_Value : Node_Id;
1943 Discriminant := First_Stored_Discriminant (Typ);
1945 while Present (Discriminant) loop
1948 Make_Selected_Component (Loc,
1949 Prefix => New_Copy_Tree (Target),
1950 Selector_Name => New_Occurrence_Of (Discriminant, Loc));
1952 Discriminant_Value :=
1953 Get_Discriminant_Value (
1956 Discriminant_Constraint (N_Typ));
1959 Make_OK_Assignment_Statement (Loc,
1961 Expression => New_Copy_Tree (Discriminant_Value));
1963 Set_No_Ctrl_Actions (Instr);
1964 Append_To (L, Instr);
1966 Next_Stored_Discriminant (Discriminant);
1972 -- Generate the assignments, component by component
1974 -- tmp.comp1 := Expr1_From_Aggr;
1975 -- tmp.comp2 := Expr2_From_Aggr;
1978 Comp := First (Component_Associations (N));
1979 while Present (Comp) loop
1980 Selector := Entity (First (Choices (Comp)));
1982 -- Ada 2005 (AI-287): Default initialization of a limited component
1984 if Box_Present (Comp)
1985 and then Is_Limited_Type (Etype (Selector))
1987 -- Ada 2005 (AI-287): If the component type has tasks then
1988 -- generate the activation chain and master entities (except
1989 -- in case of an allocator because in that case these entities
1990 -- are generated by Build_Task_Allocate_Block_With_Init_Stmts).
1993 Ctype : constant Entity_Id := Etype (Selector);
1994 Inside_Allocator : Boolean := False;
1995 P : Node_Id := Parent (N);
1998 if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
1999 while Present (P) loop
2000 if Nkind (P) = N_Allocator then
2001 Inside_Allocator := True;
2008 if not Inside_Init_Proc and not Inside_Allocator then
2009 Build_Activation_Chain_Entity (N);
2011 if not Has_Master_Entity (Current_Scope) then
2012 Build_Master_Entity (Etype (N));
2019 Build_Initialization_Call (Loc,
2020 Id_Ref => Make_Selected_Component (Loc,
2021 Prefix => New_Copy_Tree (Target),
2022 Selector_Name => New_Occurrence_Of (Selector,
2024 Typ => Etype (Selector),
2025 With_Default_Init => True));
2032 if Ekind (Selector) /= E_Discriminant
2033 or else Nkind (N) = N_Extension_Aggregate
2035 Comp_Type := Etype (Selector);
2037 Make_Selected_Component (Loc,
2038 Prefix => New_Copy_Tree (Target),
2039 Selector_Name => New_Occurrence_Of (Selector, Loc));
2041 if Nkind (Expression (Comp)) = N_Qualified_Expression then
2042 Expr_Q := Expression (Expression (Comp));
2044 Expr_Q := Expression (Comp);
2047 -- The controller is the one of the parent type defining
2048 -- the component (in case of inherited components).
2050 if Controlled_Type (Comp_Type) then
2051 Internal_Final_List :=
2052 Make_Selected_Component (Loc,
2053 Prefix => Convert_To (
2054 Scope (Original_Record_Component (Selector)),
2055 New_Copy_Tree (Target)),
2057 Make_Identifier (Loc, Name_uController));
2059 Internal_Final_List :=
2060 Make_Selected_Component (Loc,
2061 Prefix => Internal_Final_List,
2062 Selector_Name => Make_Identifier (Loc, Name_F));
2064 -- The internal final list can be part of a constant object
2066 Set_Assignment_OK (Internal_Final_List);
2069 Internal_Final_List := Empty;
2074 if Is_Delayed_Aggregate (Expr_Q) then
2076 Late_Expansion (Expr_Q, Comp_Type, Comp_Expr,
2077 Internal_Final_List));
2081 Make_OK_Assignment_Statement (Loc,
2083 Expression => Expression (Comp));
2085 Set_No_Ctrl_Actions (Instr);
2086 Append_To (L, Instr);
2088 -- Adjust the tag if tagged (because of possible view
2089 -- conversions), unless compiling for the Java VM
2090 -- where tags are implicit.
2092 -- tmp.comp._tag := comp_typ'tag;
2094 if Is_Tagged_Type (Comp_Type) and then not Java_VM then
2096 Make_OK_Assignment_Statement (Loc,
2098 Make_Selected_Component (Loc,
2099 Prefix => New_Copy_Tree (Comp_Expr),
2102 (First_Tag_Component (Comp_Type), Loc)),
2105 Unchecked_Convert_To (RTE (RE_Tag),
2107 (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
2110 Append_To (L, Instr);
2113 -- Adjust and Attach the component to the proper controller
2114 -- Adjust (tmp.comp);
2115 -- Attach_To_Final_List (tmp.comp,
2116 -- comp_typ (tmp)._record_controller.f)
2118 if Controlled_Type (Comp_Type) then
2121 Ref => New_Copy_Tree (Comp_Expr),
2123 Flist_Ref => Internal_Final_List,
2124 With_Attach => Make_Integer_Literal (Loc, 1)));
2130 elsif Ekind (Selector) = E_Discriminant
2131 and then Nkind (N) /= N_Extension_Aggregate
2132 and then Nkind (Parent (N)) = N_Component_Association
2133 and then Is_Constrained (Typ)
2135 -- We must check that the discriminant value imposed by the
2136 -- context is the same as the value given in the subaggregate,
2137 -- because after the expansion into assignments there is no
2138 -- record on which to perform a regular discriminant check.
2145 D_Val := First_Elmt (Discriminant_Constraint (Typ));
2146 Disc := First_Discriminant (Typ);
2148 while Chars (Disc) /= Chars (Selector) loop
2149 Next_Discriminant (Disc);
2153 pragma Assert (Present (D_Val));
2156 Make_Raise_Constraint_Error (Loc,
2159 Left_Opnd => New_Copy_Tree (Node (D_Val)),
2160 Right_Opnd => Expression (Comp)),
2161 Reason => CE_Discriminant_Check_Failed));
2170 -- If the type is tagged, the tag needs to be initialized (unless
2171 -- compiling for the Java VM where tags are implicit). It is done
2172 -- late in the initialization process because in some cases, we call
2173 -- the init proc of an ancestor which will not leave out the right tag
2175 if Ancestor_Is_Expression then
2178 elsif Is_Tagged_Type (Typ) and then not Java_VM then
2180 Make_OK_Assignment_Statement (Loc,
2182 Make_Selected_Component (Loc,
2183 Prefix => New_Copy_Tree (Target),
2186 (First_Tag_Component (Base_Type (Typ)), Loc)),
2189 Unchecked_Convert_To (RTE (RE_Tag),
2191 (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))),
2194 Append_To (L, Instr);
2197 -- Now deal with the various controlled type data structure
2201 and then Finalize_Storage_Only (Typ)
2203 (Is_Library_Level_Entity (Obj)
2204 or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
2207 Attach := Make_Integer_Literal (Loc, 0);
2209 elsif Nkind (Parent (N)) = N_Qualified_Expression
2210 and then Nkind (Parent (Parent (N))) = N_Allocator
2212 Attach := Make_Integer_Literal (Loc, 2);
2215 Attach := Make_Integer_Literal (Loc, 1);
2218 -- Determine the external finalization list. It is either the
2219 -- finalization list of the outer-scope or the one coming from
2220 -- an outer aggregate. When the target is not a temporary, the
2221 -- proper scope is the scope of the target rather than the
2222 -- potentially transient current scope.
2224 if Controlled_Type (Typ) then
2225 if Present (Flist) then
2226 External_Final_List := New_Copy_Tree (Flist);
2228 elsif Is_Entity_Name (Target)
2229 and then Present (Scope (Entity (Target)))
2231 External_Final_List := Find_Final_List (Scope (Entity (Target)));
2234 External_Final_List := Find_Final_List (Current_Scope);
2238 External_Final_List := Empty;
2241 -- Initialize and attach the outer object in the is_controlled case
2243 if Is_Controlled (Typ) then
2244 if Ancestor_Is_Subtype_Mark then
2245 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2246 Set_Assignment_OK (Ref);
2248 Make_Procedure_Call_Statement (Loc,
2251 (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
2252 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
2255 if not Has_Controlled_Component (Typ) then
2256 Ref := New_Copy_Tree (Target);
2257 Set_Assignment_OK (Ref);
2261 Flist_Ref => New_Copy_Tree (External_Final_List),
2262 With_Attach => Attach));
2266 -- In the Has_Controlled component case, all the intermediate
2267 -- controllers must be initialized
2269 if Has_Controlled_Component (Typ)
2270 and not Is_Limited_Ancestor_Expansion
2273 Inner_Typ : Entity_Id;
2274 Outer_Typ : Entity_Id;
2279 Outer_Typ := Base_Type (Typ);
2281 -- Find outer type with a controller
2283 while Outer_Typ /= Init_Typ
2284 and then not Has_New_Controlled_Component (Outer_Typ)
2286 Outer_Typ := Etype (Outer_Typ);
2289 -- Attach it to the outer record controller to the
2290 -- external final list
2292 if Outer_Typ = Init_Typ then
2293 Append_List_To (Start_L,
2297 F => External_Final_List,
2299 Init_Pr => Ancestor_Is_Expression));
2302 Inner_Typ := Init_Typ;
2305 Append_List_To (Start_L,
2309 F => External_Final_List,
2313 Inner_Typ := Etype (Outer_Typ);
2315 not Is_Tagged_Type (Typ) or else Inner_Typ = Outer_Typ;
2318 -- The outer object has to be attached as well
2320 if Is_Controlled (Typ) then
2321 Ref := New_Copy_Tree (Target);
2322 Set_Assignment_OK (Ref);
2326 Flist_Ref => New_Copy_Tree (External_Final_List),
2327 With_Attach => New_Copy_Tree (Attach)));
2330 -- Initialize the internal controllers for tagged types with
2331 -- more than one controller.
2333 while not At_Root and then Inner_Typ /= Init_Typ loop
2334 if Has_New_Controlled_Component (Inner_Typ) then
2336 Make_Selected_Component (Loc,
2337 Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
2339 Make_Identifier (Loc, Name_uController));
2341 Make_Selected_Component (Loc,
2343 Selector_Name => Make_Identifier (Loc, Name_F));
2345 Append_List_To (Start_L,
2350 Attach => Make_Integer_Literal (Loc, 1),
2352 Outer_Typ := Inner_Typ;
2357 At_Root := Inner_Typ = Etype (Inner_Typ);
2358 Inner_Typ := Etype (Inner_Typ);
2361 -- If not done yet attach the controller of the ancestor part
2363 if Outer_Typ /= Init_Typ
2364 and then Inner_Typ = Init_Typ
2365 and then Has_Controlled_Component (Init_Typ)
2368 Make_Selected_Component (Loc,
2369 Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
2370 Selector_Name => Make_Identifier (Loc, Name_uController));
2372 Make_Selected_Component (Loc,
2374 Selector_Name => Make_Identifier (Loc, Name_F));
2376 Attach := Make_Integer_Literal (Loc, 1);
2377 Append_List_To (Start_L,
2383 Init_Pr => Ancestor_Is_Expression));
2388 Append_List_To (Start_L, L);
2390 end Build_Record_Aggr_Code;
2392 -------------------------------
2393 -- Convert_Aggr_In_Allocator --
2394 -------------------------------
2396 procedure Convert_Aggr_In_Allocator (Decl, Aggr : Node_Id) is
2397 Loc : constant Source_Ptr := Sloc (Aggr);
2398 Typ : constant Entity_Id := Etype (Aggr);
2399 Temp : constant Entity_Id := Defining_Identifier (Decl);
2401 Occ : constant Node_Id :=
2402 Unchecked_Convert_To (Typ,
2403 Make_Explicit_Dereference (Loc,
2404 New_Reference_To (Temp, Loc)));
2406 Access_Type : constant Entity_Id := Etype (Temp);
2409 if Is_Array_Type (Typ) then
2410 Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ);
2412 elsif Has_Default_Init_Comps (Aggr) then
2414 L : constant List_Id := New_List;
2415 Init_Stmts : List_Id;
2418 Init_Stmts := Late_Expansion (Aggr, Typ, Occ,
2419 Find_Final_List (Access_Type),
2420 Associated_Final_Chain (Base_Type (Access_Type)));
2422 Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
2423 Insert_Actions_After (Decl, L);
2427 Insert_Actions_After (Decl,
2428 Late_Expansion (Aggr, Typ, Occ,
2429 Find_Final_List (Access_Type),
2430 Associated_Final_Chain (Base_Type (Access_Type))));
2432 end Convert_Aggr_In_Allocator;
2434 --------------------------------
2435 -- Convert_Aggr_In_Assignment --
2436 --------------------------------
2438 procedure Convert_Aggr_In_Assignment (N : Node_Id) is
2439 Aggr : Node_Id := Expression (N);
2440 Typ : constant Entity_Id := Etype (Aggr);
2441 Occ : constant Node_Id := New_Copy_Tree (Name (N));
2444 if Nkind (Aggr) = N_Qualified_Expression then
2445 Aggr := Expression (Aggr);
2448 Insert_Actions_After (N,
2449 Late_Expansion (Aggr, Typ, Occ,
2450 Find_Final_List (Typ, New_Copy_Tree (Occ))));
2451 end Convert_Aggr_In_Assignment;
2453 ---------------------------------
2454 -- Convert_Aggr_In_Object_Decl --
2455 ---------------------------------
2457 procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is
2458 Obj : constant Entity_Id := Defining_Identifier (N);
2459 Aggr : Node_Id := Expression (N);
2460 Loc : constant Source_Ptr := Sloc (Aggr);
2461 Typ : constant Entity_Id := Etype (Aggr);
2462 Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
2464 function Discriminants_Ok return Boolean;
2465 -- If the object type is constrained, the discriminants in the
2466 -- aggregate must be checked against the discriminants of the subtype.
2467 -- This cannot be done using Apply_Discriminant_Checks because after
2468 -- expansion there is no aggregate left to check.
2470 ----------------------
2471 -- Discriminants_Ok --
2472 ----------------------
2474 function Discriminants_Ok return Boolean is
2475 Cond : Node_Id := Empty;
2484 D := First_Discriminant (Typ);
2485 Disc1 := First_Elmt (Discriminant_Constraint (Typ));
2486 Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj)));
2488 while Present (Disc1) and then Present (Disc2) loop
2489 Val1 := Node (Disc1);
2490 Val2 := Node (Disc2);
2492 if not Is_OK_Static_Expression (Val1)
2493 or else not Is_OK_Static_Expression (Val2)
2495 Check := Make_Op_Ne (Loc,
2496 Left_Opnd => Duplicate_Subexpr (Val1),
2497 Right_Opnd => Duplicate_Subexpr (Val2));
2503 Cond := Make_Or_Else (Loc,
2505 Right_Opnd => Check);
2508 elsif Expr_Value (Val1) /= Expr_Value (Val2) then
2509 Apply_Compile_Time_Constraint_Error (Aggr,
2510 Msg => "incorrect value for discriminant&?",
2511 Reason => CE_Discriminant_Check_Failed,
2516 Next_Discriminant (D);
2521 -- If any discriminant constraint is non-static, emit a check
2523 if Present (Cond) then
2525 Make_Raise_Constraint_Error (Loc,
2527 Reason => CE_Discriminant_Check_Failed));
2531 end Discriminants_Ok;
2533 -- Start of processing for Convert_Aggr_In_Object_Decl
2536 Set_Assignment_OK (Occ);
2538 if Nkind (Aggr) = N_Qualified_Expression then
2539 Aggr := Expression (Aggr);
2542 if Has_Discriminants (Typ)
2543 and then Typ /= Etype (Obj)
2544 and then Is_Constrained (Etype (Obj))
2545 and then not Discriminants_Ok
2550 Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj));
2551 Set_No_Initialization (N);
2552 Initialize_Discriminants (N, Typ);
2553 end Convert_Aggr_In_Object_Decl;
2555 -------------------------------------
2556 -- Convert_array_Aggr_In_Allocator --
2557 -------------------------------------
2559 procedure Convert_Array_Aggr_In_Allocator
2564 Aggr_Code : List_Id;
2565 Typ : constant Entity_Id := Etype (Aggr);
2566 Ctyp : constant Entity_Id := Component_Type (Typ);
2569 -- The target is an explicit dereference of the allocated object.
2570 -- Generate component assignments to it, as for an aggregate that
2571 -- appears on the right-hand side of an assignment statement.
2574 Build_Array_Aggr_Code (Aggr,
2576 Index => First_Index (Typ),
2578 Scalar_Comp => Is_Scalar_Type (Ctyp));
2580 Insert_Actions_After (Decl, Aggr_Code);
2581 end Convert_Array_Aggr_In_Allocator;
2583 ----------------------------
2584 -- Convert_To_Assignments --
2585 ----------------------------
2587 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
2588 Loc : constant Source_Ptr := Sloc (N);
2592 Target_Expr : Node_Id;
2593 Parent_Kind : Node_Kind;
2594 Unc_Decl : Boolean := False;
2595 Parent_Node : Node_Id;
2598 Parent_Node := Parent (N);
2599 Parent_Kind := Nkind (Parent_Node);
2601 if Parent_Kind = N_Qualified_Expression then
2603 -- Check if we are in a unconstrained declaration because in this
2604 -- case the current delayed expansion mechanism doesn't work when
2605 -- the declared object size depend on the initializing expr.
2608 Parent_Node := Parent (Parent_Node);
2609 Parent_Kind := Nkind (Parent_Node);
2611 if Parent_Kind = N_Object_Declaration then
2613 not Is_Entity_Name (Object_Definition (Parent_Node))
2614 or else Has_Discriminants
2615 (Entity (Object_Definition (Parent_Node)))
2616 or else Is_Class_Wide_Type
2617 (Entity (Object_Definition (Parent_Node)));
2622 -- Just set the Delay flag in the following cases where the
2623 -- transformation will be done top down from above
2625 -- - internal aggregate (transformed when expanding the parent)
2626 -- - allocators (see Convert_Aggr_In_Allocator)
2627 -- - object decl (see Convert_Aggr_In_Object_Decl)
2628 -- - safe assignments (see Convert_Aggr_Assignments)
2629 -- so far only the assignments in the init procs are taken
2632 if Parent_Kind = N_Aggregate
2633 or else Parent_Kind = N_Extension_Aggregate
2634 or else Parent_Kind = N_Component_Association
2635 or else Parent_Kind = N_Allocator
2636 or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
2637 or else (Parent_Kind = N_Assignment_Statement
2638 and then Inside_Init_Proc)
2640 Set_Expansion_Delayed (N);
2644 if Requires_Transient_Scope (Typ) then
2645 Establish_Transient_Scope (N, Sec_Stack =>
2646 Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
2649 -- Create the temporary
2651 Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
2654 Make_Object_Declaration (Loc,
2655 Defining_Identifier => Temp,
2656 Object_Definition => New_Occurrence_Of (Typ, Loc));
2658 Set_No_Initialization (Instr);
2659 Insert_Action (N, Instr);
2660 Initialize_Discriminants (Instr, Typ);
2661 Target_Expr := New_Occurrence_Of (Temp, Loc);
2663 Insert_Actions (N, Build_Record_Aggr_Code (N, Typ, Target_Expr));
2664 Rewrite (N, New_Occurrence_Of (Temp, Loc));
2665 Analyze_And_Resolve (N, Typ);
2666 end Convert_To_Assignments;
2668 ---------------------------
2669 -- Convert_To_Positional --
2670 ---------------------------
2672 procedure Convert_To_Positional
2674 Max_Others_Replicate : Nat := 5;
2675 Handle_Bit_Packed : Boolean := False)
2677 Typ : constant Entity_Id := Etype (N);
2682 Ixb : Node_Id) return Boolean;
2683 -- Convert the aggregate into a purely positional form if possible
2685 function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
2686 -- Return True iff the array N is flat (which is not rivial
2687 -- in the case of multidimensionsl aggregates).
2696 Ixb : Node_Id) return Boolean
2698 Loc : constant Source_Ptr := Sloc (N);
2699 Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb));
2700 Lo : constant Node_Id := Type_Low_Bound (Etype (Ix));
2701 Hi : constant Node_Id := Type_High_Bound (Etype (Ix));
2705 -- The following constant determines the maximum size of an
2706 -- aggregate produced by converting named to positional
2707 -- notation (e.g. from others clauses). This avoids running
2708 -- away with attempts to convert huge aggregates.
2710 -- The normal limit is 5000, but we increase this limit to
2711 -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code)
2712 -- or Restrictions (No_Implicit_Loops) is specified, since in
2713 -- either case, we are at risk of declaring the program illegal
2714 -- because of this limit.
2716 Max_Aggr_Size : constant Nat :=
2717 5000 + (2 ** 24 - 5000) *
2719 (Restriction_Active (No_Elaboration_Code)
2721 Restriction_Active (No_Implicit_Loops));
2724 if Nkind (Original_Node (N)) = N_String_Literal then
2728 -- Bounds need to be known at compile time
2730 if not Compile_Time_Known_Value (Lo)
2731 or else not Compile_Time_Known_Value (Hi)
2736 -- Get bounds and check reasonable size (positive, not too large)
2737 -- Also only handle bounds starting at the base type low bound
2738 -- for now since the compiler isn't able to handle different low
2739 -- bounds yet. Case such as new String'(3..5 => ' ') will get
2740 -- the wrong bounds, though it seems that the aggregate should
2741 -- retain the bounds set on its Etype (see C64103E and CC1311B).
2743 Lov := Expr_Value (Lo);
2744 Hiv := Expr_Value (Hi);
2747 or else (Hiv - Lov > Max_Aggr_Size)
2748 or else not Compile_Time_Known_Value (Blo)
2749 or else (Lov /= Expr_Value (Blo))
2754 -- Bounds must be in integer range (for array Vals below)
2756 if not UI_Is_In_Int_Range (Lov)
2758 not UI_Is_In_Int_Range (Hiv)
2763 -- Determine if set of alternatives is suitable for conversion
2764 -- and build an array containing the values in sequence.
2767 Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv))
2768 of Node_Id := (others => Empty);
2769 -- The values in the aggregate sorted appropriately
2772 -- Same data as Vals in list form
2775 -- Used to validate Max_Others_Replicate limit
2778 Num : Int := UI_To_Int (Lov);
2783 if Present (Expressions (N)) then
2784 Elmt := First (Expressions (N));
2786 while Present (Elmt) loop
2787 if Nkind (Elmt) = N_Aggregate
2788 and then Present (Next_Index (Ix))
2790 not Flatten (Elmt, Next_Index (Ix), Next_Index (Ixb))
2795 Vals (Num) := Relocate_Node (Elmt);
2802 if No (Component_Associations (N)) then
2806 Elmt := First (Component_Associations (N));
2808 if Nkind (Expression (Elmt)) = N_Aggregate then
2809 if Present (Next_Index (Ix))
2812 (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb))
2818 Component_Loop : while Present (Elmt) loop
2819 Choice := First (Choices (Elmt));
2820 Choice_Loop : while Present (Choice) loop
2822 -- If we have an others choice, fill in the missing elements
2823 -- subject to the limit established by Max_Others_Replicate.
2825 if Nkind (Choice) = N_Others_Choice then
2828 for J in Vals'Range loop
2829 if No (Vals (J)) then
2830 Vals (J) := New_Copy_Tree (Expression (Elmt));
2831 Rep_Count := Rep_Count + 1;
2833 -- Check for maximum others replication. Note that
2834 -- we skip this test if either of the restrictions
2835 -- No_Elaboration_Code or No_Implicit_Loops is
2836 -- active, or if this is a preelaborable unit.
2839 P : constant Entity_Id :=
2840 Cunit_Entity (Current_Sem_Unit);
2843 if Restriction_Active (No_Elaboration_Code)
2844 or else Restriction_Active (No_Implicit_Loops)
2845 or else Is_Preelaborated (P)
2846 or else (Ekind (P) = E_Package_Body
2848 Is_Preelaborated (Spec_Entity (P)))
2852 elsif Rep_Count > Max_Others_Replicate then
2859 exit Component_Loop;
2861 -- Case of a subtype mark
2863 elsif Nkind (Choice) = N_Identifier
2864 and then Is_Type (Entity (Choice))
2866 Lo := Type_Low_Bound (Etype (Choice));
2867 Hi := Type_High_Bound (Etype (Choice));
2869 -- Case of subtype indication
2871 elsif Nkind (Choice) = N_Subtype_Indication then
2872 Lo := Low_Bound (Range_Expression (Constraint (Choice)));
2873 Hi := High_Bound (Range_Expression (Constraint (Choice)));
2877 elsif Nkind (Choice) = N_Range then
2878 Lo := Low_Bound (Choice);
2879 Hi := High_Bound (Choice);
2881 -- Normal subexpression case
2883 else pragma Assert (Nkind (Choice) in N_Subexpr);
2884 if not Compile_Time_Known_Value (Choice) then
2888 Vals (UI_To_Int (Expr_Value (Choice))) :=
2889 New_Copy_Tree (Expression (Elmt));
2894 -- Range cases merge with Lo,Hi said
2896 if not Compile_Time_Known_Value (Lo)
2898 not Compile_Time_Known_Value (Hi)
2902 for J in UI_To_Int (Expr_Value (Lo)) ..
2903 UI_To_Int (Expr_Value (Hi))
2905 Vals (J) := New_Copy_Tree (Expression (Elmt));
2911 end loop Choice_Loop;
2914 end loop Component_Loop;
2916 -- If we get here the conversion is possible
2919 for J in Vals'Range loop
2920 Append (Vals (J), Vlist);
2923 Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist));
2924 Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N)));
2933 function Is_Flat (N : Node_Id; Dims : Int) return Boolean is
2940 elsif Nkind (N) = N_Aggregate then
2941 if Present (Component_Associations (N)) then
2945 Elmt := First (Expressions (N));
2947 while Present (Elmt) loop
2948 if not Is_Flat (Elmt, Dims - 1) then
2962 -- Start of processing for Convert_To_Positional
2965 -- Ada 2005 (AI-287): Do not convert in case of default initialized
2966 -- components because in this case will need to call the corresponding
2969 if Has_Default_Init_Comps (N) then
2973 if Is_Flat (N, Number_Dimensions (Typ)) then
2977 if Is_Bit_Packed_Array (Typ)
2978 and then not Handle_Bit_Packed
2983 -- Do not convert to positional if controlled components are
2984 -- involved since these require special processing
2986 if Has_Controlled_Component (Typ) then
2990 if Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ))) then
2991 Analyze_And_Resolve (N, Typ);
2993 end Convert_To_Positional;
2995 ----------------------------
2996 -- Expand_Array_Aggregate --
2997 ----------------------------
2999 -- Array aggregate expansion proceeds as follows:
3001 -- 1. If requested we generate code to perform all the array aggregate
3002 -- bound checks, specifically
3004 -- (a) Check that the index range defined by aggregate bounds is
3005 -- compatible with corresponding index subtype.
3007 -- (b) If an others choice is present check that no aggregate
3008 -- index is outside the bounds of the index constraint.
3010 -- (c) For multidimensional arrays make sure that all subaggregates
3011 -- corresponding to the same dimension have the same bounds.
3013 -- 2. Check for packed array aggregate which can be converted to a
3014 -- constant so that the aggregate disappeares completely.
3016 -- 3. Check case of nested aggregate. Generally nested aggregates are
3017 -- handled during the processing of the parent aggregate.
3019 -- 4. Check if the aggregate can be statically processed. If this is the
3020 -- case pass it as is to Gigi. Note that a necessary condition for
3021 -- static processing is that the aggregate be fully positional.
3023 -- 5. If in place aggregate expansion is possible (i.e. no need to create
3024 -- a temporary) then mark the aggregate as such and return. Otherwise
3025 -- create a new temporary and generate the appropriate initialization
3028 procedure Expand_Array_Aggregate (N : Node_Id) is
3029 Loc : constant Source_Ptr := Sloc (N);
3031 Typ : constant Entity_Id := Etype (N);
3032 Ctyp : constant Entity_Id := Component_Type (Typ);
3033 -- Typ is the correct constrained array subtype of the aggregate
3034 -- Ctyp is the corresponding component type.
3036 Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
3037 -- Number of aggregate index dimensions
3039 Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id;
3040 Aggr_High : array (1 .. Aggr_Dimension) of Node_Id;
3041 -- Low and High bounds of the constraint for each aggregate index
3043 Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
3044 -- The type of each index
3046 Maybe_In_Place_OK : Boolean;
3047 -- If the type is neither controlled nor packed and the aggregate
3048 -- is the expression in an assignment, assignment in place may be
3049 -- possible, provided other conditions are met on the LHS.
3051 Others_Present : array (1 .. Aggr_Dimension) of Boolean :=
3053 -- If Others_Present (J) is True, then there is an others choice
3054 -- in one of the sub-aggregates of N at dimension J.
3056 procedure Build_Constrained_Type (Positional : Boolean);
3057 -- If the subtype is not static or unconstrained, build a constrained
3058 -- type using the computable sizes of the aggregate and its sub-
3061 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id);
3062 -- Checks that the bounds of Aggr_Bounds are within the bounds defined
3065 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos);
3066 -- Checks that in a multi-dimensional array aggregate all subaggregates
3067 -- corresponding to the same dimension have the same bounds.
3068 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3069 -- corresponding to the sub-aggregate.
3071 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos);
3072 -- Computes the values of array Others_Present. Sub_Aggr is the
3073 -- array sub-aggregate we start the computation from. Dim is the
3074 -- dimension corresponding to the sub-aggregate.
3076 function Has_Address_Clause (D : Node_Id) return Boolean;
3077 -- If the aggregate is the expression in an object declaration, it
3078 -- cannot be expanded in place. This function does a lookahead in the
3079 -- current declarative part to find an address clause for the object
3082 function In_Place_Assign_OK return Boolean;
3083 -- Simple predicate to determine whether an aggregate assignment can
3084 -- be done in place, because none of the new values can depend on the
3085 -- components of the target of the assignment.
3087 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
3088 -- Checks that if an others choice is present in any sub-aggregate no
3089 -- aggregate index is outside the bounds of the index constraint.
3090 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3091 -- corresponding to the sub-aggregate.
3093 ----------------------------
3094 -- Build_Constrained_Type --
3095 ----------------------------
3097 procedure Build_Constrained_Type (Positional : Boolean) is
3098 Loc : constant Source_Ptr := Sloc (N);
3099 Agg_Type : Entity_Id;
3102 Typ : constant Entity_Id := Etype (N);
3103 Indices : constant List_Id := New_List;
3109 Make_Defining_Identifier (
3110 Loc, New_Internal_Name ('A'));
3112 -- If the aggregate is purely positional, all its subaggregates
3113 -- have the same size. We collect the dimensions from the first
3114 -- subaggregate at each level.
3119 for D in 1 .. Number_Dimensions (Typ) loop
3120 Comp := First (Expressions (Sub_Agg));
3125 while Present (Comp) loop
3132 Low_Bound => Make_Integer_Literal (Loc, 1),
3134 Make_Integer_Literal (Loc, Num)),
3139 -- We know the aggregate type is unconstrained and the
3140 -- aggregate is not processable by the back end, therefore
3141 -- not necessarily positional. Retrieve the bounds of each
3142 -- dimension as computed earlier.
3144 for D in 1 .. Number_Dimensions (Typ) loop
3147 Low_Bound => Aggr_Low (D),
3148 High_Bound => Aggr_High (D)),
3154 Make_Full_Type_Declaration (Loc,
3155 Defining_Identifier => Agg_Type,
3157 Make_Constrained_Array_Definition (Loc,
3158 Discrete_Subtype_Definitions => Indices,
3159 Component_Definition =>
3160 Make_Component_Definition (Loc,
3161 Aliased_Present => False,
3162 Subtype_Indication =>
3163 New_Occurrence_Of (Component_Type (Typ), Loc))));
3165 Insert_Action (N, Decl);
3167 Set_Etype (N, Agg_Type);
3168 Set_Is_Itype (Agg_Type);
3169 Freeze_Itype (Agg_Type, N);
3170 end Build_Constrained_Type;
3176 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is
3183 Cond : Node_Id := Empty;
3186 Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi);
3187 Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi);
3189 -- Generate the following test:
3191 -- [constraint_error when
3192 -- Aggr_Lo <= Aggr_Hi and then
3193 -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
3195 -- As an optimization try to see if some tests are trivially vacuos
3196 -- because we are comparing an expression against itself.
3198 if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then
3201 elsif Aggr_Hi = Ind_Hi then
3204 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3205 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo));
3207 elsif Aggr_Lo = Ind_Lo then
3210 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
3211 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Hi));
3218 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3219 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)),
3223 Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
3224 Right_Opnd => Duplicate_Subexpr (Ind_Hi)));
3227 if Present (Cond) then
3232 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3233 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)),
3235 Right_Opnd => Cond);
3237 Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False);
3238 Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False);
3240 Make_Raise_Constraint_Error (Loc,
3242 Reason => CE_Length_Check_Failed));
3246 ----------------------------
3247 -- Check_Same_Aggr_Bounds --
3248 ----------------------------
3250 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
3251 Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr));
3252 Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr));
3253 -- The bounds of this specific sub-aggregate
3255 Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
3256 Aggr_Hi : constant Node_Id := Aggr_High (Dim);
3257 -- The bounds of the aggregate for this dimension
3259 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
3260 -- The index type for this dimension.xxx
3262 Cond : Node_Id := Empty;
3268 -- If index checks are on generate the test
3270 -- [constraint_error when
3271 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
3273 -- As an optimization try to see if some tests are trivially vacuos
3274 -- because we are comparing an expression against itself. Also for
3275 -- the first dimension the test is trivially vacuous because there
3276 -- is just one aggregate for dimension 1.
3278 if Index_Checks_Suppressed (Ind_Typ) then
3282 or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi)
3286 elsif Aggr_Hi = Sub_Hi then
3289 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3290 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo));
3292 elsif Aggr_Lo = Sub_Lo then
3295 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
3296 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi));
3303 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3304 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)),
3308 Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
3309 Right_Opnd => Duplicate_Subexpr (Sub_Hi)));
3312 if Present (Cond) then
3314 Make_Raise_Constraint_Error (Loc,
3316 Reason => CE_Length_Check_Failed));
3319 -- Now look inside the sub-aggregate to see if there is more work
3321 if Dim < Aggr_Dimension then
3323 -- Process positional components
3325 if Present (Expressions (Sub_Aggr)) then
3326 Expr := First (Expressions (Sub_Aggr));
3327 while Present (Expr) loop
3328 Check_Same_Aggr_Bounds (Expr, Dim + 1);
3333 -- Process component associations
3335 if Present (Component_Associations (Sub_Aggr)) then
3336 Assoc := First (Component_Associations (Sub_Aggr));
3337 while Present (Assoc) loop
3338 Expr := Expression (Assoc);
3339 Check_Same_Aggr_Bounds (Expr, Dim + 1);
3344 end Check_Same_Aggr_Bounds;
3346 ----------------------------
3347 -- Compute_Others_Present --
3348 ----------------------------
3350 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is
3355 if Present (Component_Associations (Sub_Aggr)) then
3356 Assoc := Last (Component_Associations (Sub_Aggr));
3358 if Nkind (First (Choices (Assoc))) = N_Others_Choice then
3359 Others_Present (Dim) := True;
3363 -- Now look inside the sub-aggregate to see if there is more work
3365 if Dim < Aggr_Dimension then
3367 -- Process positional components
3369 if Present (Expressions (Sub_Aggr)) then
3370 Expr := First (Expressions (Sub_Aggr));
3371 while Present (Expr) loop
3372 Compute_Others_Present (Expr, Dim + 1);
3377 -- Process component associations
3379 if Present (Component_Associations (Sub_Aggr)) then
3380 Assoc := First (Component_Associations (Sub_Aggr));
3381 while Present (Assoc) loop
3382 Expr := Expression (Assoc);
3383 Compute_Others_Present (Expr, Dim + 1);
3388 end Compute_Others_Present;
3390 ------------------------
3391 -- Has_Address_Clause --
3392 ------------------------
3394 function Has_Address_Clause (D : Node_Id) return Boolean is
3395 Id : constant Entity_Id := Defining_Identifier (D);
3396 Decl : Node_Id := Next (D);
3399 while Present (Decl) loop
3400 if Nkind (Decl) = N_At_Clause
3401 and then Chars (Identifier (Decl)) = Chars (Id)
3405 elsif Nkind (Decl) = N_Attribute_Definition_Clause
3406 and then Chars (Decl) = Name_Address
3407 and then Chars (Name (Decl)) = Chars (Id)
3416 end Has_Address_Clause;
3418 ------------------------
3419 -- In_Place_Assign_OK --
3420 ------------------------
3422 function In_Place_Assign_OK return Boolean is
3430 function Is_Others_Aggregate (Aggr : Node_Id) return Boolean;
3431 -- Aggregates that consist of a single Others choice are safe
3432 -- if the single expression is.
3434 function Safe_Aggregate (Aggr : Node_Id) return Boolean;
3435 -- Check recursively that each component of a (sub)aggregate does
3436 -- not depend on the variable being assigned to.
3438 function Safe_Component (Expr : Node_Id) return Boolean;
3439 -- Verify that an expression cannot depend on the variable being
3440 -- assigned to. Room for improvement here (but less than before).
3442 -------------------------
3443 -- Is_Others_Aggregate --
3444 -------------------------
3446 function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is
3448 return No (Expressions (Aggr))
3450 (First (Choices (First (Component_Associations (Aggr)))))
3452 end Is_Others_Aggregate;
3454 --------------------
3455 -- Safe_Aggregate --
3456 --------------------
3458 function Safe_Aggregate (Aggr : Node_Id) return Boolean is
3462 if Present (Expressions (Aggr)) then
3463 Expr := First (Expressions (Aggr));
3465 while Present (Expr) loop
3466 if Nkind (Expr) = N_Aggregate then
3467 if not Safe_Aggregate (Expr) then
3471 elsif not Safe_Component (Expr) then
3479 if Present (Component_Associations (Aggr)) then
3480 Expr := First (Component_Associations (Aggr));
3482 while Present (Expr) loop
3483 if Nkind (Expression (Expr)) = N_Aggregate then
3484 if not Safe_Aggregate (Expression (Expr)) then
3488 elsif not Safe_Component (Expression (Expr)) then
3499 --------------------
3500 -- Safe_Component --
3501 --------------------
3503 function Safe_Component (Expr : Node_Id) return Boolean is
3504 Comp : Node_Id := Expr;
3506 function Check_Component (Comp : Node_Id) return Boolean;
3507 -- Do the recursive traversal, after copy
3509 ---------------------
3510 -- Check_Component --
3511 ---------------------
3513 function Check_Component (Comp : Node_Id) return Boolean is
3515 if Is_Overloaded (Comp) then
3519 return Compile_Time_Known_Value (Comp)
3521 or else (Is_Entity_Name (Comp)
3522 and then Present (Entity (Comp))
3523 and then No (Renamed_Object (Entity (Comp))))
3525 or else (Nkind (Comp) = N_Attribute_Reference
3526 and then Check_Component (Prefix (Comp)))
3528 or else (Nkind (Comp) in N_Binary_Op
3529 and then Check_Component (Left_Opnd (Comp))
3530 and then Check_Component (Right_Opnd (Comp)))
3532 or else (Nkind (Comp) in N_Unary_Op
3533 and then Check_Component (Right_Opnd (Comp)))
3535 or else (Nkind (Comp) = N_Selected_Component
3536 and then Check_Component (Prefix (Comp)))
3538 or else (Nkind (Comp) = N_Unchecked_Type_Conversion
3539 and then Check_Component (Expression (Comp)));
3540 end Check_Component;
3542 -- Start of processing for Safe_Component
3545 -- If the component appears in an association that may
3546 -- correspond to more than one element, it is not analyzed
3547 -- before the expansion into assignments, to avoid side effects.
3548 -- We analyze, but do not resolve the copy, to obtain sufficient
3549 -- entity information for the checks that follow. If component is
3550 -- overloaded we assume an unsafe function call.
3552 if not Analyzed (Comp) then
3553 if Is_Overloaded (Expr) then
3556 elsif Nkind (Expr) = N_Aggregate
3557 and then not Is_Others_Aggregate (Expr)
3561 elsif Nkind (Expr) = N_Allocator then
3563 -- For now, too complex to analyze
3568 Comp := New_Copy_Tree (Expr);
3569 Set_Parent (Comp, Parent (Expr));
3573 if Nkind (Comp) = N_Aggregate then
3574 return Safe_Aggregate (Comp);
3576 return Check_Component (Comp);
3580 -- Start of processing for In_Place_Assign_OK
3583 if Present (Component_Associations (N)) then
3585 -- On assignment, sliding can take place, so we cannot do the
3586 -- assignment in place unless the bounds of the aggregate are
3587 -- statically equal to those of the target.
3589 -- If the aggregate is given by an others choice, the bounds
3590 -- are derived from the left-hand side, and the assignment is
3591 -- safe if the expression is.
3593 if Is_Others_Aggregate (N) then
3596 (Expression (First (Component_Associations (N))));
3599 Aggr_In := First_Index (Etype (N));
3600 if Nkind (Parent (N)) = N_Assignment_Statement then
3601 Obj_In := First_Index (Etype (Name (Parent (N))));
3604 -- Context is an allocator. Check bounds of aggregate
3605 -- against given type in qualified expression.
3607 pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator);
3609 First_Index (Etype (Entity (Subtype_Mark (Parent (N)))));
3612 while Present (Aggr_In) loop
3613 Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
3614 Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
3616 if not Compile_Time_Known_Value (Aggr_Lo)
3617 or else not Compile_Time_Known_Value (Aggr_Hi)
3618 or else not Compile_Time_Known_Value (Obj_Lo)
3619 or else not Compile_Time_Known_Value (Obj_Hi)
3620 or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
3621 or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
3626 Next_Index (Aggr_In);
3627 Next_Index (Obj_In);
3631 -- Now check the component values themselves
3633 return Safe_Aggregate (N);
3634 end In_Place_Assign_OK;
3640 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is
3641 Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
3642 Aggr_Hi : constant Node_Id := Aggr_High (Dim);
3643 -- The bounds of the aggregate for this dimension
3645 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
3646 -- The index type for this dimension
3648 Need_To_Check : Boolean := False;
3650 Choices_Lo : Node_Id := Empty;
3651 Choices_Hi : Node_Id := Empty;
3652 -- The lowest and highest discrete choices for a named sub-aggregate
3654 Nb_Choices : Int := -1;
3655 -- The number of discrete non-others choices in this sub-aggregate
3657 Nb_Elements : Uint := Uint_0;
3658 -- The number of elements in a positional aggregate
3660 Cond : Node_Id := Empty;
3667 -- Check if we have an others choice. If we do make sure that this
3668 -- sub-aggregate contains at least one element in addition to the
3671 if Range_Checks_Suppressed (Ind_Typ) then
3672 Need_To_Check := False;
3674 elsif Present (Expressions (Sub_Aggr))
3675 and then Present (Component_Associations (Sub_Aggr))
3677 Need_To_Check := True;
3679 elsif Present (Component_Associations (Sub_Aggr)) then
3680 Assoc := Last (Component_Associations (Sub_Aggr));
3682 if Nkind (First (Choices (Assoc))) /= N_Others_Choice then
3683 Need_To_Check := False;
3686 -- Count the number of discrete choices. Start with -1
3687 -- because the others choice does not count.
3690 Assoc := First (Component_Associations (Sub_Aggr));
3691 while Present (Assoc) loop
3692 Choice := First (Choices (Assoc));
3693 while Present (Choice) loop
3694 Nb_Choices := Nb_Choices + 1;
3701 -- If there is only an others choice nothing to do
3703 Need_To_Check := (Nb_Choices > 0);
3707 Need_To_Check := False;
3710 -- If we are dealing with a positional sub-aggregate with an
3711 -- others choice then compute the number or positional elements.
3713 if Need_To_Check and then Present (Expressions (Sub_Aggr)) then
3714 Expr := First (Expressions (Sub_Aggr));
3715 Nb_Elements := Uint_0;
3716 while Present (Expr) loop
3717 Nb_Elements := Nb_Elements + 1;
3721 -- If the aggregate contains discrete choices and an others choice
3722 -- compute the smallest and largest discrete choice values.
3724 elsif Need_To_Check then
3725 Compute_Choices_Lo_And_Choices_Hi : declare
3727 Table : Case_Table_Type (1 .. Nb_Choices);
3728 -- Used to sort all the different choice values
3735 Assoc := First (Component_Associations (Sub_Aggr));
3736 while Present (Assoc) loop
3737 Choice := First (Choices (Assoc));
3738 while Present (Choice) loop
3739 if Nkind (Choice) = N_Others_Choice then
3743 Get_Index_Bounds (Choice, Low, High);
3744 Table (J).Choice_Lo := Low;
3745 Table (J).Choice_Hi := High;
3754 -- Sort the discrete choices
3756 Sort_Case_Table (Table);
3758 Choices_Lo := Table (1).Choice_Lo;
3759 Choices_Hi := Table (Nb_Choices).Choice_Hi;
3760 end Compute_Choices_Lo_And_Choices_Hi;
3763 -- If no others choice in this sub-aggregate, or the aggregate
3764 -- comprises only an others choice, nothing to do.
3766 if not Need_To_Check then
3769 -- If we are dealing with an aggregate containing an others
3770 -- choice and positional components, we generate the following test:
3772 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
3773 -- Ind_Typ'Pos (Aggr_Hi)
3775 -- raise Constraint_Error;
3778 elsif Nb_Elements > Uint_0 then
3784 Make_Attribute_Reference (Loc,
3785 Prefix => New_Reference_To (Ind_Typ, Loc),
3786 Attribute_Name => Name_Pos,
3789 (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
3790 Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
3793 Make_Attribute_Reference (Loc,
3794 Prefix => New_Reference_To (Ind_Typ, Loc),
3795 Attribute_Name => Name_Pos,
3796 Expressions => New_List (
3797 Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
3799 -- If we are dealing with an aggregate containing an others
3800 -- choice and discrete choices we generate the following test:
3802 -- [constraint_error when
3803 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
3811 Duplicate_Subexpr_Move_Checks (Choices_Lo),
3813 Duplicate_Subexpr_Move_Checks (Aggr_Lo)),
3818 Duplicate_Subexpr (Choices_Hi),
3820 Duplicate_Subexpr (Aggr_Hi)));
3823 if Present (Cond) then
3825 Make_Raise_Constraint_Error (Loc,
3827 Reason => CE_Length_Check_Failed));
3830 -- Now look inside the sub-aggregate to see if there is more work
3832 if Dim < Aggr_Dimension then
3834 -- Process positional components
3836 if Present (Expressions (Sub_Aggr)) then
3837 Expr := First (Expressions (Sub_Aggr));
3838 while Present (Expr) loop
3839 Others_Check (Expr, Dim + 1);
3844 -- Process component associations
3846 if Present (Component_Associations (Sub_Aggr)) then
3847 Assoc := First (Component_Associations (Sub_Aggr));
3848 while Present (Assoc) loop
3849 Expr := Expression (Assoc);
3850 Others_Check (Expr, Dim + 1);
3857 -- Remaining Expand_Array_Aggregate variables
3860 -- Holds the temporary aggregate value
3863 -- Holds the declaration of Tmp
3865 Aggr_Code : List_Id;
3866 Parent_Node : Node_Id;
3867 Parent_Kind : Node_Kind;
3869 -- Start of processing for Expand_Array_Aggregate
3872 -- Do not touch the special aggregates of attributes used for Asm calls
3874 if Is_RTE (Ctyp, RE_Asm_Input_Operand)
3875 or else Is_RTE (Ctyp, RE_Asm_Output_Operand)
3880 -- If the semantic analyzer has determined that aggregate N will raise
3881 -- Constraint_Error at run-time, then the aggregate node has been
3882 -- replaced with an N_Raise_Constraint_Error node and we should
3885 pragma Assert (not Raises_Constraint_Error (N));
3889 -- Check that the index range defined by aggregate bounds is
3890 -- compatible with corresponding index subtype.
3892 Index_Compatibility_Check : declare
3893 Aggr_Index_Range : Node_Id := First_Index (Typ);
3894 -- The current aggregate index range
3896 Index_Constraint : Node_Id := First_Index (Etype (Typ));
3897 -- The corresponding index constraint against which we have to
3898 -- check the above aggregate index range.
3901 Compute_Others_Present (N, 1);
3903 for J in 1 .. Aggr_Dimension loop
3904 -- There is no need to emit a check if an others choice is
3905 -- present for this array aggregate dimension since in this
3906 -- case one of N's sub-aggregates has taken its bounds from the
3907 -- context and these bounds must have been checked already. In
3908 -- addition all sub-aggregates corresponding to the same
3909 -- dimension must all have the same bounds (checked in (c) below).
3911 if not Range_Checks_Suppressed (Etype (Index_Constraint))
3912 and then not Others_Present (J)
3914 -- We don't use Checks.Apply_Range_Check here because it
3915 -- emits a spurious check. Namely it checks that the range
3916 -- defined by the aggregate bounds is non empty. But we know
3917 -- this already if we get here.
3919 Check_Bounds (Aggr_Index_Range, Index_Constraint);
3922 -- Save the low and high bounds of the aggregate index as well
3923 -- as the index type for later use in checks (b) and (c) below.
3925 Aggr_Low (J) := Low_Bound (Aggr_Index_Range);
3926 Aggr_High (J) := High_Bound (Aggr_Index_Range);
3928 Aggr_Index_Typ (J) := Etype (Index_Constraint);
3930 Next_Index (Aggr_Index_Range);
3931 Next_Index (Index_Constraint);
3933 end Index_Compatibility_Check;
3937 -- If an others choice is present check that no aggregate
3938 -- index is outside the bounds of the index constraint.
3940 Others_Check (N, 1);
3944 -- For multidimensional arrays make sure that all subaggregates
3945 -- corresponding to the same dimension have the same bounds.
3947 if Aggr_Dimension > 1 then
3948 Check_Same_Aggr_Bounds (N, 1);
3953 -- Here we test for is packed array aggregate that we can handle
3954 -- at compile time. If so, return with transformation done. Note
3955 -- that we do this even if the aggregate is nested, because once
3956 -- we have done this processing, there is no more nested aggregate!
3958 if Packed_Array_Aggregate_Handled (N) then
3962 -- At this point we try to convert to positional form
3964 Convert_To_Positional (N);
3966 -- if the result is no longer an aggregate (e.g. it may be a string
3967 -- literal, or a temporary which has the needed value), then we are
3968 -- done, since there is no longer a nested aggregate.
3970 if Nkind (N) /= N_Aggregate then
3973 -- We are also done if the result is an analyzed aggregate
3974 -- This case could use more comments ???
3977 and then N /= Original_Node (N)
3982 -- Now see if back end processing is possible
3984 if Backend_Processing_Possible (N) then
3986 -- If the aggregate is static but the constraints are not, build
3987 -- a static subtype for the aggregate, so that Gigi can place it
3988 -- in static memory. Perform an unchecked_conversion to the non-
3989 -- static type imposed by the context.
3992 Itype : constant Entity_Id := Etype (N);
3994 Needs_Type : Boolean := False;
3997 Index := First_Index (Itype);
3999 while Present (Index) loop
4000 if not Is_Static_Subtype (Etype (Index)) then
4009 Build_Constrained_Type (Positional => True);
4010 Rewrite (N, Unchecked_Convert_To (Itype, N));
4020 -- Delay expansion for nested aggregates it will be taken care of
4021 -- when the parent aggregate is expanded
4023 Parent_Node := Parent (N);
4024 Parent_Kind := Nkind (Parent_Node);
4026 if Parent_Kind = N_Qualified_Expression then
4027 Parent_Node := Parent (Parent_Node);
4028 Parent_Kind := Nkind (Parent_Node);
4031 if Parent_Kind = N_Aggregate
4032 or else Parent_Kind = N_Extension_Aggregate
4033 or else Parent_Kind = N_Component_Association
4034 or else (Parent_Kind = N_Object_Declaration
4035 and then Controlled_Type (Typ))
4036 or else (Parent_Kind = N_Assignment_Statement
4037 and then Inside_Init_Proc)
4039 Set_Expansion_Delayed (N);
4045 -- Look if in place aggregate expansion is possible
4047 -- For object declarations we build the aggregate in place, unless
4048 -- the array is bit-packed or the component is controlled.
4050 -- For assignments we do the assignment in place if all the component
4051 -- associations have compile-time known values. For other cases we
4052 -- create a temporary. The analysis for safety of on-line assignment
4053 -- is delicate, i.e. we don't know how to do it fully yet ???
4055 -- For allocators we assign to the designated object in place if the
4056 -- aggregate meets the same conditions as other in-place assignments.
4057 -- In this case the aggregate may not come from source but was created
4058 -- for default initialization, e.g. with Initialize_Scalars.
4060 if Requires_Transient_Scope (Typ) then
4061 Establish_Transient_Scope
4062 (N, Sec_Stack => Has_Controlled_Component (Typ));
4065 if Has_Default_Init_Comps (N) then
4066 Maybe_In_Place_OK := False;
4068 elsif Is_Bit_Packed_Array (Typ)
4069 or else Has_Controlled_Component (Typ)
4071 Maybe_In_Place_OK := False;
4074 Maybe_In_Place_OK :=
4075 (Nkind (Parent (N)) = N_Assignment_Statement
4076 and then Comes_From_Source (N)
4077 and then In_Place_Assign_OK)
4080 (Nkind (Parent (Parent (N))) = N_Allocator
4081 and then In_Place_Assign_OK);
4084 if not Has_Default_Init_Comps (N)
4085 and then Comes_From_Source (Parent (N))
4086 and then Nkind (Parent (N)) = N_Object_Declaration
4088 Must_Slide (Etype (Defining_Identifier (Parent (N))), Typ)
4089 and then N = Expression (Parent (N))
4090 and then not Is_Bit_Packed_Array (Typ)
4091 and then not Has_Controlled_Component (Typ)
4092 and then not Has_Address_Clause (Parent (N))
4094 Tmp := Defining_Identifier (Parent (N));
4095 Set_No_Initialization (Parent (N));
4096 Set_Expression (Parent (N), Empty);
4098 -- Set the type of the entity, for use in the analysis of the
4099 -- subsequent indexed assignments. If the nominal type is not
4100 -- constrained, build a subtype from the known bounds of the
4101 -- aggregate. If the declaration has a subtype mark, use it,
4102 -- otherwise use the itype of the aggregate.
4104 if not Is_Constrained (Typ) then
4105 Build_Constrained_Type (Positional => False);
4106 elsif Is_Entity_Name (Object_Definition (Parent (N)))
4107 and then Is_Constrained (Entity (Object_Definition (Parent (N))))
4109 Set_Etype (Tmp, Entity (Object_Definition (Parent (N))));
4111 Set_Size_Known_At_Compile_Time (Typ, False);
4112 Set_Etype (Tmp, Typ);
4115 elsif Maybe_In_Place_OK
4116 and then Nkind (Parent (N)) = N_Qualified_Expression
4117 and then Nkind (Parent (Parent (N))) = N_Allocator
4119 Set_Expansion_Delayed (N);
4122 -- In the remaining cases the aggregate is the RHS of an assignment
4124 elsif Maybe_In_Place_OK
4125 and then Is_Entity_Name (Name (Parent (N)))
4127 Tmp := Entity (Name (Parent (N)));
4129 if Etype (Tmp) /= Etype (N) then
4130 Apply_Length_Check (N, Etype (Tmp));
4132 if Nkind (N) = N_Raise_Constraint_Error then
4134 -- Static error, nothing further to expand
4140 elsif Maybe_In_Place_OK
4141 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
4142 and then Is_Entity_Name (Prefix (Name (Parent (N))))
4144 Tmp := Name (Parent (N));
4146 if Etype (Tmp) /= Etype (N) then
4147 Apply_Length_Check (N, Etype (Tmp));
4150 elsif Maybe_In_Place_OK
4151 and then Nkind (Name (Parent (N))) = N_Slice
4152 and then Safe_Slice_Assignment (N)
4154 -- Safe_Slice_Assignment rewrites assignment as a loop
4160 -- In place aggregate expansion is not possible
4163 Maybe_In_Place_OK := False;
4164 Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
4166 Make_Object_Declaration
4168 Defining_Identifier => Tmp,
4169 Object_Definition => New_Occurrence_Of (Typ, Loc));
4170 Set_No_Initialization (Tmp_Decl, True);
4172 -- If we are within a loop, the temporary will be pushed on the
4173 -- stack at each iteration. If the aggregate is the expression for
4174 -- an allocator, it will be immediately copied to the heap and can
4175 -- be reclaimed at once. We create a transient scope around the
4176 -- aggregate for this purpose.
4178 if Ekind (Current_Scope) = E_Loop
4179 and then Nkind (Parent (Parent (N))) = N_Allocator
4181 Establish_Transient_Scope (N, False);
4184 Insert_Action (N, Tmp_Decl);
4187 -- Construct and insert the aggregate code. We can safely suppress
4188 -- index checks because this code is guaranteed not to raise CE
4189 -- on index checks. However we should *not* suppress all checks.
4195 if Nkind (Tmp) = N_Defining_Identifier then
4196 Target := New_Reference_To (Tmp, Loc);
4200 if Has_Default_Init_Comps (N) then
4202 -- Ada 2005 (AI-287): This case has not been analyzed???
4204 raise Program_Error;
4207 -- Name in assignment is explicit dereference
4209 Target := New_Copy (Tmp);
4213 Build_Array_Aggr_Code (N,
4215 Index => First_Index (Typ),
4217 Scalar_Comp => Is_Scalar_Type (Ctyp));
4220 if Comes_From_Source (Tmp) then
4221 Insert_Actions_After (Parent (N), Aggr_Code);
4224 Insert_Actions (N, Aggr_Code);
4227 -- If the aggregate has been assigned in place, remove the original
4230 if Nkind (Parent (N)) = N_Assignment_Statement
4231 and then Maybe_In_Place_OK
4233 Rewrite (Parent (N), Make_Null_Statement (Loc));
4235 elsif Nkind (Parent (N)) /= N_Object_Declaration
4236 or else Tmp /= Defining_Identifier (Parent (N))
4238 Rewrite (N, New_Occurrence_Of (Tmp, Loc));
4239 Analyze_And_Resolve (N, Typ);
4241 end Expand_Array_Aggregate;
4243 ------------------------
4244 -- Expand_N_Aggregate --
4245 ------------------------
4247 procedure Expand_N_Aggregate (N : Node_Id) is
4249 if Is_Record_Type (Etype (N)) then
4250 Expand_Record_Aggregate (N);
4252 Expand_Array_Aggregate (N);
4256 when RE_Not_Available =>
4258 end Expand_N_Aggregate;
4260 ----------------------------------
4261 -- Expand_N_Extension_Aggregate --
4262 ----------------------------------
4264 -- If the ancestor part is an expression, add a component association for
4265 -- the parent field. If the type of the ancestor part is not the direct
4266 -- parent of the expected type, build recursively the needed ancestors.
4267 -- If the ancestor part is a subtype_mark, replace aggregate with a decla-
4268 -- ration for a temporary of the expected type, followed by individual
4269 -- assignments to the given components.
4271 procedure Expand_N_Extension_Aggregate (N : Node_Id) is
4272 Loc : constant Source_Ptr := Sloc (N);
4273 A : constant Node_Id := Ancestor_Part (N);
4274 Typ : constant Entity_Id := Etype (N);
4277 -- If the ancestor is a subtype mark, an init proc must be called
4278 -- on the resulting object which thus has to be materialized in
4281 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
4282 Convert_To_Assignments (N, Typ);
4284 -- The extension aggregate is transformed into a record aggregate
4285 -- of the following form (c1 and c2 are inherited components)
4287 -- (Exp with c3 => a, c4 => b)
4288 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b)
4293 -- No tag is needed in the case of Java_VM
4296 Expand_Record_Aggregate (N,
4299 Expand_Record_Aggregate (N,
4302 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc),
4308 when RE_Not_Available =>
4310 end Expand_N_Extension_Aggregate;
4312 -----------------------------
4313 -- Expand_Record_Aggregate --
4314 -----------------------------
4316 procedure Expand_Record_Aggregate
4318 Orig_Tag : Node_Id := Empty;
4319 Parent_Expr : Node_Id := Empty)
4321 Loc : constant Source_Ptr := Sloc (N);
4322 Comps : constant List_Id := Component_Associations (N);
4323 Typ : constant Entity_Id := Etype (N);
4324 Base_Typ : constant Entity_Id := Base_Type (Typ);
4326 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean;
4327 -- Checks the presence of a nested aggregate which needs Late_Expansion
4328 -- or the presence of tagged components which may need tag adjustment.
4330 --------------------------------------------------
4331 -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
4332 --------------------------------------------------
4334 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is
4344 while Present (C) loop
4345 if Nkind (Expression (C)) = N_Qualified_Expression then
4346 Expr_Q := Expression (Expression (C));
4348 Expr_Q := Expression (C);
4351 -- Return true if the aggregate has any associations for
4352 -- tagged components that may require tag adjustment.
4353 -- These are cases where the source expression may have
4354 -- a tag that could differ from the component tag (e.g.,
4355 -- can occur for type conversions and formal parameters).
4356 -- (Tag adjustment is not needed if Java_VM because object
4357 -- tags are implicit in the JVM.)
4359 if Is_Tagged_Type (Etype (Expr_Q))
4360 and then (Nkind (Expr_Q) = N_Type_Conversion
4361 or else (Is_Entity_Name (Expr_Q)
4362 and then Ekind (Entity (Expr_Q)) in Formal_Kind))
4363 and then not Java_VM
4368 if Is_Delayed_Aggregate (Expr_Q) then
4376 end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps;
4378 -- Remaining Expand_Record_Aggregate variables
4380 Tag_Value : Node_Id;
4384 -- Start of processing for Expand_Record_Aggregate
4387 -- If the aggregate is to be assigned to an atomic variable, we
4388 -- have to prevent a piecemeal assignment even if the aggregate
4389 -- is to be expanded. We create a temporary for the aggregate, and
4390 -- assign the temporary instead, so that the back end can generate
4391 -- an atomic move for it.
4394 and then (Nkind (Parent (N)) = N_Object_Declaration
4395 or else Nkind (Parent (N)) = N_Assignment_Statement)
4396 and then Comes_From_Source (Parent (N))
4398 Expand_Atomic_Aggregate (N, Typ);
4402 -- Gigi doesn't handle properly temporaries of variable size
4403 -- so we generate it in the front-end
4405 if not Size_Known_At_Compile_Time (Typ) then
4406 Convert_To_Assignments (N, Typ);
4408 -- Temporaries for controlled aggregates need to be attached to a
4409 -- final chain in order to be properly finalized, so it has to
4410 -- be created in the front-end
4412 elsif Is_Controlled (Typ)
4413 or else Has_Controlled_Component (Base_Type (Typ))
4415 Convert_To_Assignments (N, Typ);
4417 -- Ada 2005 (AI-287): In case of default initialized components we
4418 -- convert the aggregate into assignments.
4420 elsif Has_Default_Init_Comps (N) then
4421 Convert_To_Assignments (N, Typ);
4423 elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then
4424 Convert_To_Assignments (N, Typ);
4426 -- If an ancestor is private, some components are not inherited and
4427 -- we cannot expand into a record aggregate
4429 elsif Has_Private_Ancestor (Typ) then
4430 Convert_To_Assignments (N, Typ);
4432 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
4433 -- is not able to handle the aggregate for Late_Request.
4435 elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
4436 Convert_To_Assignments (N, Typ);
4438 -- If some components are mutable, the size of the aggregate component
4439 -- may be disctinct from the default size of the type component, so
4440 -- we need to expand to insure that the back-end copies the proper
4441 -- size of the data.
4443 elsif Has_Mutable_Components (Typ) then
4444 Convert_To_Assignments (N, Typ);
4446 -- If the type involved has any non-bit aligned components, then
4447 -- we are not sure that the back end can handle this case correctly.
4449 elsif Type_May_Have_Bit_Aligned_Components (Typ) then
4450 Convert_To_Assignments (N, Typ);
4452 -- In all other cases we generate a proper aggregate that
4453 -- can be handled by gigi.
4456 -- If no discriminants, nothing special to do
4458 if not Has_Discriminants (Typ) then
4461 -- Case of discriminants present
4463 elsif Is_Derived_Type (Typ) then
4465 -- For untagged types, non-stored discriminants are replaced
4466 -- with stored discriminants, which are the ones that gigi uses
4467 -- to describe the type and its components.
4469 Generate_Aggregate_For_Derived_Type : declare
4470 Constraints : constant List_Id := New_List;
4471 First_Comp : Node_Id;
4472 Discriminant : Entity_Id;
4474 Num_Disc : Int := 0;
4475 Num_Gird : Int := 0;
4477 procedure Prepend_Stored_Values (T : Entity_Id);
4478 -- Scan the list of stored discriminants of the type, and
4479 -- add their values to the aggregate being built.
4481 ---------------------------
4482 -- Prepend_Stored_Values --
4483 ---------------------------
4485 procedure Prepend_Stored_Values (T : Entity_Id) is
4487 Discriminant := First_Stored_Discriminant (T);
4489 while Present (Discriminant) loop
4491 Make_Component_Association (Loc,
4493 New_List (New_Occurrence_Of (Discriminant, Loc)),
4497 Get_Discriminant_Value (
4500 Discriminant_Constraint (Typ))));
4502 if No (First_Comp) then
4503 Prepend_To (Component_Associations (N), New_Comp);
4505 Insert_After (First_Comp, New_Comp);
4508 First_Comp := New_Comp;
4509 Next_Stored_Discriminant (Discriminant);
4511 end Prepend_Stored_Values;
4513 -- Start of processing for Generate_Aggregate_For_Derived_Type
4516 -- Remove the associations for the discriminant of
4517 -- the derived type.
4519 First_Comp := First (Component_Associations (N));
4521 while Present (First_Comp) loop
4525 if Ekind (Entity (First (Choices (Comp)))) =
4529 Num_Disc := Num_Disc + 1;
4533 -- Insert stored discriminant associations in the correct
4534 -- order. If there are more stored discriminants than new
4535 -- discriminants, there is at least one new discriminant
4536 -- that constrains more than one of the stored discriminants.
4537 -- In this case we need to construct a proper subtype of
4538 -- the parent type, in order to supply values to all the
4539 -- components. Otherwise there is one-one correspondence
4540 -- between the constraints and the stored discriminants.
4542 First_Comp := Empty;
4544 Discriminant := First_Stored_Discriminant (Base_Type (Typ));
4546 while Present (Discriminant) loop
4547 Num_Gird := Num_Gird + 1;
4548 Next_Stored_Discriminant (Discriminant);
4551 -- Case of more stored discriminants than new discriminants
4553 if Num_Gird > Num_Disc then
4555 -- Create a proper subtype of the parent type, which is
4556 -- the proper implementation type for the aggregate, and
4557 -- convert it to the intended target type.
4559 Discriminant := First_Stored_Discriminant (Base_Type (Typ));
4561 while Present (Discriminant) loop
4564 Get_Discriminant_Value (
4567 Discriminant_Constraint (Typ)));
4568 Append (New_Comp, Constraints);
4569 Next_Stored_Discriminant (Discriminant);
4573 Make_Subtype_Declaration (Loc,
4574 Defining_Identifier =>
4575 Make_Defining_Identifier (Loc,
4576 New_Internal_Name ('T')),
4577 Subtype_Indication =>
4578 Make_Subtype_Indication (Loc,
4580 New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
4582 Make_Index_Or_Discriminant_Constraint
4583 (Loc, Constraints)));
4585 Insert_Action (N, Decl);
4586 Prepend_Stored_Values (Base_Type (Typ));
4588 Set_Etype (N, Defining_Identifier (Decl));
4591 Rewrite (N, Unchecked_Convert_To (Typ, N));
4594 -- Case where we do not have fewer new discriminants than
4595 -- stored discriminants, so in this case we can simply
4596 -- use the stored discriminants of the subtype.
4599 Prepend_Stored_Values (Typ);
4601 end Generate_Aggregate_For_Derived_Type;
4604 if Is_Tagged_Type (Typ) then
4606 -- The tagged case, _parent and _tag component must be created
4608 -- Reset null_present unconditionally. tagged records always have
4609 -- at least one field (the tag or the parent)
4611 Set_Null_Record_Present (N, False);
4613 -- When the current aggregate comes from the expansion of an
4614 -- extension aggregate, the parent expr is replaced by an
4615 -- aggregate formed by selected components of this expr
4617 if Present (Parent_Expr)
4618 and then Is_Empty_List (Comps)
4620 Comp := First_Entity (Typ);
4621 while Present (Comp) loop
4623 -- Skip all entities that aren't discriminants or components
4625 if Ekind (Comp) /= E_Discriminant
4626 and then Ekind (Comp) /= E_Component
4630 -- Skip all expander-generated components
4633 not Comes_From_Source (Original_Record_Component (Comp))
4639 Make_Selected_Component (Loc,
4641 Unchecked_Convert_To (Typ,
4642 Duplicate_Subexpr (Parent_Expr, True)),
4644 Selector_Name => New_Occurrence_Of (Comp, Loc));
4647 Make_Component_Association (Loc,
4649 New_List (New_Occurrence_Of (Comp, Loc)),
4653 Analyze_And_Resolve (New_Comp, Etype (Comp));
4660 -- Compute the value for the Tag now, if the type is a root it
4661 -- will be included in the aggregate right away, otherwise it will
4662 -- be propagated to the parent aggregate
4664 if Present (Orig_Tag) then
4665 Tag_Value := Orig_Tag;
4671 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
4674 -- For a derived type, an aggregate for the parent is formed with
4675 -- all the inherited components.
4677 if Is_Derived_Type (Typ) then
4680 First_Comp : Node_Id;
4681 Parent_Comps : List_Id;
4682 Parent_Aggr : Node_Id;
4683 Parent_Name : Node_Id;
4686 -- Remove the inherited component association from the
4687 -- aggregate and store them in the parent aggregate
4689 First_Comp := First (Component_Associations (N));
4690 Parent_Comps := New_List;
4692 while Present (First_Comp)
4693 and then Scope (Original_Record_Component (
4694 Entity (First (Choices (First_Comp))))) /= Base_Typ
4699 Append (Comp, Parent_Comps);
4702 Parent_Aggr := Make_Aggregate (Loc,
4703 Component_Associations => Parent_Comps);
4704 Set_Etype (Parent_Aggr, Etype (Base_Type (Typ)));
4706 -- Find the _parent component
4708 Comp := First_Component (Typ);
4709 while Chars (Comp) /= Name_uParent loop
4710 Comp := Next_Component (Comp);
4713 Parent_Name := New_Occurrence_Of (Comp, Loc);
4715 -- Insert the parent aggregate
4717 Prepend_To (Component_Associations (N),
4718 Make_Component_Association (Loc,
4719 Choices => New_List (Parent_Name),
4720 Expression => Parent_Aggr));
4722 -- Expand recursively the parent propagating the right Tag
4724 Expand_Record_Aggregate (
4725 Parent_Aggr, Tag_Value, Parent_Expr);
4728 -- For a root type, the tag component is added (unless compiling
4729 -- for the Java VM, where tags are implicit).
4731 elsif not Java_VM then
4733 Tag_Name : constant Node_Id :=
4735 (First_Tag_Component (Typ), Loc);
4736 Typ_Tag : constant Entity_Id := RTE (RE_Tag);
4737 Conv_Node : constant Node_Id :=
4738 Unchecked_Convert_To (Typ_Tag, Tag_Value);
4741 Set_Etype (Conv_Node, Typ_Tag);
4742 Prepend_To (Component_Associations (N),
4743 Make_Component_Association (Loc,
4744 Choices => New_List (Tag_Name),
4745 Expression => Conv_Node));
4750 end Expand_Record_Aggregate;
4752 ----------------------------
4753 -- Has_Default_Init_Comps --
4754 ----------------------------
4756 function Has_Default_Init_Comps (N : Node_Id) return Boolean is
4757 Comps : constant List_Id := Component_Associations (N);
4761 pragma Assert (Nkind (N) = N_Aggregate
4762 or else Nkind (N) = N_Extension_Aggregate);
4768 -- Check if any direct component has default initialized components
4771 while Present (C) loop
4772 if Box_Present (C) then
4779 -- Recursive call in case of aggregate expression
4782 while Present (C) loop
4783 Expr := Expression (C);
4786 and then (Nkind (Expr) = N_Aggregate
4787 or else Nkind (Expr) = N_Extension_Aggregate)
4788 and then Has_Default_Init_Comps (Expr)
4797 end Has_Default_Init_Comps;
4799 --------------------------
4800 -- Is_Delayed_Aggregate --
4801 --------------------------
4803 function Is_Delayed_Aggregate (N : Node_Id) return Boolean is
4804 Node : Node_Id := N;
4805 Kind : Node_Kind := Nkind (Node);
4808 if Kind = N_Qualified_Expression then
4809 Node := Expression (Node);
4810 Kind := Nkind (Node);
4813 if Kind /= N_Aggregate and then Kind /= N_Extension_Aggregate then
4816 return Expansion_Delayed (Node);
4818 end Is_Delayed_Aggregate;
4820 --------------------
4821 -- Late_Expansion --
4822 --------------------
4824 function Late_Expansion
4828 Flist : Node_Id := Empty;
4829 Obj : Entity_Id := Empty) return List_Id
4832 if Is_Record_Type (Etype (N)) then
4833 return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj);
4835 else pragma Assert (Is_Array_Type (Etype (N)));
4837 Build_Array_Aggr_Code
4839 Ctype => Component_Type (Etype (N)),
4840 Index => First_Index (Typ),
4842 Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
4848 ----------------------------------
4849 -- Make_OK_Assignment_Statement --
4850 ----------------------------------
4852 function Make_OK_Assignment_Statement
4855 Expression : Node_Id) return Node_Id
4858 Set_Assignment_OK (Name);
4859 return Make_Assignment_Statement (Sloc, Name, Expression);
4860 end Make_OK_Assignment_Statement;
4862 -----------------------
4863 -- Number_Of_Choices --
4864 -----------------------
4866 function Number_Of_Choices (N : Node_Id) return Nat is
4870 Nb_Choices : Nat := 0;
4873 if Present (Expressions (N)) then
4877 Assoc := First (Component_Associations (N));
4878 while Present (Assoc) loop
4880 Choice := First (Choices (Assoc));
4881 while Present (Choice) loop
4883 if Nkind (Choice) /= N_Others_Choice then
4884 Nb_Choices := Nb_Choices + 1;
4894 end Number_Of_Choices;
4896 ------------------------------------
4897 -- Packed_Array_Aggregate_Handled --
4898 ------------------------------------
4900 -- The current version of this procedure will handle at compile time
4901 -- any array aggregate that meets these conditions:
4903 -- One dimensional, bit packed
4904 -- Underlying packed type is modular type
4905 -- Bounds are within 32-bit Int range
4906 -- All bounds and values are static
4908 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is
4909 Loc : constant Source_Ptr := Sloc (N);
4910 Typ : constant Entity_Id := Etype (N);
4911 Ctyp : constant Entity_Id := Component_Type (Typ);
4913 Not_Handled : exception;
4914 -- Exception raised if this aggregate cannot be handled
4917 -- For now, handle only one dimensional bit packed arrays
4919 if not Is_Bit_Packed_Array (Typ)
4920 or else Number_Dimensions (Typ) > 1
4921 or else not Is_Modular_Integer_Type (Packed_Array_Type (Typ))
4927 Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
4931 -- Bounds of index type
4935 -- Values of bounds if compile time known
4937 function Get_Component_Val (N : Node_Id) return Uint;
4938 -- Given a expression value N of the component type Ctyp, returns
4939 -- A value of Csiz (component size) bits representing this value.
4940 -- If the value is non-static or any other reason exists why the
4941 -- value cannot be returned, then Not_Handled is raised.
4943 -----------------------
4944 -- Get_Component_Val --
4945 -----------------------
4947 function Get_Component_Val (N : Node_Id) return Uint is
4951 -- We have to analyze the expression here before doing any further
4952 -- processing here. The analysis of such expressions is deferred
4953 -- till expansion to prevent some problems of premature analysis.
4955 Analyze_And_Resolve (N, Ctyp);
4957 -- Must have a compile time value. String literals have to
4958 -- be converted into temporaries as well, because they cannot
4959 -- easily be converted into their bit representation.
4961 if not Compile_Time_Known_Value (N)
4962 or else Nkind (N) = N_String_Literal
4967 Val := Expr_Rep_Value (N);
4969 -- Adjust for bias, and strip proper number of bits
4971 if Has_Biased_Representation (Ctyp) then
4972 Val := Val - Expr_Value (Type_Low_Bound (Ctyp));
4975 return Val mod Uint_2 ** Csiz;
4976 end Get_Component_Val;
4978 -- Here we know we have a one dimensional bit packed array
4981 Get_Index_Bounds (First_Index (Typ), Lo, Hi);
4983 -- Cannot do anything if bounds are dynamic
4985 if not Compile_Time_Known_Value (Lo)
4987 not Compile_Time_Known_Value (Hi)
4992 -- Or are silly out of range of int bounds
4994 Lob := Expr_Value (Lo);
4995 Hib := Expr_Value (Hi);
4997 if not UI_Is_In_Int_Range (Lob)
4999 not UI_Is_In_Int_Range (Hib)
5004 -- At this stage we have a suitable aggregate for handling
5005 -- at compile time (the only remaining checks, are that the
5006 -- values of expressions in the aggregate are compile time
5007 -- known (check performed by Get_Component_Val), and that
5008 -- any subtypes or ranges are statically known.
5010 -- If the aggregate is not fully positional at this stage,
5011 -- then convert it to positional form. Either this will fail,
5012 -- in which case we can do nothing, or it will succeed, in
5013 -- which case we have succeeded in handling the aggregate,
5014 -- or it will stay an aggregate, in which case we have failed
5015 -- to handle this case.
5017 if Present (Component_Associations (N)) then
5018 Convert_To_Positional
5019 (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
5020 return Nkind (N) /= N_Aggregate;
5023 -- Otherwise we are all positional, so convert to proper value
5026 Lov : constant Int := UI_To_Int (Lob);
5027 Hiv : constant Int := UI_To_Int (Hib);
5029 Len : constant Nat := Int'Max (0, Hiv - Lov + 1);
5030 -- The length of the array (number of elements)
5032 Aggregate_Val : Uint;
5033 -- Value of aggregate. The value is set in the low order
5034 -- bits of this value. For the little-endian case, the
5035 -- values are stored from low-order to high-order and
5036 -- for the big-endian case the values are stored from
5037 -- high-order to low-order. Note that gigi will take care
5038 -- of the conversions to left justify the value in the big
5039 -- endian case (because of left justified modular type
5040 -- processing), so we do not have to worry about that here.
5043 -- Integer literal for resulting constructed value
5046 -- Shift count from low order for next value
5049 -- Shift increment for loop
5052 -- Next expression from positional parameters of aggregate
5055 -- For little endian, we fill up the low order bits of the
5056 -- target value. For big endian we fill up the high order
5057 -- bits of the target value (which is a left justified
5060 if Bytes_Big_Endian xor Debug_Flag_8 then
5061 Shift := Csiz * (Len - 1);
5068 -- Loop to set the values
5071 Aggregate_Val := Uint_0;
5073 Expr := First (Expressions (N));
5074 Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
5076 for J in 2 .. Len loop
5077 Shift := Shift + Incr;
5080 Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
5084 -- Now we can rewrite with the proper value
5087 Make_Integer_Literal (Loc,
5088 Intval => Aggregate_Val);
5089 Set_Print_In_Hex (Lit);
5091 -- Construct the expression using this literal. Note that it is
5092 -- important to qualify the literal with its proper modular type
5093 -- since universal integer does not have the required range and
5094 -- also this is a left justified modular type, which is important
5095 -- in the big-endian case.
5098 Unchecked_Convert_To (Typ,
5099 Make_Qualified_Expression (Loc,
5101 New_Occurrence_Of (Packed_Array_Type (Typ), Loc),
5102 Expression => Lit)));
5104 Analyze_And_Resolve (N, Typ);
5112 end Packed_Array_Aggregate_Handled;
5114 ----------------------------
5115 -- Has_Mutable_Components --
5116 ----------------------------
5118 function Has_Mutable_Components (Typ : Entity_Id) return Boolean is
5122 Comp := First_Component (Typ);
5124 while Present (Comp) loop
5125 if Is_Record_Type (Etype (Comp))
5126 and then Has_Discriminants (Etype (Comp))
5127 and then not Is_Constrained (Etype (Comp))
5132 Next_Component (Comp);
5136 end Has_Mutable_Components;
5138 ------------------------------
5139 -- Initialize_Discriminants --
5140 ------------------------------
5142 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is
5143 Loc : constant Source_Ptr := Sloc (N);
5144 Bas : constant Entity_Id := Base_Type (Typ);
5145 Par : constant Entity_Id := Etype (Bas);
5146 Decl : constant Node_Id := Parent (Par);
5150 if Is_Tagged_Type (Bas)
5151 and then Is_Derived_Type (Bas)
5152 and then Has_Discriminants (Par)
5153 and then Has_Discriminants (Bas)
5154 and then Number_Discriminants (Bas) /= Number_Discriminants (Par)
5155 and then Nkind (Decl) = N_Full_Type_Declaration
5156 and then Nkind (Type_Definition (Decl)) = N_Record_Definition
5158 (Variant_Part (Component_List (Type_Definition (Decl))))
5159 and then Nkind (N) /= N_Extension_Aggregate
5162 -- Call init proc to set discriminants.
5163 -- There should eventually be a special procedure for this ???
5165 Ref := New_Reference_To (Defining_Identifier (N), Loc);
5166 Insert_Actions_After (N,
5167 Build_Initialization_Call (Sloc (N), Ref, Typ));
5169 end Initialize_Discriminants;
5176 (Obj_Type : Entity_Id;
5177 Typ : Entity_Id) return Boolean
5179 L1, L2, H1, H2 : Node_Id;
5181 -- No sliding if the type of the object is not established yet, if
5182 -- it is an unconstrained type whose actual subtype comes from the
5183 -- aggregate, or if the two types are identical.
5185 if not Is_Array_Type (Obj_Type) then
5188 elsif not Is_Constrained (Obj_Type) then
5191 elsif Typ = Obj_Type then
5195 -- Sliding can only occur along the first dimension
5197 Get_Index_Bounds (First_Index (Typ), L1, H1);
5198 Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
5200 if not Is_Static_Expression (L1)
5201 or else not Is_Static_Expression (L2)
5202 or else not Is_Static_Expression (H1)
5203 or else not Is_Static_Expression (H2)
5207 return Expr_Value (L1) /= Expr_Value (L2)
5208 or else Expr_Value (H1) /= Expr_Value (H2);
5213 ---------------------------
5214 -- Safe_Slice_Assignment --
5215 ---------------------------
5217 function Safe_Slice_Assignment (N : Node_Id) return Boolean is
5218 Loc : constant Source_Ptr := Sloc (Parent (N));
5219 Pref : constant Node_Id := Prefix (Name (Parent (N)));
5220 Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N)));
5228 -- Generate: for J in Range loop Pref (J) := Expr; end loop;
5230 if Comes_From_Source (N)
5231 and then No (Expressions (N))
5232 and then Nkind (First (Choices (First (Component_Associations (N)))))
5236 Expression (First (Component_Associations (N)));
5237 L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
5240 Make_Iteration_Scheme (Loc,
5241 Loop_Parameter_Specification =>
5242 Make_Loop_Parameter_Specification
5244 Defining_Identifier => L_J,
5245 Discrete_Subtype_Definition => Relocate_Node (Range_Node)));
5248 Make_Assignment_Statement (Loc,
5250 Make_Indexed_Component (Loc,
5251 Prefix => Relocate_Node (Pref),
5252 Expressions => New_List (New_Occurrence_Of (L_J, Loc))),
5253 Expression => Relocate_Node (Expr));
5255 -- Construct the final loop
5258 Make_Implicit_Loop_Statement
5259 (Node => Parent (N),
5260 Identifier => Empty,
5261 Iteration_Scheme => L_Iter,
5262 Statements => New_List (L_Body));
5264 -- Set type of aggregate to be type of lhs in assignment,
5265 -- to suppress redundant length checks.
5267 Set_Etype (N, Etype (Name (Parent (N))));
5269 Rewrite (Parent (N), Stat);
5270 Analyze (Parent (N));
5276 end Safe_Slice_Assignment;
5278 ---------------------
5279 -- Sort_Case_Table --
5280 ---------------------
5282 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
5283 L : constant Int := Case_Table'First;
5284 U : constant Int := Case_Table'Last;
5293 T := Case_Table (K + 1);
5297 and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
5298 Expr_Value (T.Choice_Lo)
5300 Case_Table (J) := Case_Table (J - 1);
5304 Case_Table (J) := T;
5307 end Sort_Case_Table;