1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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 Freeze; use Freeze;
38 with Hostparm; use Hostparm;
39 with Itypes; use Itypes;
41 with Nmake; use Nmake;
42 with Nlists; use Nlists;
43 with Restrict; use Restrict;
44 with Rtsfind; use Rtsfind;
45 with Ttypes; use Ttypes;
47 with Sem_Ch3; use Sem_Ch3;
48 with Sem_Eval; use Sem_Eval;
49 with Sem_Res; use Sem_Res;
50 with Sem_Util; use Sem_Util;
51 with Sinfo; use Sinfo;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Tbuild; use Tbuild;
55 with Uintp; use Uintp;
57 package body Exp_Aggr is
59 type Case_Bounds is record
62 Choice_Node : Node_Id;
65 type Case_Table_Type is array (Nat range <>) of Case_Bounds;
66 -- Table type used by Check_Case_Choices procedure
68 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
69 -- Sort the Case Table using the Lower Bound of each Choice as the key.
70 -- A simple insertion sort is used since the number of choices in a case
71 -- statement of variant part will usually be small and probably in near
74 function Has_Default_Init_Comps (N : Node_Id) return Boolean;
75 -- N is an aggregate (record or array). Checks the presence of default
76 -- initialization (<>) in any component (Ada0Y: AI-287)
78 ------------------------------------------------------
79 -- Local subprograms for Record Aggregate Expansion --
80 ------------------------------------------------------
82 procedure Expand_Record_Aggregate
84 Orig_Tag : Node_Id := Empty;
85 Parent_Expr : Node_Id := Empty);
86 -- This is the top level procedure for record aggregate expansion.
87 -- Expansion for record aggregates needs expand aggregates for tagged
88 -- record types. Specifically Expand_Record_Aggregate adds the Tag
89 -- field in front of the Component_Association list that was created
90 -- during resolution by Resolve_Record_Aggregate.
92 -- N is the record aggregate node.
93 -- Orig_Tag is the value of the Tag that has to be provided for this
94 -- specific aggregate. It carries the tag corresponding to the type
95 -- of the outermost aggregate during the recursive expansion
96 -- Parent_Expr is the ancestor part of the original extension
99 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
100 -- N is an N_Aggregate of a N_Extension_Aggregate. Typ is the type of
101 -- the aggregate. Transform the given aggregate into a sequence of
102 -- assignments component per component.
104 function Build_Record_Aggr_Code
108 Flist : Node_Id := Empty;
109 Obj : Entity_Id := Empty;
110 Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id;
111 -- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type
112 -- of the aggregate. Target is an expression containing the
113 -- location on which the component by component assignments will
114 -- take place. Returns the list of assignments plus all other
115 -- adjustments needed for tagged and controlled types. Flist is an
116 -- expression representing the finalization list on which to
117 -- attach the controlled components if any. Obj is present in the
118 -- object declaration and dynamic allocation cases, it contains
119 -- an entity that allows to know if the value being created needs to be
120 -- attached to the final list in case of pragma finalize_Storage_Only.
121 -- Is_Limited_Ancestor_Expansion indicates that the function has been
122 -- called recursively to expand the limited ancestor to avoid copying it.
124 function Has_Mutable_Components (Typ : Entity_Id) return Boolean;
125 -- Return true if one of the component is of a discriminated type with
126 -- defaults. An aggregate for a type with mutable components must be
127 -- expanded into individual assignments.
129 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);
130 -- If the type of the aggregate is a type extension with renamed discrimi-
131 -- nants, we must initialize the hidden discriminants of the parent.
132 -- Otherwise, the target object must not be initialized. The discriminants
133 -- are initialized by calling the initialization procedure for the type.
134 -- This is incorrect if the initialization of other components has any
135 -- side effects. We restrict this call to the case where the parent type
136 -- has a variant part, because this is the only case where the hidden
137 -- discriminants are accessed, namely when calling discriminant checking
138 -- functions of the parent type, and when applying a stream attribute to
139 -- an object of the derived type.
141 -----------------------------------------------------
142 -- Local Subprograms for Array Aggregate Expansion --
143 -----------------------------------------------------
145 procedure Convert_To_Positional
147 Max_Others_Replicate : Nat := 5;
148 Handle_Bit_Packed : Boolean := False);
149 -- If possible, convert named notation to positional notation. This
150 -- conversion is possible only in some static cases. If the conversion
151 -- is possible, then N is rewritten with the analyzed converted
152 -- aggregate. The parameter Max_Others_Replicate controls the maximum
153 -- number of values corresponding to an others choice that will be
154 -- converted to positional notation (the default of 5 is the normal
155 -- limit, and reflects the fact that normally the loop is better than
156 -- a lot of separate assignments). Note that this limit gets overridden
157 -- in any case if either of the restrictions No_Elaboration_Code or
158 -- No_Implicit_Loops is set. The parameter Handle_Bit_Packed is usually
159 -- set False (since we do not expect the back end to handle bit packed
160 -- arrays, so the normal case of conversion is pointless), but in the
161 -- special case of a call from Packed_Array_Aggregate_Handled, we set
162 -- this parameter to True, since these are cases we handle in there.
164 procedure Expand_Array_Aggregate (N : Node_Id);
165 -- This is the top-level routine to perform array aggregate expansion.
166 -- N is the N_Aggregate node to be expanded.
168 function Backend_Processing_Possible (N : Node_Id) return Boolean;
169 -- This function checks if array aggregate N can be processed directly
170 -- by Gigi. If this is the case True is returned.
172 function Build_Array_Aggr_Code
177 Scalar_Comp : Boolean;
178 Indices : List_Id := No_List;
179 Flist : Node_Id := Empty) return List_Id;
180 -- This recursive routine returns a list of statements containing the
181 -- loops and assignments that are needed for the expansion of the array
184 -- N is the (sub-)aggregate node to be expanded into code. This node
185 -- has been fully analyzed, and its Etype is properly set.
187 -- Index is the index node corresponding to the array sub-aggregate N.
189 -- Into is the target expression into which we are copying the aggregate.
190 -- Note that this node may not have been analyzed yet, and so the Etype
191 -- field may not be set.
193 -- Scalar_Comp is True if the component type of the aggregate is scalar.
195 -- Indices is the current list of expressions used to index the
196 -- object we are writing into.
198 -- Flist is an expression representing the finalization list on which
199 -- to attach the controlled components if any.
201 function Number_Of_Choices (N : Node_Id) return Nat;
202 -- Returns the number of discrete choices (not including the others choice
203 -- if present) contained in (sub-)aggregate N.
205 function Late_Expansion
209 Flist : Node_Id := Empty;
210 Obj : Entity_Id := Empty) return List_Id;
211 -- N is a nested (record or array) aggregate that has been marked
212 -- with 'Delay_Expansion'. Typ is the expected type of the
213 -- aggregate and Target is a (duplicable) expression that will
214 -- hold the result of the aggregate expansion. Flist is the
215 -- finalization list to be used to attach controlled
216 -- components. 'Obj' when non empty, carries the original object
217 -- being initialized in order to know if it needs to be attached
218 -- to the previous parameter which may not be the case when
219 -- Finalize_Storage_Only is set. Basically this procedure is used
220 -- to implement top-down expansions of nested aggregates. This is
221 -- necessary for avoiding temporaries at each level as well as for
222 -- propagating the right internal finalization list.
224 function Make_OK_Assignment_Statement
227 Expression : Node_Id) return Node_Id;
228 -- This is like Make_Assignment_Statement, except that Assignment_OK
229 -- is set in the left operand. All assignments built by this unit
230 -- use this routine. This is needed to deal with assignments to
231 -- initialized constants that are done in place.
233 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
234 -- Given an array aggregate, this function handles the case of a packed
235 -- array aggregate with all constant values, where the aggregate can be
236 -- evaluated at compile time. If this is possible, then N is rewritten
237 -- to be its proper compile time value with all the components properly
238 -- assembled. The expression is analyzed and resolved and True is
239 -- returned. If this transformation is not possible, N is unchanged
240 -- and False is returned
242 function Safe_Slice_Assignment (N : Node_Id) return Boolean;
243 -- If a slice assignment has an aggregate with a single others_choice,
244 -- the assignment can be done in place even if bounds are not static,
245 -- by converting it into a loop over the discrete range of the slice.
247 ---------------------------------
248 -- Backend_Processing_Possible --
249 ---------------------------------
251 -- Backend processing by Gigi/gcc is possible only if all the following
252 -- conditions are met:
254 -- 1. N is fully positional
256 -- 2. N is not a bit-packed array aggregate;
258 -- 3. The size of N's array type must be known at compile time. Note
259 -- that this implies that the component size is also known
261 -- 4. The array type of N does not follow the Fortran layout convention
262 -- or if it does it must be 1 dimensional.
264 -- 5. The array component type is tagged, which may necessitate
265 -- reassignment of proper tags.
267 -- 6. The array component type might have unaligned bit components
269 function Backend_Processing_Possible (N : Node_Id) return Boolean is
270 Typ : constant Entity_Id := Etype (N);
271 -- Typ is the correct constrained array subtype of the aggregate.
273 function Static_Check (N : Node_Id; Index : Node_Id) return Boolean;
274 -- Recursively checks that N is fully positional, returns true if so.
280 function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is
284 -- Check for component associations
286 if Present (Component_Associations (N)) then
290 -- Recurse to check subaggregates, which may appear in qualified
291 -- expressions. If delayed, the front-end will have to expand.
293 Expr := First (Expressions (N));
295 while Present (Expr) loop
297 if Is_Delayed_Aggregate (Expr) then
301 if Present (Next_Index (Index))
302 and then not Static_Check (Expr, Next_Index (Index))
313 -- Start of processing for Backend_Processing_Possible
316 -- Checks 2 (array must not be bit packed)
318 if Is_Bit_Packed_Array (Typ) then
322 -- Checks 4 (array must not be multi-dimensional Fortran case)
324 if Convention (Typ) = Convention_Fortran
325 and then Number_Dimensions (Typ) > 1
330 -- Checks 3 (size of array must be known at compile time)
332 if not Size_Known_At_Compile_Time (Typ) then
336 -- Checks 1 (aggregate must be fully positional)
338 if not Static_Check (N, First_Index (Typ)) then
342 -- Checks 5 (if the component type is tagged, then we may need
343 -- to do tag adjustments; perhaps this should be refined to
344 -- check for any component associations that actually
345 -- need tag adjustment, along the lines of the test that's
346 -- done in Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
347 -- for record aggregates with tagged components, but not
348 -- clear whether it's worthwhile ???; in the case of the
349 -- JVM, object tags are handled implicitly)
351 if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then
355 -- Checks 6 (component type must not have bit aligned components)
357 if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then
361 -- Backend processing is possible
363 Set_Compile_Time_Known_Aggregate (N, True);
364 Set_Size_Known_At_Compile_Time (Etype (N), True);
366 end Backend_Processing_Possible;
368 ---------------------------
369 -- Build_Array_Aggr_Code --
370 ---------------------------
372 -- The code that we generate from a one dimensional aggregate is
374 -- 1. If the sub-aggregate contains discrete choices we
376 -- (a) Sort the discrete choices
378 -- (b) Otherwise for each discrete choice that specifies a range we
379 -- emit a loop. If a range specifies a maximum of three values, or
380 -- we are dealing with an expression we emit a sequence of
381 -- assignments instead of a loop.
383 -- (c) Generate the remaining loops to cover the others choice if any.
385 -- 2. If the aggregate contains positional elements we
387 -- (a) translate the positional elements in a series of assignments.
389 -- (b) Generate a final loop to cover the others choice if any.
390 -- Note that this final loop has to be a while loop since the case
392 -- L : Integer := Integer'Last;
393 -- H : Integer := Integer'Last;
394 -- A : array (L .. H) := (1, others =>0);
396 -- cannot be handled by a for loop. Thus for the following
398 -- array (L .. H) := (.. positional elements.., others =>E);
400 -- we always generate something like:
402 -- J : Index_Type := Index_Of_Last_Positional_Element;
404 -- J := Index_Base'Succ (J)
408 function Build_Array_Aggr_Code
413 Scalar_Comp : Boolean;
414 Indices : List_Id := No_List;
415 Flist : Node_Id := Empty) return List_Id
417 Loc : constant Source_Ptr := Sloc (N);
418 Index_Base : constant Entity_Id := Base_Type (Etype (Index));
419 Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base);
420 Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);
422 function Add (Val : Int; To : Node_Id) return Node_Id;
423 -- Returns an expression where Val is added to expression To,
424 -- unless To+Val is provably out of To's base type range.
425 -- To must be an already analyzed expression.
427 function Empty_Range (L, H : Node_Id) return Boolean;
428 -- Returns True if the range defined by L .. H is certainly empty.
430 function Equal (L, H : Node_Id) return Boolean;
431 -- Returns True if L = H for sure.
433 function Index_Base_Name return Node_Id;
434 -- Returns a new reference to the index type name.
436 function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
437 -- Ind must be a side-effect free expression. If the input aggregate
438 -- N to Build_Loop contains no sub-aggregates, then this function
439 -- returns the assignment statement:
441 -- Into (Indices, Ind) := Expr;
443 -- Otherwise we call Build_Code recursively.
445 -- Ada0Y (AI-287): In case of default initialized component, Expr is
446 -- empty and we generate a call to the corresponding IP subprogram.
448 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
449 -- Nodes L and H must be side-effect free expressions.
450 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
451 -- This routine returns the for loop statement
453 -- for J in Index_Base'(L) .. Index_Base'(H) loop
454 -- Into (Indices, J) := Expr;
457 -- Otherwise we call Build_Code recursively.
458 -- As an optimization if the loop covers 3 or less scalar elements we
459 -- generate a sequence of assignments.
461 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
462 -- Nodes L and H must be side-effect free expressions.
463 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
464 -- This routine returns the while loop statement
466 -- J : Index_Base := L;
468 -- J := Index_Base'Succ (J);
469 -- Into (Indices, J) := Expr;
472 -- Otherwise we call Build_Code recursively
474 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
475 function Local_Expr_Value (E : Node_Id) return Uint;
476 -- These two Local routines are used to replace the corresponding ones
477 -- in sem_eval because while processing the bounds of an aggregate with
478 -- discrete choices whose index type is an enumeration, we build static
479 -- expressions not recognized by Compile_Time_Known_Value as such since
480 -- they have not yet been analyzed and resolved. All the expressions in
481 -- question are things like Index_Base_Name'Val (Const) which we can
482 -- easily recognize as being constant.
488 function Add (Val : Int; To : Node_Id) return Node_Id is
493 U_Val : constant Uint := UI_From_Int (Val);
496 -- Note: do not try to optimize the case of Val = 0, because
497 -- we need to build a new node with the proper Sloc value anyway.
499 -- First test if we can do constant folding
501 if Local_Compile_Time_Known_Value (To) then
502 U_To := Local_Expr_Value (To) + Val;
504 -- Determine if our constant is outside the range of the index.
505 -- If so return an Empty node. This empty node will be caught
506 -- by Empty_Range below.
508 if Compile_Time_Known_Value (Index_Base_L)
509 and then U_To < Expr_Value (Index_Base_L)
513 elsif Compile_Time_Known_Value (Index_Base_H)
514 and then U_To > Expr_Value (Index_Base_H)
519 Expr_Pos := Make_Integer_Literal (Loc, U_To);
520 Set_Is_Static_Expression (Expr_Pos);
522 if not Is_Enumeration_Type (Index_Base) then
525 -- If we are dealing with enumeration return
526 -- Index_Base'Val (Expr_Pos)
530 Make_Attribute_Reference
532 Prefix => Index_Base_Name,
533 Attribute_Name => Name_Val,
534 Expressions => New_List (Expr_Pos));
540 -- If we are here no constant folding possible
542 if not Is_Enumeration_Type (Index_Base) then
545 Left_Opnd => Duplicate_Subexpr (To),
546 Right_Opnd => Make_Integer_Literal (Loc, U_Val));
548 -- If we are dealing with enumeration return
549 -- Index_Base'Val (Index_Base'Pos (To) + Val)
553 Make_Attribute_Reference
555 Prefix => Index_Base_Name,
556 Attribute_Name => Name_Pos,
557 Expressions => New_List (Duplicate_Subexpr (To)));
562 Right_Opnd => Make_Integer_Literal (Loc, U_Val));
565 Make_Attribute_Reference
567 Prefix => Index_Base_Name,
568 Attribute_Name => Name_Val,
569 Expressions => New_List (Expr_Pos));
579 function Empty_Range (L, H : Node_Id) return Boolean is
580 Is_Empty : Boolean := False;
585 -- First check if L or H were already detected as overflowing the
586 -- index base range type by function Add above. If this is so Add
587 -- returns the empty node.
589 if No (L) or else No (H) then
596 -- L > H range is empty
602 -- B_L > H range must be empty
608 -- L > B_H range must be empty
612 High := Index_Base_H;
615 if Local_Compile_Time_Known_Value (Low)
616 and then Local_Compile_Time_Known_Value (High)
619 UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High));
632 function Equal (L, H : Node_Id) return Boolean is
637 elsif Local_Compile_Time_Known_Value (L)
638 and then Local_Compile_Time_Known_Value (H)
640 return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H));
650 function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
651 L : constant List_Id := New_List;
655 New_Indices : List_Id;
656 Indexed_Comp : Node_Id;
658 Comp_Type : Entity_Id := Empty;
660 function Add_Loop_Actions (Lis : List_Id) return List_Id;
661 -- Collect insert_actions generated in the construction of a
662 -- loop, and prepend them to the sequence of assignments to
663 -- complete the eventual body of the loop.
665 ----------------------
666 -- Add_Loop_Actions --
667 ----------------------
669 function Add_Loop_Actions (Lis : List_Id) return List_Id is
673 -- Ada0Y (AI-287): Do nothing else in case of default initialized
676 if not Present (Expr) then
679 elsif Nkind (Parent (Expr)) = N_Component_Association
680 and then Present (Loop_Actions (Parent (Expr)))
682 Append_List (Lis, Loop_Actions (Parent (Expr)));
683 Res := Loop_Actions (Parent (Expr));
684 Set_Loop_Actions (Parent (Expr), No_List);
690 end Add_Loop_Actions;
692 -- Start of processing for Gen_Assign
696 New_Indices := New_List;
698 New_Indices := New_Copy_List_Tree (Indices);
701 Append_To (New_Indices, Ind);
703 if Present (Flist) then
704 F := New_Copy_Tree (Flist);
706 elsif Present (Etype (N)) and then Controlled_Type (Etype (N)) then
707 if Is_Entity_Name (Into)
708 and then Present (Scope (Entity (Into)))
710 F := Find_Final_List (Scope (Entity (Into)));
712 F := Find_Final_List (Current_Scope);
718 if Present (Next_Index (Index)) then
721 Build_Array_Aggr_Code
724 Index => Next_Index (Index),
726 Scalar_Comp => Scalar_Comp,
727 Indices => New_Indices,
731 -- If we get here then we are at a bottom-level (sub-)aggregate
735 (Make_Indexed_Component (Loc,
736 Prefix => New_Copy_Tree (Into),
737 Expressions => New_Indices));
739 Set_Assignment_OK (Indexed_Comp);
741 -- Ada0Y (AI-287): In case of default initialized component, Expr
742 -- is not present (and therefore we also initialize Expr_Q to empty)
744 if not Present (Expr) then
746 elsif Nkind (Expr) = N_Qualified_Expression then
747 Expr_Q := Expression (Expr);
752 if Present (Etype (N))
753 and then Etype (N) /= Any_Composite
755 Comp_Type := Component_Type (Etype (N));
756 pragma Assert (Comp_Type = Ctype); -- AI-287
758 elsif Present (Next (First (New_Indices))) then
760 -- Ada0Y (AI-287): Do nothing in case of default initialized
761 -- component because we have received the component type in
762 -- the formal parameter Ctype.
763 -- ??? I have added some assert pragmas to check if this new
764 -- formal can be used to replace this code in all cases.
766 if Present (Expr) then
768 -- This is a multidimensional array. Recover the component
769 -- type from the outermost aggregate, because subaggregates
770 -- do not have an assigned type.
773 P : Node_Id := Parent (Expr);
776 while Present (P) loop
778 if Nkind (P) = N_Aggregate
779 and then Present (Etype (P))
781 Comp_Type := Component_Type (Etype (P));
788 pragma Assert (Comp_Type = Ctype); -- AI-287
793 -- Ada0Y (AI-287): We only analyze the expression in case of non
794 -- default initialized components (otherwise Expr_Q is not present)
797 and then (Nkind (Expr_Q) = N_Aggregate
798 or else Nkind (Expr_Q) = N_Extension_Aggregate)
800 -- At this stage the Expression may not have been
801 -- analyzed yet because the array aggregate code has not
802 -- been updated to use the Expansion_Delayed flag and
803 -- avoid analysis altogether to solve the same problem
804 -- (see Resolve_Aggr_Expr) so let's do the analysis of
805 -- non-array aggregates now in order to get the value of
806 -- Expansion_Delayed flag for the inner aggregate ???
808 if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then
809 Analyze_And_Resolve (Expr_Q, Comp_Type);
812 if Is_Delayed_Aggregate (Expr_Q) then
815 Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp, F));
819 -- Ada0Y (AI-287): In case of default initialized component, call
820 -- the initialization subprogram associated with the component type
822 if not Present (Expr) then
825 Build_Initialization_Call (Loc,
826 Id_Ref => Indexed_Comp,
828 With_Default_Init => True));
832 -- Now generate the assignment with no associated controlled
833 -- actions since the target of the assignment may not have
834 -- been initialized, it is not possible to Finalize it as
835 -- expected by normal controlled assignment. The rest of the
836 -- controlled actions are done manually with the proper
837 -- finalization list coming from the context.
840 Make_OK_Assignment_Statement (Loc,
841 Name => Indexed_Comp,
842 Expression => New_Copy_Tree (Expr));
844 if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
845 Set_No_Ctrl_Actions (A);
850 -- Adjust the tag if tagged (because of possible view
851 -- conversions), unless compiling for the Java VM
852 -- where tags are implicit.
854 if Present (Comp_Type)
855 and then Is_Tagged_Type (Comp_Type)
859 Make_OK_Assignment_Statement (Loc,
861 Make_Selected_Component (Loc,
862 Prefix => New_Copy_Tree (Indexed_Comp),
864 New_Reference_To (Tag_Component (Comp_Type), Loc)),
867 Unchecked_Convert_To (RTE (RE_Tag),
869 Access_Disp_Table (Comp_Type), Loc)));
874 -- Adjust and Attach the component to the proper final list
875 -- which can be the controller of the outer record object or
876 -- the final list associated with the scope
878 if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
881 Ref => New_Copy_Tree (Indexed_Comp),
884 With_Attach => Make_Integer_Literal (Loc, 1)));
888 return Add_Loop_Actions (L);
895 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
899 -- Index_Base'(L) .. Index_Base'(H)
901 L_Iteration_Scheme : Node_Id;
902 -- L_J in Index_Base'(L) .. Index_Base'(H)
905 -- The statements to execute in the loop
907 S : constant List_Id := New_List;
908 -- List of statements
911 -- Copy of expression tree, used for checking purposes
914 -- If loop bounds define an empty range return the null statement
916 if Empty_Range (L, H) then
917 Append_To (S, Make_Null_Statement (Loc));
919 -- Ada0Y (AI-287): Nothing else need to be done in case of
920 -- default initialized component
922 if not Present (Expr) then
926 -- The expression must be type-checked even though no component
927 -- of the aggregate will have this value. This is done only for
928 -- actual components of the array, not for subaggregates. Do
929 -- the check on a copy, because the expression may be shared
930 -- among several choices, some of which might be non-null.
932 if Present (Etype (N))
933 and then Is_Array_Type (Etype (N))
934 and then No (Next_Index (Index))
936 Expander_Mode_Save_And_Set (False);
937 Tcopy := New_Copy_Tree (Expr);
938 Set_Parent (Tcopy, N);
939 Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
940 Expander_Mode_Restore;
946 -- If loop bounds are the same then generate an assignment
948 elsif Equal (L, H) then
949 return Gen_Assign (New_Copy_Tree (L), Expr);
951 -- If H - L <= 2 then generate a sequence of assignments
952 -- when we are processing the bottom most aggregate and it contains
953 -- scalar components.
955 elsif No (Next_Index (Index))
957 and then Local_Compile_Time_Known_Value (L)
958 and then Local_Compile_Time_Known_Value (H)
959 and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
962 Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
963 Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
965 if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then
966 Append_List_To (S, Gen_Assign (Add (2, To => L), Expr));
972 -- Otherwise construct the loop, starting with the loop index L_J
974 L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
976 -- Construct "L .. H"
981 Low_Bound => Make_Qualified_Expression
983 Subtype_Mark => Index_Base_Name,
985 High_Bound => Make_Qualified_Expression
987 Subtype_Mark => Index_Base_Name,
990 -- Construct "for L_J in Index_Base range L .. H"
992 L_Iteration_Scheme :=
993 Make_Iteration_Scheme
995 Loop_Parameter_Specification =>
996 Make_Loop_Parameter_Specification
998 Defining_Identifier => L_J,
999 Discrete_Subtype_Definition => L_Range));
1001 -- Construct the statements to execute in the loop body
1003 L_Body := Gen_Assign (New_Reference_To (L_J, Loc), Expr);
1005 -- Construct the final loop
1007 Append_To (S, Make_Implicit_Loop_Statement
1009 Identifier => Empty,
1010 Iteration_Scheme => L_Iteration_Scheme,
1011 Statements => L_Body));
1020 -- The code built is
1022 -- W_J : Index_Base := L;
1023 -- while W_J < H loop
1024 -- W_J := Index_Base'Succ (W);
1028 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is
1032 -- W_J : Base_Type := L;
1034 W_Iteration_Scheme : Node_Id;
1037 W_Index_Succ : Node_Id;
1038 -- Index_Base'Succ (J)
1040 W_Increment : Node_Id;
1041 -- W_J := Index_Base'Succ (W)
1043 W_Body : constant List_Id := New_List;
1044 -- The statements to execute in the loop
1046 S : constant List_Id := New_List;
1047 -- list of statement
1050 -- If loop bounds define an empty range or are equal return null
1052 if Empty_Range (L, H) or else Equal (L, H) then
1053 Append_To (S, Make_Null_Statement (Loc));
1057 -- Build the decl of W_J
1059 W_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
1061 Make_Object_Declaration
1063 Defining_Identifier => W_J,
1064 Object_Definition => Index_Base_Name,
1067 -- Theoretically we should do a New_Copy_Tree (L) here, but we know
1068 -- that in this particular case L is a fresh Expr generated by
1069 -- Add which we are the only ones to use.
1071 Append_To (S, W_Decl);
1073 -- Construct " while W_J < H"
1075 W_Iteration_Scheme :=
1076 Make_Iteration_Scheme
1078 Condition => Make_Op_Lt
1080 Left_Opnd => New_Reference_To (W_J, Loc),
1081 Right_Opnd => New_Copy_Tree (H)));
1083 -- Construct the statements to execute in the loop body
1086 Make_Attribute_Reference
1088 Prefix => Index_Base_Name,
1089 Attribute_Name => Name_Succ,
1090 Expressions => New_List (New_Reference_To (W_J, Loc)));
1093 Make_OK_Assignment_Statement
1095 Name => New_Reference_To (W_J, Loc),
1096 Expression => W_Index_Succ);
1098 Append_To (W_Body, W_Increment);
1099 Append_List_To (W_Body,
1100 Gen_Assign (New_Reference_To (W_J, Loc), Expr));
1102 -- Construct the final loop
1104 Append_To (S, Make_Implicit_Loop_Statement
1106 Identifier => Empty,
1107 Iteration_Scheme => W_Iteration_Scheme,
1108 Statements => W_Body));
1113 ---------------------
1114 -- Index_Base_Name --
1115 ---------------------
1117 function Index_Base_Name return Node_Id is
1119 return New_Reference_To (Index_Base, Sloc (N));
1120 end Index_Base_Name;
1122 ------------------------------------
1123 -- Local_Compile_Time_Known_Value --
1124 ------------------------------------
1126 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is
1128 return Compile_Time_Known_Value (E)
1130 (Nkind (E) = N_Attribute_Reference
1131 and then Attribute_Name (E) = Name_Val
1132 and then Compile_Time_Known_Value (First (Expressions (E))));
1133 end Local_Compile_Time_Known_Value;
1135 ----------------------
1136 -- Local_Expr_Value --
1137 ----------------------
1139 function Local_Expr_Value (E : Node_Id) return Uint is
1141 if Compile_Time_Known_Value (E) then
1142 return Expr_Value (E);
1144 return Expr_Value (First (Expressions (E)));
1146 end Local_Expr_Value;
1148 -- Build_Array_Aggr_Code Variables
1155 Others_Expr : Node_Id := Empty;
1156 Others_Mbox_Present : Boolean := False;
1158 Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
1159 Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
1160 -- The aggregate bounds of this specific sub-aggregate. Note that if
1161 -- the code generated by Build_Array_Aggr_Code is executed then these
1162 -- bounds are OK. Otherwise a Constraint_Error would have been raised.
1164 Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L);
1165 Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
1166 -- After Duplicate_Subexpr these are side-effect free.
1171 Nb_Choices : Nat := 0;
1172 Table : Case_Table_Type (1 .. Number_Of_Choices (N));
1173 -- Used to sort all the different choice values
1176 -- Number of elements in the positional aggregate
1178 New_Code : constant List_Id := New_List;
1180 -- Start of processing for Build_Array_Aggr_Code
1183 -- First before we start, a special case. if we have a bit packed
1184 -- array represented as a modular type, then clear the value to
1185 -- zero first, to ensure that unused bits are properly cleared.
1190 and then Is_Bit_Packed_Array (Typ)
1191 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ))
1193 Append_To (New_Code,
1194 Make_Assignment_Statement (Loc,
1195 Name => New_Copy_Tree (Into),
1197 Unchecked_Convert_To (Typ,
1198 Make_Integer_Literal (Loc, Uint_0))));
1202 -- STEP 1: Process component associations
1203 -- For those associations that may generate a loop, initialize
1204 -- Loop_Actions to collect inserted actions that may be crated.
1206 if No (Expressions (N)) then
1208 -- STEP 1 (a): Sort the discrete choices
1210 Assoc := First (Component_Associations (N));
1211 while Present (Assoc) loop
1212 Choice := First (Choices (Assoc));
1213 while Present (Choice) loop
1214 if Nkind (Choice) = N_Others_Choice then
1215 Set_Loop_Actions (Assoc, New_List);
1217 if Box_Present (Assoc) then
1218 Others_Mbox_Present := True;
1220 Others_Expr := Expression (Assoc);
1225 Get_Index_Bounds (Choice, Low, High);
1228 Set_Loop_Actions (Assoc, New_List);
1231 Nb_Choices := Nb_Choices + 1;
1232 if Box_Present (Assoc) then
1233 Table (Nb_Choices) := (Choice_Lo => Low,
1235 Choice_Node => Empty);
1237 Table (Nb_Choices) := (Choice_Lo => Low,
1239 Choice_Node => Expression (Assoc));
1247 -- If there is more than one set of choices these must be static
1248 -- and we can therefore sort them. Remember that Nb_Choices does not
1249 -- account for an others choice.
1251 if Nb_Choices > 1 then
1252 Sort_Case_Table (Table);
1255 -- STEP 1 (b): take care of the whole set of discrete choices.
1257 for J in 1 .. Nb_Choices loop
1258 Low := Table (J).Choice_Lo;
1259 High := Table (J).Choice_Hi;
1260 Expr := Table (J).Choice_Node;
1261 Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
1264 -- STEP 1 (c): generate the remaining loops to cover others choice
1265 -- We don't need to generate loops over empty gaps, but if there is
1266 -- a single empty range we must analyze the expression for semantics
1268 if Present (Others_Expr) or else Others_Mbox_Present then
1270 First : Boolean := True;
1273 for J in 0 .. Nb_Choices loop
1277 Low := Add (1, To => Table (J).Choice_Hi);
1280 if J = Nb_Choices then
1283 High := Add (-1, To => Table (J + 1).Choice_Lo);
1286 -- If this is an expansion within an init proc, make
1287 -- sure that discriminant references are replaced by
1288 -- the corresponding discriminal.
1290 if Inside_Init_Proc then
1291 if Is_Entity_Name (Low)
1292 and then Ekind (Entity (Low)) = E_Discriminant
1294 Set_Entity (Low, Discriminal (Entity (Low)));
1297 if Is_Entity_Name (High)
1298 and then Ekind (Entity (High)) = E_Discriminant
1300 Set_Entity (High, Discriminal (Entity (High)));
1305 or else not Empty_Range (Low, High)
1309 (Gen_Loop (Low, High, Others_Expr), To => New_Code);
1315 -- STEP 2: Process positional components
1318 -- STEP 2 (a): Generate the assignments for each positional element
1319 -- Note that here we have to use Aggr_L rather than Aggr_Low because
1320 -- Aggr_L is analyzed and Add wants an analyzed expression.
1322 Expr := First (Expressions (N));
1325 while Present (Expr) loop
1326 Nb_Elements := Nb_Elements + 1;
1327 Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr),
1332 -- STEP 2 (b): Generate final loop if an others choice is present
1333 -- Here Nb_Elements gives the offset of the last positional element.
1335 if Present (Component_Associations (N)) then
1336 Assoc := Last (Component_Associations (N));
1339 if Box_Present (Assoc) then
1340 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1345 Expr := Expression (Assoc);
1347 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1356 end Build_Array_Aggr_Code;
1358 ----------------------------
1359 -- Build_Record_Aggr_Code --
1360 ----------------------------
1362 function Build_Record_Aggr_Code
1366 Flist : Node_Id := Empty;
1367 Obj : Entity_Id := Empty;
1368 Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id
1370 Loc : constant Source_Ptr := Sloc (N);
1371 L : constant List_Id := New_List;
1372 Start_L : constant List_Id := New_List;
1373 N_Typ : constant Entity_Id := Etype (N);
1379 Comp_Type : Entity_Id;
1380 Selector : Entity_Id;
1381 Comp_Expr : Node_Id;
1384 Internal_Final_List : Node_Id;
1386 -- If this is an internal aggregate, the External_Final_List is an
1387 -- expression for the controller record of the enclosing type.
1388 -- If the current aggregate has several controlled components, this
1389 -- expression will appear in several calls to attach to the finali-
1390 -- zation list, and it must not be shared.
1392 External_Final_List : Node_Id;
1393 Ancestor_Is_Expression : Boolean := False;
1394 Ancestor_Is_Subtype_Mark : Boolean := False;
1396 Init_Typ : Entity_Id := Empty;
1399 function Get_Constraint_Association (T : Entity_Id) return Node_Id;
1400 -- Returns the first discriminant association in the constraint
1401 -- associated with T, if any, otherwise returns Empty.
1403 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
1404 -- Returns the value that the given discriminant of an ancestor
1405 -- type should receive (in the absence of a conflict with the
1406 -- value provided by an ancestor part of an extension aggregate).
1408 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id);
1409 -- Check that each of the discriminant values defined by the
1410 -- ancestor part of an extension aggregate match the corresponding
1411 -- values provided by either an association of the aggregate or
1412 -- by the constraint imposed by a parent type (RM95-4.3.2(8)).
1414 function Init_Controller
1419 Init_Pr : Boolean) return List_Id;
1420 -- returns the list of statements necessary to initialize the internal
1421 -- controller of the (possible) ancestor typ into target and attach
1422 -- it to finalization list F. Init_Pr conditions the call to the
1423 -- init proc since it may already be done due to ancestor initialization
1425 ---------------------------------
1426 -- Ancestor_Discriminant_Value --
1427 ---------------------------------
1429 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is
1431 Assoc_Elmt : Elmt_Id;
1432 Aggr_Comp : Entity_Id;
1433 Corresp_Disc : Entity_Id;
1434 Current_Typ : Entity_Id := Base_Type (Typ);
1435 Parent_Typ : Entity_Id;
1436 Parent_Disc : Entity_Id;
1437 Save_Assoc : Node_Id := Empty;
1440 -- First check any discriminant associations to see if
1441 -- any of them provide a value for the discriminant.
1443 if Present (Discriminant_Specifications (Parent (Current_Typ))) then
1444 Assoc := First (Component_Associations (N));
1445 while Present (Assoc) loop
1446 Aggr_Comp := Entity (First (Choices (Assoc)));
1448 if Ekind (Aggr_Comp) = E_Discriminant then
1449 Save_Assoc := Expression (Assoc);
1451 Corresp_Disc := Corresponding_Discriminant (Aggr_Comp);
1452 while Present (Corresp_Disc) loop
1453 -- If found a corresponding discriminant then return
1454 -- the value given in the aggregate. (Note: this is
1455 -- not correct in the presence of side effects. ???)
1457 if Disc = Corresp_Disc then
1458 return Duplicate_Subexpr (Expression (Assoc));
1462 Corresponding_Discriminant (Corresp_Disc);
1470 -- No match found in aggregate, so chain up parent types to find
1471 -- a constraint that defines the value of the discriminant.
1473 Parent_Typ := Etype (Current_Typ);
1474 while Current_Typ /= Parent_Typ loop
1475 if Has_Discriminants (Parent_Typ) then
1476 Parent_Disc := First_Discriminant (Parent_Typ);
1478 -- We either get the association from the subtype indication
1479 -- of the type definition itself, or from the discriminant
1480 -- constraint associated with the type entity (which is
1481 -- preferable, but it's not always present ???)
1483 if Is_Empty_Elmt_List (
1484 Discriminant_Constraint (Current_Typ))
1486 Assoc := Get_Constraint_Association (Current_Typ);
1487 Assoc_Elmt := No_Elmt;
1490 First_Elmt (Discriminant_Constraint (Current_Typ));
1491 Assoc := Node (Assoc_Elmt);
1494 -- Traverse the discriminants of the parent type looking
1495 -- for one that corresponds.
1497 while Present (Parent_Disc) and then Present (Assoc) loop
1498 Corresp_Disc := Parent_Disc;
1499 while Present (Corresp_Disc)
1500 and then Disc /= Corresp_Disc
1503 Corresponding_Discriminant (Corresp_Disc);
1506 if Disc = Corresp_Disc then
1507 if Nkind (Assoc) = N_Discriminant_Association then
1508 Assoc := Expression (Assoc);
1511 -- If the located association directly denotes
1512 -- a discriminant, then use the value of a saved
1513 -- association of the aggregate. This is a kludge
1514 -- to handle certain cases involving multiple
1515 -- discriminants mapped to a single discriminant
1516 -- of a descendant. It's not clear how to locate the
1517 -- appropriate discriminant value for such cases. ???
1519 if Is_Entity_Name (Assoc)
1520 and then Ekind (Entity (Assoc)) = E_Discriminant
1522 Assoc := Save_Assoc;
1525 return Duplicate_Subexpr (Assoc);
1528 Next_Discriminant (Parent_Disc);
1530 if No (Assoc_Elmt) then
1533 Next_Elmt (Assoc_Elmt);
1534 if Present (Assoc_Elmt) then
1535 Assoc := Node (Assoc_Elmt);
1543 Current_Typ := Parent_Typ;
1544 Parent_Typ := Etype (Current_Typ);
1547 -- In some cases there's no ancestor value to locate (such as
1548 -- when an ancestor part given by an expression defines the
1549 -- discriminant value).
1552 end Ancestor_Discriminant_Value;
1554 ----------------------------------
1555 -- Check_Ancestor_Discriminants --
1556 ----------------------------------
1558 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is
1559 Discr : Entity_Id := First_Discriminant (Base_Type (Anc_Typ));
1560 Disc_Value : Node_Id;
1564 while Present (Discr) loop
1565 Disc_Value := Ancestor_Discriminant_Value (Discr);
1567 if Present (Disc_Value) then
1568 Cond := Make_Op_Ne (Loc,
1570 Make_Selected_Component (Loc,
1571 Prefix => New_Copy_Tree (Target),
1572 Selector_Name => New_Occurrence_Of (Discr, Loc)),
1573 Right_Opnd => Disc_Value);
1576 Make_Raise_Constraint_Error (Loc,
1578 Reason => CE_Discriminant_Check_Failed));
1581 Next_Discriminant (Discr);
1583 end Check_Ancestor_Discriminants;
1585 --------------------------------
1586 -- Get_Constraint_Association --
1587 --------------------------------
1589 function Get_Constraint_Association (T : Entity_Id) return Node_Id is
1590 Typ_Def : constant Node_Id := Type_Definition (Parent (T));
1591 Indic : constant Node_Id := Subtype_Indication (Typ_Def);
1594 -- ??? Also need to cover case of a type mark denoting a subtype
1597 if Nkind (Indic) = N_Subtype_Indication
1598 and then Present (Constraint (Indic))
1600 return First (Constraints (Constraint (Indic)));
1604 end Get_Constraint_Association;
1606 ---------------------
1607 -- Init_controller --
1608 ---------------------
1610 function Init_Controller
1615 Init_Pr : Boolean) return List_Id
1617 L : constant List_Id := New_List;
1622 -- init-proc (target._controller);
1623 -- initialize (target._controller);
1624 -- Attach_to_Final_List (target._controller, F);
1627 Make_Selected_Component (Loc,
1628 Prefix => Convert_To (Typ, New_Copy_Tree (Target)),
1629 Selector_Name => Make_Identifier (Loc, Name_uController));
1630 Set_Assignment_OK (Ref);
1632 -- Ada0Y (AI-287): Give support to default initialization of limited
1633 -- types and components
1635 if (Nkind (Target) = N_Identifier
1636 and then Present (Etype (Target))
1637 and then Is_Limited_Type (Etype (Target)))
1638 or else (Nkind (Target) = N_Selected_Component
1639 and then Present (Etype (Selector_Name (Target)))
1640 and then Is_Limited_Type (Etype (Selector_Name (Target))))
1641 or else (Nkind (Target) = N_Unchecked_Type_Conversion
1642 and then Present (Etype (Target))
1643 and then Is_Limited_Type (Etype (Target)))
1644 or else (Nkind (Target) = N_Unchecked_Expression
1645 and then Nkind (Expression (Target)) = N_Indexed_Component
1646 and then Present (Etype (Prefix (Expression (Target))))
1647 and then Is_Limited_Type
1648 (Etype (Prefix (Expression (Target)))))
1653 Build_Initialization_Call (Loc,
1655 Typ => RTE (RE_Limited_Record_Controller),
1656 In_Init_Proc => Within_Init_Proc));
1660 Make_Procedure_Call_Statement (Loc,
1663 (Find_Prim_Op (RTE (RE_Limited_Record_Controller),
1664 Name_Initialize), Loc),
1665 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
1670 Build_Initialization_Call (Loc,
1672 Typ => RTE (RE_Record_Controller),
1673 In_Init_Proc => Within_Init_Proc));
1677 Make_Procedure_Call_Statement (Loc,
1679 New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
1680 Name_Initialize), Loc),
1681 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
1687 Obj_Ref => New_Copy_Tree (Ref),
1689 With_Attach => Attach));
1691 end Init_Controller;
1693 -- Start of processing for Build_Record_Aggr_Code
1696 -- Deal with the ancestor part of extension aggregates
1697 -- or with the discriminants of the root type
1699 if Nkind (N) = N_Extension_Aggregate then
1701 A : constant Node_Id := Ancestor_Part (N);
1704 -- If the ancestor part is a subtype mark "T", we generate
1706 -- init-proc (T(tmp)); if T is constrained and
1707 -- init-proc (S(tmp)); where S applies an appropriate
1708 -- constraint if T is unconstrained
1710 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
1711 Ancestor_Is_Subtype_Mark := True;
1713 if Is_Constrained (Entity (A)) then
1714 Init_Typ := Entity (A);
1716 -- For an ancestor part given by an unconstrained type
1717 -- mark, create a subtype constrained by appropriate
1718 -- corresponding discriminant values coming from either
1719 -- associations of the aggregate or a constraint on
1720 -- a parent type. The subtype will be used to generate
1721 -- the correct default value for the ancestor part.
1723 elsif Has_Discriminants (Entity (A)) then
1725 Anc_Typ : constant Entity_Id := Entity (A);
1726 Anc_Constr : constant List_Id := New_List;
1727 Discrim : Entity_Id;
1728 Disc_Value : Node_Id;
1729 New_Indic : Node_Id;
1730 Subt_Decl : Node_Id;
1733 Discrim := First_Discriminant (Anc_Typ);
1734 while Present (Discrim) loop
1735 Disc_Value := Ancestor_Discriminant_Value (Discrim);
1736 Append_To (Anc_Constr, Disc_Value);
1737 Next_Discriminant (Discrim);
1741 Make_Subtype_Indication (Loc,
1742 Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc),
1744 Make_Index_Or_Discriminant_Constraint (Loc,
1745 Constraints => Anc_Constr));
1747 Init_Typ := Create_Itype (Ekind (Anc_Typ), N);
1750 Make_Subtype_Declaration (Loc,
1751 Defining_Identifier => Init_Typ,
1752 Subtype_Indication => New_Indic);
1754 -- Itypes must be analyzed with checks off
1755 -- Declaration must have a parent for proper
1756 -- handling of subsidiary actions.
1758 Set_Parent (Subt_Decl, N);
1759 Analyze (Subt_Decl, Suppress => All_Checks);
1763 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
1764 Set_Assignment_OK (Ref);
1766 if Has_Default_Init_Comps (N)
1767 or else Has_Task (Base_Type (Init_Typ))
1769 Append_List_To (Start_L,
1770 Build_Initialization_Call (Loc,
1773 In_Init_Proc => Within_Init_Proc,
1774 With_Default_Init => True));
1776 Append_List_To (Start_L,
1777 Build_Initialization_Call (Loc,
1780 In_Init_Proc => Within_Init_Proc));
1783 if Is_Constrained (Entity (A))
1784 and then Has_Discriminants (Entity (A))
1786 Check_Ancestor_Discriminants (Entity (A));
1789 -- Ada0Y (AI-287): If the ancestor part is a limited type, a
1790 -- recursive call expands the ancestor.
1792 elsif Is_Limited_Type (Etype (A)) then
1793 Ancestor_Is_Expression := True;
1795 Append_List_To (Start_L,
1796 Build_Record_Aggr_Code (
1797 N => Expression (A),
1798 Typ => Etype (Expression (A)),
1802 Is_Limited_Ancestor_Expansion => True));
1804 -- If the ancestor part is an expression "E", we generate
1808 Ancestor_Is_Expression := True;
1809 Init_Typ := Etype (A);
1811 -- Assign the tag before doing the assignment to make sure
1812 -- that the dispatching call in the subsequent deep_adjust
1813 -- works properly (unless Java_VM, where tags are implicit).
1817 Make_OK_Assignment_Statement (Loc,
1819 Make_Selected_Component (Loc,
1820 Prefix => New_Copy_Tree (Target),
1821 Selector_Name => New_Reference_To (
1822 Tag_Component (Base_Type (Typ)), Loc)),
1825 Unchecked_Convert_To (RTE (RE_Tag),
1827 Access_Disp_Table (Base_Type (Typ)), Loc)));
1829 Set_Assignment_OK (Name (Instr));
1830 Append_To (L, Instr);
1833 -- If the ancestor part is an aggregate, force its full
1834 -- expansion, which was delayed.
1836 if Nkind (A) = N_Qualified_Expression
1837 and then (Nkind (Expression (A)) = N_Aggregate
1839 Nkind (Expression (A)) = N_Extension_Aggregate)
1841 Set_Analyzed (A, False);
1842 Set_Analyzed (Expression (A), False);
1845 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
1846 Set_Assignment_OK (Ref);
1848 Make_Unsuppress_Block (Loc,
1849 Name_Discriminant_Check,
1851 Make_OK_Assignment_Statement (Loc,
1853 Expression => A))));
1855 if Has_Discriminants (Init_Typ) then
1856 Check_Ancestor_Discriminants (Init_Typ);
1861 -- Normal case (not an extension aggregate)
1864 -- Generate the discriminant expressions, component by component.
1865 -- If the base type is an unchecked union, the discriminants are
1866 -- unknown to the back-end and absent from a value of the type, so
1867 -- assignments for them are not emitted.
1869 if Has_Discriminants (Typ)
1870 and then not Is_Unchecked_Union (Base_Type (Typ))
1872 -- ??? The discriminants of the object not inherited in the type
1873 -- of the object should be initialized here
1877 -- Generate discriminant init values
1880 Discriminant : Entity_Id;
1881 Discriminant_Value : Node_Id;
1884 Discriminant := First_Stored_Discriminant (Typ);
1886 while Present (Discriminant) loop
1889 Make_Selected_Component (Loc,
1890 Prefix => New_Copy_Tree (Target),
1891 Selector_Name => New_Occurrence_Of (Discriminant, Loc));
1893 Discriminant_Value :=
1894 Get_Discriminant_Value (
1897 Discriminant_Constraint (N_Typ));
1900 Make_OK_Assignment_Statement (Loc,
1902 Expression => New_Copy_Tree (Discriminant_Value));
1904 Set_No_Ctrl_Actions (Instr);
1905 Append_To (L, Instr);
1907 Next_Stored_Discriminant (Discriminant);
1913 -- Generate the assignments, component by component
1915 -- tmp.comp1 := Expr1_From_Aggr;
1916 -- tmp.comp2 := Expr2_From_Aggr;
1919 Comp := First (Component_Associations (N));
1920 while Present (Comp) loop
1921 Selector := Entity (First (Choices (Comp)));
1923 -- Ada0Y (AI-287): Default initialization of a limited component
1925 if Box_Present (Comp)
1926 and then Is_Limited_Type (Etype (Selector))
1928 -- Ada0Y (AI-287): If the component type has tasks then generate
1929 -- the activation chain and master entities (except in case of an
1930 -- allocator because in that case these entities are generated
1931 -- by Build_Task_Allocate_Block_With_Init_Stmts)
1934 Ctype : constant Entity_Id := Etype (Selector);
1935 Inside_Allocator : Boolean := False;
1936 P : Node_Id := Parent (N);
1939 if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
1940 while Present (P) loop
1941 if Nkind (P) = N_Allocator then
1942 Inside_Allocator := True;
1949 if not Inside_Init_Proc and not Inside_Allocator then
1950 Build_Activation_Chain_Entity (N);
1952 if not Has_Master_Entity (Current_Scope) then
1953 Build_Master_Entity (Etype (N));
1960 Build_Initialization_Call (Loc,
1961 Id_Ref => Make_Selected_Component (Loc,
1962 Prefix => New_Copy_Tree (Target),
1963 Selector_Name => New_Occurrence_Of (Selector,
1965 Typ => Etype (Selector),
1966 With_Default_Init => True));
1973 if Ekind (Selector) /= E_Discriminant
1974 or else Nkind (N) = N_Extension_Aggregate
1976 Comp_Type := Etype (Selector);
1978 Make_Selected_Component (Loc,
1979 Prefix => New_Copy_Tree (Target),
1980 Selector_Name => New_Occurrence_Of (Selector, Loc));
1982 if Nkind (Expression (Comp)) = N_Qualified_Expression then
1983 Expr_Q := Expression (Expression (Comp));
1985 Expr_Q := Expression (Comp);
1988 -- The controller is the one of the parent type defining
1989 -- the component (in case of inherited components).
1991 if Controlled_Type (Comp_Type) then
1992 Internal_Final_List :=
1993 Make_Selected_Component (Loc,
1994 Prefix => Convert_To (
1995 Scope (Original_Record_Component (Selector)),
1996 New_Copy_Tree (Target)),
1998 Make_Identifier (Loc, Name_uController));
2000 Internal_Final_List :=
2001 Make_Selected_Component (Loc,
2002 Prefix => Internal_Final_List,
2003 Selector_Name => Make_Identifier (Loc, Name_F));
2005 -- The internal final list can be part of a constant object
2007 Set_Assignment_OK (Internal_Final_List);
2010 Internal_Final_List := Empty;
2015 if Is_Delayed_Aggregate (Expr_Q) then
2017 Late_Expansion (Expr_Q, Comp_Type, Comp_Expr,
2018 Internal_Final_List));
2022 Make_OK_Assignment_Statement (Loc,
2024 Expression => Expression (Comp));
2026 Set_No_Ctrl_Actions (Instr);
2027 Append_To (L, Instr);
2029 -- Adjust the tag if tagged (because of possible view
2030 -- conversions), unless compiling for the Java VM
2031 -- where tags are implicit.
2033 -- tmp.comp._tag := comp_typ'tag;
2035 if Is_Tagged_Type (Comp_Type) and then not Java_VM then
2037 Make_OK_Assignment_Statement (Loc,
2039 Make_Selected_Component (Loc,
2040 Prefix => New_Copy_Tree (Comp_Expr),
2042 New_Reference_To (Tag_Component (Comp_Type), Loc)),
2045 Unchecked_Convert_To (RTE (RE_Tag),
2047 Access_Disp_Table (Comp_Type), Loc)));
2049 Append_To (L, Instr);
2052 -- Adjust and Attach the component to the proper controller
2053 -- Adjust (tmp.comp);
2054 -- Attach_To_Final_List (tmp.comp,
2055 -- comp_typ (tmp)._record_controller.f)
2057 if Controlled_Type (Comp_Type) then
2060 Ref => New_Copy_Tree (Comp_Expr),
2062 Flist_Ref => Internal_Final_List,
2063 With_Attach => Make_Integer_Literal (Loc, 1)));
2069 elsif Ekind (Selector) = E_Discriminant
2070 and then Nkind (N) /= N_Extension_Aggregate
2071 and then Nkind (Parent (N)) = N_Component_Association
2072 and then Is_Constrained (Typ)
2074 -- We must check that the discriminant value imposed by the
2075 -- context is the same as the value given in the subaggregate,
2076 -- because after the expansion into assignments there is no
2077 -- record on which to perform a regular discriminant check.
2084 D_Val := First_Elmt (Discriminant_Constraint (Typ));
2085 Disc := First_Discriminant (Typ);
2087 while Chars (Disc) /= Chars (Selector) loop
2088 Next_Discriminant (Disc);
2092 pragma Assert (Present (D_Val));
2095 Make_Raise_Constraint_Error (Loc,
2098 Left_Opnd => New_Copy_Tree (Node (D_Val)),
2099 Right_Opnd => Expression (Comp)),
2100 Reason => CE_Discriminant_Check_Failed));
2109 -- If the type is tagged, the tag needs to be initialized (unless
2110 -- compiling for the Java VM where tags are implicit). It is done
2111 -- late in the initialization process because in some cases, we call
2112 -- the init proc of an ancestor which will not leave out the right tag
2114 if Ancestor_Is_Expression then
2117 elsif Is_Tagged_Type (Typ) and then not Java_VM then
2119 Make_OK_Assignment_Statement (Loc,
2121 Make_Selected_Component (Loc,
2122 Prefix => New_Copy_Tree (Target),
2124 New_Reference_To (Tag_Component (Base_Type (Typ)), Loc)),
2127 Unchecked_Convert_To (RTE (RE_Tag),
2128 New_Reference_To (Access_Disp_Table (Base_Type (Typ)), Loc)));
2130 Append_To (L, Instr);
2133 -- Now deal with the various controlled type data structure
2137 and then Finalize_Storage_Only (Typ)
2138 and then (Is_Library_Level_Entity (Obj)
2139 or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
2142 Attach := Make_Integer_Literal (Loc, 0);
2144 elsif Nkind (Parent (N)) = N_Qualified_Expression
2145 and then Nkind (Parent (Parent (N))) = N_Allocator
2147 Attach := Make_Integer_Literal (Loc, 2);
2150 Attach := Make_Integer_Literal (Loc, 1);
2153 -- Determine the external finalization list. It is either the
2154 -- finalization list of the outer-scope or the one coming from
2155 -- an outer aggregate. When the target is not a temporary, the
2156 -- proper scope is the scope of the target rather than the
2157 -- potentially transient current scope.
2159 if Controlled_Type (Typ) then
2160 if Present (Flist) then
2161 External_Final_List := New_Copy_Tree (Flist);
2163 elsif Is_Entity_Name (Target)
2164 and then Present (Scope (Entity (Target)))
2166 External_Final_List := Find_Final_List (Scope (Entity (Target)));
2169 External_Final_List := Find_Final_List (Current_Scope);
2173 External_Final_List := Empty;
2176 -- Initialize and attach the outer object in the is_controlled case
2178 if Is_Controlled (Typ) then
2179 if Ancestor_Is_Subtype_Mark then
2180 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2181 Set_Assignment_OK (Ref);
2183 Make_Procedure_Call_Statement (Loc,
2184 Name => New_Reference_To (
2185 Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
2186 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
2189 if not Has_Controlled_Component (Typ) then
2190 Ref := New_Copy_Tree (Target);
2191 Set_Assignment_OK (Ref);
2195 Flist_Ref => New_Copy_Tree (External_Final_List),
2196 With_Attach => Attach));
2200 -- In the Has_Controlled component case, all the intermediate
2201 -- controllers must be initialized
2203 if Has_Controlled_Component (Typ)
2204 and not Is_Limited_Ancestor_Expansion
2207 Inner_Typ : Entity_Id;
2208 Outer_Typ : Entity_Id;
2213 Outer_Typ := Base_Type (Typ);
2215 -- Find outer type with a controller
2217 while Outer_Typ /= Init_Typ
2218 and then not Has_New_Controlled_Component (Outer_Typ)
2220 Outer_Typ := Etype (Outer_Typ);
2223 -- Attach it to the outer record controller to the
2224 -- external final list
2226 if Outer_Typ = Init_Typ then
2227 Append_List_To (Start_L,
2231 F => External_Final_List,
2233 Init_Pr => Ancestor_Is_Expression));
2236 Inner_Typ := Init_Typ;
2239 Append_List_To (Start_L,
2243 F => External_Final_List,
2247 Inner_Typ := Etype (Outer_Typ);
2249 not Is_Tagged_Type (Typ) or else Inner_Typ = Outer_Typ;
2252 -- The outer object has to be attached as well
2254 if Is_Controlled (Typ) then
2255 Ref := New_Copy_Tree (Target);
2256 Set_Assignment_OK (Ref);
2260 Flist_Ref => New_Copy_Tree (External_Final_List),
2261 With_Attach => New_Copy_Tree (Attach)));
2264 -- Initialize the internal controllers for tagged types with
2265 -- more than one controller.
2267 while not At_Root and then Inner_Typ /= Init_Typ loop
2268 if Has_New_Controlled_Component (Inner_Typ) then
2270 Make_Selected_Component (Loc,
2271 Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
2273 Make_Identifier (Loc, Name_uController));
2275 Make_Selected_Component (Loc,
2277 Selector_Name => Make_Identifier (Loc, Name_F));
2279 Append_List_To (Start_L,
2284 Attach => Make_Integer_Literal (Loc, 1),
2286 Outer_Typ := Inner_Typ;
2291 At_Root := Inner_Typ = Etype (Inner_Typ);
2292 Inner_Typ := Etype (Inner_Typ);
2295 -- If not done yet attach the controller of the ancestor part
2297 if Outer_Typ /= Init_Typ
2298 and then Inner_Typ = Init_Typ
2299 and then Has_Controlled_Component (Init_Typ)
2302 Make_Selected_Component (Loc,
2303 Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
2304 Selector_Name => Make_Identifier (Loc, Name_uController));
2306 Make_Selected_Component (Loc,
2308 Selector_Name => Make_Identifier (Loc, Name_F));
2310 Attach := Make_Integer_Literal (Loc, 1);
2311 Append_List_To (Start_L,
2317 Init_Pr => Ancestor_Is_Expression));
2322 Append_List_To (Start_L, L);
2324 end Build_Record_Aggr_Code;
2326 -------------------------------
2327 -- Convert_Aggr_In_Allocator --
2328 -------------------------------
2330 procedure Convert_Aggr_In_Allocator (Decl, Aggr : Node_Id) is
2331 Loc : constant Source_Ptr := Sloc (Aggr);
2332 Typ : constant Entity_Id := Etype (Aggr);
2333 Temp : constant Entity_Id := Defining_Identifier (Decl);
2335 Occ : constant Node_Id :=
2336 Unchecked_Convert_To (Typ,
2337 Make_Explicit_Dereference (Loc,
2338 New_Reference_To (Temp, Loc)));
2340 Access_Type : constant Entity_Id := Etype (Temp);
2343 if Has_Default_Init_Comps (Aggr) then
2345 L : constant List_Id := New_List;
2346 Init_Stmts : List_Id;
2349 Init_Stmts := Late_Expansion (Aggr, Typ, Occ,
2350 Find_Final_List (Access_Type),
2351 Associated_Final_Chain (Base_Type (Access_Type)));
2353 Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
2354 Insert_Actions_After (Decl, L);
2358 Insert_Actions_After (Decl,
2359 Late_Expansion (Aggr, Typ, Occ,
2360 Find_Final_List (Access_Type),
2361 Associated_Final_Chain (Base_Type (Access_Type))));
2363 end Convert_Aggr_In_Allocator;
2365 --------------------------------
2366 -- Convert_Aggr_In_Assignment --
2367 --------------------------------
2369 procedure Convert_Aggr_In_Assignment (N : Node_Id) is
2370 Aggr : Node_Id := Expression (N);
2371 Typ : constant Entity_Id := Etype (Aggr);
2372 Occ : constant Node_Id := New_Copy_Tree (Name (N));
2375 if Nkind (Aggr) = N_Qualified_Expression then
2376 Aggr := Expression (Aggr);
2379 Insert_Actions_After (N,
2380 Late_Expansion (Aggr, Typ, Occ,
2381 Find_Final_List (Typ, New_Copy_Tree (Occ))));
2382 end Convert_Aggr_In_Assignment;
2384 ---------------------------------
2385 -- Convert_Aggr_In_Object_Decl --
2386 ---------------------------------
2388 procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is
2389 Obj : constant Entity_Id := Defining_Identifier (N);
2390 Aggr : Node_Id := Expression (N);
2391 Loc : constant Source_Ptr := Sloc (Aggr);
2392 Typ : constant Entity_Id := Etype (Aggr);
2393 Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
2395 function Discriminants_Ok return Boolean;
2396 -- If the object type is constrained, the discriminants in the
2397 -- aggregate must be checked against the discriminants of the subtype.
2398 -- This cannot be done using Apply_Discriminant_Checks because after
2399 -- expansion there is no aggregate left to check.
2401 ----------------------
2402 -- Discriminants_Ok --
2403 ----------------------
2405 function Discriminants_Ok return Boolean is
2406 Cond : Node_Id := Empty;
2415 D := First_Discriminant (Typ);
2416 Disc1 := First_Elmt (Discriminant_Constraint (Typ));
2417 Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj)));
2419 while Present (Disc1) and then Present (Disc2) loop
2420 Val1 := Node (Disc1);
2421 Val2 := Node (Disc2);
2423 if not Is_OK_Static_Expression (Val1)
2424 or else not Is_OK_Static_Expression (Val2)
2426 Check := Make_Op_Ne (Loc,
2427 Left_Opnd => Duplicate_Subexpr (Val1),
2428 Right_Opnd => Duplicate_Subexpr (Val2));
2434 Cond := Make_Or_Else (Loc,
2436 Right_Opnd => Check);
2439 elsif Expr_Value (Val1) /= Expr_Value (Val2) then
2440 Apply_Compile_Time_Constraint_Error (Aggr,
2441 Msg => "incorrect value for discriminant&?",
2442 Reason => CE_Discriminant_Check_Failed,
2447 Next_Discriminant (D);
2452 -- If any discriminant constraint is non-static, emit a check.
2454 if Present (Cond) then
2456 Make_Raise_Constraint_Error (Loc,
2458 Reason => CE_Discriminant_Check_Failed));
2462 end Discriminants_Ok;
2464 -- Start of processing for Convert_Aggr_In_Object_Decl
2467 Set_Assignment_OK (Occ);
2469 if Nkind (Aggr) = N_Qualified_Expression then
2470 Aggr := Expression (Aggr);
2473 if Has_Discriminants (Typ)
2474 and then Typ /= Etype (Obj)
2475 and then Is_Constrained (Etype (Obj))
2476 and then not Discriminants_Ok
2481 Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj));
2482 Set_No_Initialization (N);
2483 Initialize_Discriminants (N, Typ);
2484 end Convert_Aggr_In_Object_Decl;
2486 ----------------------------
2487 -- Convert_To_Assignments --
2488 ----------------------------
2490 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
2491 Loc : constant Source_Ptr := Sloc (N);
2495 Target_Expr : Node_Id;
2496 Parent_Kind : Node_Kind;
2497 Unc_Decl : Boolean := False;
2498 Parent_Node : Node_Id;
2501 Parent_Node := Parent (N);
2502 Parent_Kind := Nkind (Parent_Node);
2504 if Parent_Kind = N_Qualified_Expression then
2506 -- Check if we are in a unconstrained declaration because in this
2507 -- case the current delayed expansion mechanism doesn't work when
2508 -- the declared object size depend on the initializing expr.
2511 Parent_Node := Parent (Parent_Node);
2512 Parent_Kind := Nkind (Parent_Node);
2514 if Parent_Kind = N_Object_Declaration then
2516 not Is_Entity_Name (Object_Definition (Parent_Node))
2517 or else Has_Discriminants
2518 (Entity (Object_Definition (Parent_Node)))
2519 or else Is_Class_Wide_Type
2520 (Entity (Object_Definition (Parent_Node)));
2525 -- Just set the Delay flag in the following cases where the
2526 -- transformation will be done top down from above
2528 -- - internal aggregate (transformed when expanding the parent)
2529 -- - allocators (see Convert_Aggr_In_Allocator)
2530 -- - object decl (see Convert_Aggr_In_Object_Decl)
2531 -- - safe assignments (see Convert_Aggr_Assignments)
2532 -- so far only the assignments in the init procs are taken
2535 if Parent_Kind = N_Aggregate
2536 or else Parent_Kind = N_Extension_Aggregate
2537 or else Parent_Kind = N_Component_Association
2538 or else Parent_Kind = N_Allocator
2539 or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
2540 or else (Parent_Kind = N_Assignment_Statement
2541 and then Inside_Init_Proc)
2543 Set_Expansion_Delayed (N);
2547 if Requires_Transient_Scope (Typ) then
2548 Establish_Transient_Scope (N, Sec_Stack =>
2549 Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
2552 -- Create the temporary
2554 Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
2557 Make_Object_Declaration (Loc,
2558 Defining_Identifier => Temp,
2559 Object_Definition => New_Occurrence_Of (Typ, Loc));
2561 Set_No_Initialization (Instr);
2562 Insert_Action (N, Instr);
2563 Initialize_Discriminants (Instr, Typ);
2564 Target_Expr := New_Occurrence_Of (Temp, Loc);
2566 Insert_Actions (N, Build_Record_Aggr_Code (N, Typ, Target_Expr));
2567 Rewrite (N, New_Occurrence_Of (Temp, Loc));
2568 Analyze_And_Resolve (N, Typ);
2569 end Convert_To_Assignments;
2571 ---------------------------
2572 -- Convert_To_Positional --
2573 ---------------------------
2575 procedure Convert_To_Positional
2577 Max_Others_Replicate : Nat := 5;
2578 Handle_Bit_Packed : Boolean := False)
2580 Typ : constant Entity_Id := Etype (N);
2585 Ixb : Node_Id) return Boolean;
2586 -- Convert the aggregate into a purely positional form if possible.
2588 function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
2589 -- Non trivial for multidimensional aggregate.
2598 Ixb : Node_Id) return Boolean
2600 Loc : constant Source_Ptr := Sloc (N);
2601 Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb));
2602 Lo : constant Node_Id := Type_Low_Bound (Etype (Ix));
2603 Hi : constant Node_Id := Type_High_Bound (Etype (Ix));
2607 -- The following constant determines the maximum size of an
2608 -- aggregate produced by converting named to positional
2609 -- notation (e.g. from others clauses). This avoids running
2610 -- away with attempts to convert huge aggregates.
2612 -- The normal limit is 5000, but we increase this limit to
2613 -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code)
2614 -- or Restrictions (No_Implicit_Loops) is specified, since in
2615 -- either case, we are at risk of declaring the program illegal
2616 -- because of this limit.
2618 Max_Aggr_Size : constant Nat :=
2619 5000 + (2 ** 24 - 5000) * Boolean'Pos
2620 (Restrictions (No_Elaboration_Code)
2622 Restrictions (No_Implicit_Loops));
2625 if Nkind (Original_Node (N)) = N_String_Literal then
2629 -- Bounds need to be known at compile time
2631 if not Compile_Time_Known_Value (Lo)
2632 or else not Compile_Time_Known_Value (Hi)
2637 -- Get bounds and check reasonable size (positive, not too large)
2638 -- Also only handle bounds starting at the base type low bound
2639 -- for now since the compiler isn't able to handle different low
2640 -- bounds yet. Case such as new String'(3..5 => ' ') will get
2641 -- the wrong bounds, though it seems that the aggregate should
2642 -- retain the bounds set on its Etype (see C64103E and CC1311B).
2644 Lov := Expr_Value (Lo);
2645 Hiv := Expr_Value (Hi);
2648 or else (Hiv - Lov > Max_Aggr_Size)
2649 or else not Compile_Time_Known_Value (Blo)
2650 or else (Lov /= Expr_Value (Blo))
2655 -- Bounds must be in integer range (for array Vals below)
2657 if not UI_Is_In_Int_Range (Lov)
2659 not UI_Is_In_Int_Range (Hiv)
2664 -- Determine if set of alternatives is suitable for conversion
2665 -- and build an array containing the values in sequence.
2668 Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv))
2669 of Node_Id := (others => Empty);
2670 -- The values in the aggregate sorted appropriately
2673 -- Same data as Vals in list form
2676 -- Used to validate Max_Others_Replicate limit
2679 Num : Int := UI_To_Int (Lov);
2684 if Present (Expressions (N)) then
2685 Elmt := First (Expressions (N));
2687 while Present (Elmt) loop
2688 if Nkind (Elmt) = N_Aggregate
2689 and then Present (Next_Index (Ix))
2691 not Flatten (Elmt, Next_Index (Ix), Next_Index (Ixb))
2696 Vals (Num) := Relocate_Node (Elmt);
2703 if No (Component_Associations (N)) then
2707 Elmt := First (Component_Associations (N));
2709 if Nkind (Expression (Elmt)) = N_Aggregate then
2710 if Present (Next_Index (Ix))
2713 (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb))
2719 Component_Loop : while Present (Elmt) loop
2720 Choice := First (Choices (Elmt));
2721 Choice_Loop : while Present (Choice) loop
2723 -- If we have an others choice, fill in the missing elements
2724 -- subject to the limit established by Max_Others_Replicate.
2726 if Nkind (Choice) = N_Others_Choice then
2729 for J in Vals'Range loop
2730 if No (Vals (J)) then
2731 Vals (J) := New_Copy_Tree (Expression (Elmt));
2732 Rep_Count := Rep_Count + 1;
2734 -- Check for maximum others replication. Note that
2735 -- we skip this test if either of the restrictions
2736 -- No_Elaboration_Code or No_Implicit_Loops is
2737 -- active, or if this is a preelaborable unit.
2740 P : constant Entity_Id :=
2741 Cunit_Entity (Current_Sem_Unit);
2744 if Restrictions (No_Elaboration_Code)
2745 or else Restrictions (No_Implicit_Loops)
2746 or else Is_Preelaborated (P)
2747 or else (Ekind (P) = E_Package_Body
2749 Is_Preelaborated (Spec_Entity (P)))
2752 elsif Rep_Count > Max_Others_Replicate then
2759 exit Component_Loop;
2761 -- Case of a subtype mark
2763 elsif Nkind (Choice) = N_Identifier
2764 and then Is_Type (Entity (Choice))
2766 Lo := Type_Low_Bound (Etype (Choice));
2767 Hi := Type_High_Bound (Etype (Choice));
2769 -- Case of subtype indication
2771 elsif Nkind (Choice) = N_Subtype_Indication then
2772 Lo := Low_Bound (Range_Expression (Constraint (Choice)));
2773 Hi := High_Bound (Range_Expression (Constraint (Choice)));
2777 elsif Nkind (Choice) = N_Range then
2778 Lo := Low_Bound (Choice);
2779 Hi := High_Bound (Choice);
2781 -- Normal subexpression case
2783 else pragma Assert (Nkind (Choice) in N_Subexpr);
2784 if not Compile_Time_Known_Value (Choice) then
2788 Vals (UI_To_Int (Expr_Value (Choice))) :=
2789 New_Copy_Tree (Expression (Elmt));
2794 -- Range cases merge with Lo,Hi said
2796 if not Compile_Time_Known_Value (Lo)
2798 not Compile_Time_Known_Value (Hi)
2802 for J in UI_To_Int (Expr_Value (Lo)) ..
2803 UI_To_Int (Expr_Value (Hi))
2805 Vals (J) := New_Copy_Tree (Expression (Elmt));
2811 end loop Choice_Loop;
2814 end loop Component_Loop;
2816 -- If we get here the conversion is possible
2819 for J in Vals'Range loop
2820 Append (Vals (J), Vlist);
2823 Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist));
2824 Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N)));
2833 function Is_Flat (N : Node_Id; Dims : Int) return Boolean is
2840 elsif Nkind (N) = N_Aggregate then
2841 if Present (Component_Associations (N)) then
2845 Elmt := First (Expressions (N));
2847 while Present (Elmt) loop
2848 if not Is_Flat (Elmt, Dims - 1) then
2862 -- Start of processing for Convert_To_Positional
2865 -- Ada0Y (AI-287): Do not convert in case of default initialized
2866 -- components because in this case will need to call the corresponding
2869 if Has_Default_Init_Comps (N) then
2873 if Is_Flat (N, Number_Dimensions (Typ)) then
2877 if Is_Bit_Packed_Array (Typ)
2878 and then not Handle_Bit_Packed
2883 -- Do not convert to positional if controlled components are
2884 -- involved since these require special processing
2886 if Has_Controlled_Component (Typ) then
2890 if Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ))) then
2891 Analyze_And_Resolve (N, Typ);
2893 end Convert_To_Positional;
2895 ----------------------------
2896 -- Expand_Array_Aggregate --
2897 ----------------------------
2899 -- Array aggregate expansion proceeds as follows:
2901 -- 1. If requested we generate code to perform all the array aggregate
2902 -- bound checks, specifically
2904 -- (a) Check that the index range defined by aggregate bounds is
2905 -- compatible with corresponding index subtype.
2907 -- (b) If an others choice is present check that no aggregate
2908 -- index is outside the bounds of the index constraint.
2910 -- (c) For multidimensional arrays make sure that all subaggregates
2911 -- corresponding to the same dimension have the same bounds.
2913 -- 2. Check for packed array aggregate which can be converted to a
2914 -- constant so that the aggregate disappeares completely.
2916 -- 3. Check case of nested aggregate. Generally nested aggregates are
2917 -- handled during the processing of the parent aggregate.
2919 -- 4. Check if the aggregate can be statically processed. If this is the
2920 -- case pass it as is to Gigi. Note that a necessary condition for
2921 -- static processing is that the aggregate be fully positional.
2923 -- 5. If in place aggregate expansion is possible (i.e. no need to create
2924 -- a temporary) then mark the aggregate as such and return. Otherwise
2925 -- create a new temporary and generate the appropriate initialization
2928 procedure Expand_Array_Aggregate (N : Node_Id) is
2929 Loc : constant Source_Ptr := Sloc (N);
2931 Typ : constant Entity_Id := Etype (N);
2932 Ctyp : constant Entity_Id := Component_Type (Typ);
2933 -- Typ is the correct constrained array subtype of the aggregate
2934 -- Ctyp is the corresponding component type.
2936 Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
2937 -- Number of aggregate index dimensions.
2939 Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id;
2940 Aggr_High : array (1 .. Aggr_Dimension) of Node_Id;
2941 -- Low and High bounds of the constraint for each aggregate index.
2943 Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
2944 -- The type of each index.
2946 Maybe_In_Place_OK : Boolean;
2947 -- If the type is neither controlled nor packed and the aggregate
2948 -- is the expression in an assignment, assignment in place may be
2949 -- possible, provided other conditions are met on the LHS.
2951 Others_Present : array (1 .. Aggr_Dimension) of Boolean :=
2953 -- If Others_Present (J) is True, then there is an others choice
2954 -- in one of the sub-aggregates of N at dimension J.
2956 procedure Build_Constrained_Type (Positional : Boolean);
2957 -- If the subtype is not static or unconstrained, build a constrained
2958 -- type using the computable sizes of the aggregate and its sub-
2961 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id);
2962 -- Checks that the bounds of Aggr_Bounds are within the bounds defined
2965 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos);
2966 -- Checks that in a multi-dimensional array aggregate all subaggregates
2967 -- corresponding to the same dimension have the same bounds.
2968 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
2969 -- corresponding to the sub-aggregate.
2971 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos);
2972 -- Computes the values of array Others_Present. Sub_Aggr is the
2973 -- array sub-aggregate we start the computation from. Dim is the
2974 -- dimension corresponding to the sub-aggregate.
2976 function Has_Address_Clause (D : Node_Id) return Boolean;
2977 -- If the aggregate is the expression in an object declaration, it
2978 -- cannot be expanded in place. This function does a lookahead in the
2979 -- current declarative part to find an address clause for the object
2982 function In_Place_Assign_OK return Boolean;
2983 -- Simple predicate to determine whether an aggregate assignment can
2984 -- be done in place, because none of the new values can depend on the
2985 -- components of the target of the assignment.
2987 function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean;
2988 -- A static aggregate in an object declaration can in most cases be
2989 -- expanded in place. The one exception is when the aggregate is given
2990 -- with component associations that specify different bounds from those
2991 -- of the type definition in the object declaration. In this rather
2992 -- pathological case the aggregate must slide, and we must introduce
2993 -- an intermediate temporary to hold it.
2995 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
2996 -- Checks that if an others choice is present in any sub-aggregate no
2997 -- aggregate index is outside the bounds of the index constraint.
2998 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
2999 -- corresponding to the sub-aggregate.
3001 ----------------------------
3002 -- Build_Constrained_Type --
3003 ----------------------------
3005 procedure Build_Constrained_Type (Positional : Boolean) is
3006 Loc : constant Source_Ptr := Sloc (N);
3007 Agg_Type : Entity_Id;
3010 Typ : constant Entity_Id := Etype (N);
3011 Indices : constant List_Id := New_List;
3017 Make_Defining_Identifier (
3018 Loc, New_Internal_Name ('A'));
3020 -- If the aggregate is purely positional, all its subaggregates
3021 -- have the same size. We collect the dimensions from the first
3022 -- subaggregate at each level.
3027 for D in 1 .. Number_Dimensions (Typ) loop
3028 Comp := First (Expressions (Sub_Agg));
3033 while Present (Comp) loop
3040 Low_Bound => Make_Integer_Literal (Loc, 1),
3042 Make_Integer_Literal (Loc, Num)),
3047 -- We know the aggregate type is unconstrained and the
3048 -- aggregate is not processable by the back end, therefore
3049 -- not necessarily positional. Retrieve the bounds of each
3050 -- dimension as computed earlier.
3052 for D in 1 .. Number_Dimensions (Typ) loop
3055 Low_Bound => Aggr_Low (D),
3056 High_Bound => Aggr_High (D)),
3062 Make_Full_Type_Declaration (Loc,
3063 Defining_Identifier => Agg_Type,
3065 Make_Constrained_Array_Definition (Loc,
3066 Discrete_Subtype_Definitions => Indices,
3067 Component_Definition =>
3068 Make_Component_Definition (Loc,
3069 Aliased_Present => False,
3070 Subtype_Indication =>
3071 New_Occurrence_Of (Component_Type (Typ), Loc))));
3073 Insert_Action (N, Decl);
3075 Set_Etype (N, Agg_Type);
3076 Set_Is_Itype (Agg_Type);
3077 Freeze_Itype (Agg_Type, N);
3078 end Build_Constrained_Type;
3084 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is
3091 Cond : Node_Id := Empty;
3094 Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi);
3095 Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi);
3097 -- Generate the following test:
3099 -- [constraint_error when
3100 -- Aggr_Lo <= Aggr_Hi and then
3101 -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
3103 -- As an optimization try to see if some tests are trivially vacuos
3104 -- because we are comparing an expression against itself.
3106 if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then
3109 elsif Aggr_Hi = Ind_Hi then
3112 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3113 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo));
3115 elsif Aggr_Lo = Ind_Lo then
3118 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
3119 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Hi));
3126 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3127 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)),
3131 Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
3132 Right_Opnd => Duplicate_Subexpr (Ind_Hi)));
3135 if Present (Cond) then
3140 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3141 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)),
3143 Right_Opnd => Cond);
3145 Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False);
3146 Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False);
3148 Make_Raise_Constraint_Error (Loc,
3150 Reason => CE_Length_Check_Failed));
3154 ----------------------------
3155 -- Check_Same_Aggr_Bounds --
3156 ----------------------------
3158 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
3159 Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr));
3160 Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr));
3161 -- The bounds of this specific sub-aggregate.
3163 Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
3164 Aggr_Hi : constant Node_Id := Aggr_High (Dim);
3165 -- The bounds of the aggregate for this dimension
3167 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
3168 -- The index type for this dimension.
3170 Cond : Node_Id := Empty;
3176 -- If index checks are on generate the test
3178 -- [constraint_error when
3179 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
3181 -- As an optimization try to see if some tests are trivially vacuos
3182 -- because we are comparing an expression against itself. Also for
3183 -- the first dimension the test is trivially vacuous because there
3184 -- is just one aggregate for dimension 1.
3186 if Index_Checks_Suppressed (Ind_Typ) then
3190 or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi)
3194 elsif Aggr_Hi = Sub_Hi then
3197 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3198 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo));
3200 elsif Aggr_Lo = Sub_Lo then
3203 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
3204 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi));
3211 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3212 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)),
3216 Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
3217 Right_Opnd => Duplicate_Subexpr (Sub_Hi)));
3220 if Present (Cond) then
3222 Make_Raise_Constraint_Error (Loc,
3224 Reason => CE_Length_Check_Failed));
3227 -- Now look inside the sub-aggregate to see if there is more work
3229 if Dim < Aggr_Dimension then
3231 -- Process positional components
3233 if Present (Expressions (Sub_Aggr)) then
3234 Expr := First (Expressions (Sub_Aggr));
3235 while Present (Expr) loop
3236 Check_Same_Aggr_Bounds (Expr, Dim + 1);
3241 -- Process component associations
3243 if Present (Component_Associations (Sub_Aggr)) then
3244 Assoc := First (Component_Associations (Sub_Aggr));
3245 while Present (Assoc) loop
3246 Expr := Expression (Assoc);
3247 Check_Same_Aggr_Bounds (Expr, Dim + 1);
3252 end Check_Same_Aggr_Bounds;
3254 ----------------------------
3255 -- Compute_Others_Present --
3256 ----------------------------
3258 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is
3263 if Present (Component_Associations (Sub_Aggr)) then
3264 Assoc := Last (Component_Associations (Sub_Aggr));
3266 if Nkind (First (Choices (Assoc))) = N_Others_Choice then
3267 Others_Present (Dim) := True;
3271 -- Now look inside the sub-aggregate to see if there is more work
3273 if Dim < Aggr_Dimension then
3275 -- Process positional components
3277 if Present (Expressions (Sub_Aggr)) then
3278 Expr := First (Expressions (Sub_Aggr));
3279 while Present (Expr) loop
3280 Compute_Others_Present (Expr, Dim + 1);
3285 -- Process component associations
3287 if Present (Component_Associations (Sub_Aggr)) then
3288 Assoc := First (Component_Associations (Sub_Aggr));
3289 while Present (Assoc) loop
3290 Expr := Expression (Assoc);
3291 Compute_Others_Present (Expr, Dim + 1);
3296 end Compute_Others_Present;
3298 ------------------------
3299 -- Has_Address_Clause --
3300 ------------------------
3302 function Has_Address_Clause (D : Node_Id) return Boolean is
3303 Id : constant Entity_Id := Defining_Identifier (D);
3304 Decl : Node_Id := Next (D);
3307 while Present (Decl) loop
3308 if Nkind (Decl) = N_At_Clause
3309 and then Chars (Identifier (Decl)) = Chars (Id)
3313 elsif Nkind (Decl) = N_Attribute_Definition_Clause
3314 and then Chars (Decl) = Name_Address
3315 and then Chars (Name (Decl)) = Chars (Id)
3324 end Has_Address_Clause;
3326 ------------------------
3327 -- In_Place_Assign_OK --
3328 ------------------------
3330 function In_Place_Assign_OK return Boolean is
3338 function Is_Others_Aggregate (Aggr : Node_Id) return Boolean;
3339 -- Aggregates that consist of a single Others choice are safe
3340 -- if the single expression is.
3342 function Safe_Aggregate (Aggr : Node_Id) return Boolean;
3343 -- Check recursively that each component of a (sub)aggregate does
3344 -- not depend on the variable being assigned to.
3346 function Safe_Component (Expr : Node_Id) return Boolean;
3347 -- Verify that an expression cannot depend on the variable being
3348 -- assigned to. Room for improvement here (but less than before).
3350 -------------------------
3351 -- Is_Others_Aggregate --
3352 -------------------------
3354 function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is
3356 return No (Expressions (Aggr))
3358 (First (Choices (First (Component_Associations (Aggr)))))
3360 end Is_Others_Aggregate;
3362 --------------------
3363 -- Safe_Aggregate --
3364 --------------------
3366 function Safe_Aggregate (Aggr : Node_Id) return Boolean is
3370 if Present (Expressions (Aggr)) then
3371 Expr := First (Expressions (Aggr));
3373 while Present (Expr) loop
3374 if Nkind (Expr) = N_Aggregate then
3375 if not Safe_Aggregate (Expr) then
3379 elsif not Safe_Component (Expr) then
3387 if Present (Component_Associations (Aggr)) then
3388 Expr := First (Component_Associations (Aggr));
3390 while Present (Expr) loop
3391 if Nkind (Expression (Expr)) = N_Aggregate then
3392 if not Safe_Aggregate (Expression (Expr)) then
3396 elsif not Safe_Component (Expression (Expr)) then
3407 --------------------
3408 -- Safe_Component --
3409 --------------------
3411 function Safe_Component (Expr : Node_Id) return Boolean is
3412 Comp : Node_Id := Expr;
3414 function Check_Component (Comp : Node_Id) return Boolean;
3415 -- Do the recursive traversal, after copy.
3417 ---------------------
3418 -- Check_Component --
3419 ---------------------
3421 function Check_Component (Comp : Node_Id) return Boolean is
3423 if Is_Overloaded (Comp) then
3427 return Compile_Time_Known_Value (Comp)
3429 or else (Is_Entity_Name (Comp)
3430 and then Present (Entity (Comp))
3431 and then No (Renamed_Object (Entity (Comp))))
3433 or else (Nkind (Comp) = N_Attribute_Reference
3434 and then Check_Component (Prefix (Comp)))
3436 or else (Nkind (Comp) in N_Binary_Op
3437 and then Check_Component (Left_Opnd (Comp))
3438 and then Check_Component (Right_Opnd (Comp)))
3440 or else (Nkind (Comp) in N_Unary_Op
3441 and then Check_Component (Right_Opnd (Comp)))
3443 or else (Nkind (Comp) = N_Selected_Component
3444 and then Check_Component (Prefix (Comp)));
3445 end Check_Component;
3447 -- Start of processing for Safe_Component
3450 -- If the component appears in an association that may
3451 -- correspond to more than one element, it is not analyzed
3452 -- before the expansion into assignments, to avoid side effects.
3453 -- We analyze, but do not resolve the copy, to obtain sufficient
3454 -- entity information for the checks that follow. If component is
3455 -- overloaded we assume an unsafe function call.
3457 if not Analyzed (Comp) then
3458 if Is_Overloaded (Expr) then
3461 elsif Nkind (Expr) = N_Aggregate
3462 and then not Is_Others_Aggregate (Expr)
3466 elsif Nkind (Expr) = N_Allocator then
3467 -- For now, too complex to analyze.
3472 Comp := New_Copy_Tree (Expr);
3473 Set_Parent (Comp, Parent (Expr));
3477 if Nkind (Comp) = N_Aggregate then
3478 return Safe_Aggregate (Comp);
3480 return Check_Component (Comp);
3484 -- Start of processing for In_Place_Assign_OK
3487 if Present (Component_Associations (N)) then
3489 -- On assignment, sliding can take place, so we cannot do the
3490 -- assignment in place unless the bounds of the aggregate are
3491 -- statically equal to those of the target.
3493 -- If the aggregate is given by an others choice, the bounds
3494 -- are derived from the left-hand side, and the assignment is
3495 -- safe if the expression is.
3497 if Is_Others_Aggregate (N) then
3500 (Expression (First (Component_Associations (N))));
3503 Aggr_In := First_Index (Etype (N));
3504 Obj_In := First_Index (Etype (Name (Parent (N))));
3506 while Present (Aggr_In) loop
3507 Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
3508 Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
3510 if not Compile_Time_Known_Value (Aggr_Lo)
3511 or else not Compile_Time_Known_Value (Aggr_Hi)
3512 or else not Compile_Time_Known_Value (Obj_Lo)
3513 or else not Compile_Time_Known_Value (Obj_Hi)
3514 or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
3515 or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
3520 Next_Index (Aggr_In);
3521 Next_Index (Obj_In);
3525 -- Now check the component values themselves.
3527 return Safe_Aggregate (N);
3528 end In_Place_Assign_OK;
3534 function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean
3536 Obj_Type : constant Entity_Id :=
3537 Etype (Defining_Identifier (Parent (N)));
3539 L1, L2, H1, H2 : Node_Id;
3542 -- No sliding if the type of the object is not established yet, if
3543 -- it is an unconstrained type whose actual subtype comes from the
3544 -- aggregate, or if the two types are identical.
3546 if not Is_Array_Type (Obj_Type) then
3549 elsif not Is_Constrained (Obj_Type) then
3552 elsif Typ = Obj_Type then
3556 -- Sliding can only occur along the first dimension
3558 Get_Index_Bounds (First_Index (Typ), L1, H1);
3559 Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
3561 if not Is_Static_Expression (L1)
3562 or else not Is_Static_Expression (L2)
3563 or else not Is_Static_Expression (H1)
3564 or else not Is_Static_Expression (H2)
3568 return Expr_Value (L1) /= Expr_Value (L2)
3569 or else Expr_Value (H1) /= Expr_Value (H2);
3578 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is
3579 Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
3580 Aggr_Hi : constant Node_Id := Aggr_High (Dim);
3581 -- The bounds of the aggregate for this dimension.
3583 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
3584 -- The index type for this dimension.
3586 Need_To_Check : Boolean := False;
3588 Choices_Lo : Node_Id := Empty;
3589 Choices_Hi : Node_Id := Empty;
3590 -- The lowest and highest discrete choices for a named sub-aggregate
3592 Nb_Choices : Int := -1;
3593 -- The number of discrete non-others choices in this sub-aggregate
3595 Nb_Elements : Uint := Uint_0;
3596 -- The number of elements in a positional aggregate
3598 Cond : Node_Id := Empty;
3605 -- Check if we have an others choice. If we do make sure that this
3606 -- sub-aggregate contains at least one element in addition to the
3609 if Range_Checks_Suppressed (Ind_Typ) then
3610 Need_To_Check := False;
3612 elsif Present (Expressions (Sub_Aggr))
3613 and then Present (Component_Associations (Sub_Aggr))
3615 Need_To_Check := True;
3617 elsif Present (Component_Associations (Sub_Aggr)) then
3618 Assoc := Last (Component_Associations (Sub_Aggr));
3620 if Nkind (First (Choices (Assoc))) /= N_Others_Choice then
3621 Need_To_Check := False;
3624 -- Count the number of discrete choices. Start with -1
3625 -- because the others choice does not count.
3628 Assoc := First (Component_Associations (Sub_Aggr));
3629 while Present (Assoc) loop
3630 Choice := First (Choices (Assoc));
3631 while Present (Choice) loop
3632 Nb_Choices := Nb_Choices + 1;
3639 -- If there is only an others choice nothing to do
3641 Need_To_Check := (Nb_Choices > 0);
3645 Need_To_Check := False;
3648 -- If we are dealing with a positional sub-aggregate with an
3649 -- others choice then compute the number or positional elements.
3651 if Need_To_Check and then Present (Expressions (Sub_Aggr)) then
3652 Expr := First (Expressions (Sub_Aggr));
3653 Nb_Elements := Uint_0;
3654 while Present (Expr) loop
3655 Nb_Elements := Nb_Elements + 1;
3659 -- If the aggregate contains discrete choices and an others choice
3660 -- compute the smallest and largest discrete choice values.
3662 elsif Need_To_Check then
3663 Compute_Choices_Lo_And_Choices_Hi : declare
3665 Table : Case_Table_Type (1 .. Nb_Choices);
3666 -- Used to sort all the different choice values
3673 Assoc := First (Component_Associations (Sub_Aggr));
3674 while Present (Assoc) loop
3675 Choice := First (Choices (Assoc));
3676 while Present (Choice) loop
3677 if Nkind (Choice) = N_Others_Choice then
3681 Get_Index_Bounds (Choice, Low, High);
3682 Table (J).Choice_Lo := Low;
3683 Table (J).Choice_Hi := High;
3692 -- Sort the discrete choices
3694 Sort_Case_Table (Table);
3696 Choices_Lo := Table (1).Choice_Lo;
3697 Choices_Hi := Table (Nb_Choices).Choice_Hi;
3698 end Compute_Choices_Lo_And_Choices_Hi;
3701 -- If no others choice in this sub-aggregate, or the aggregate
3702 -- comprises only an others choice, nothing to do.
3704 if not Need_To_Check then
3707 -- If we are dealing with an aggregate containing an others
3708 -- choice and positional components, we generate the following test:
3710 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
3711 -- Ind_Typ'Pos (Aggr_Hi)
3713 -- raise Constraint_Error;
3716 elsif Nb_Elements > Uint_0 then
3722 Make_Attribute_Reference (Loc,
3723 Prefix => New_Reference_To (Ind_Typ, Loc),
3724 Attribute_Name => Name_Pos,
3727 (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
3728 Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
3731 Make_Attribute_Reference (Loc,
3732 Prefix => New_Reference_To (Ind_Typ, Loc),
3733 Attribute_Name => Name_Pos,
3734 Expressions => New_List (
3735 Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
3737 -- If we are dealing with an aggregate containing an others
3738 -- choice and discrete choices we generate the following test:
3740 -- [constraint_error when
3741 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
3749 Duplicate_Subexpr_Move_Checks (Choices_Lo),
3751 Duplicate_Subexpr_Move_Checks (Aggr_Lo)),
3756 Duplicate_Subexpr (Choices_Hi),
3758 Duplicate_Subexpr (Aggr_Hi)));
3761 if Present (Cond) then
3763 Make_Raise_Constraint_Error (Loc,
3765 Reason => CE_Length_Check_Failed));
3768 -- Now look inside the sub-aggregate to see if there is more work
3770 if Dim < Aggr_Dimension then
3772 -- Process positional components
3774 if Present (Expressions (Sub_Aggr)) then
3775 Expr := First (Expressions (Sub_Aggr));
3776 while Present (Expr) loop
3777 Others_Check (Expr, Dim + 1);
3782 -- Process component associations
3784 if Present (Component_Associations (Sub_Aggr)) then
3785 Assoc := First (Component_Associations (Sub_Aggr));
3786 while Present (Assoc) loop
3787 Expr := Expression (Assoc);
3788 Others_Check (Expr, Dim + 1);
3795 -- Remaining Expand_Array_Aggregate variables
3798 -- Holds the temporary aggregate value
3801 -- Holds the declaration of Tmp
3803 Aggr_Code : List_Id;
3804 Parent_Node : Node_Id;
3805 Parent_Kind : Node_Kind;
3807 -- Start of processing for Expand_Array_Aggregate
3810 -- Do not touch the special aggregates of attributes used for Asm calls
3812 if Is_RTE (Ctyp, RE_Asm_Input_Operand)
3813 or else Is_RTE (Ctyp, RE_Asm_Output_Operand)
3818 -- If the semantic analyzer has determined that aggregate N will raise
3819 -- Constraint_Error at run-time, then the aggregate node has been
3820 -- replaced with an N_Raise_Constraint_Error node and we should
3823 pragma Assert (not Raises_Constraint_Error (N));
3827 -- Check that the index range defined by aggregate bounds is
3828 -- compatible with corresponding index subtype.
3830 Index_Compatibility_Check : declare
3831 Aggr_Index_Range : Node_Id := First_Index (Typ);
3832 -- The current aggregate index range
3834 Index_Constraint : Node_Id := First_Index (Etype (Typ));
3835 -- The corresponding index constraint against which we have to
3836 -- check the above aggregate index range.
3839 Compute_Others_Present (N, 1);
3841 for J in 1 .. Aggr_Dimension loop
3842 -- There is no need to emit a check if an others choice is
3843 -- present for this array aggregate dimension since in this
3844 -- case one of N's sub-aggregates has taken its bounds from the
3845 -- context and these bounds must have been checked already. In
3846 -- addition all sub-aggregates corresponding to the same
3847 -- dimension must all have the same bounds (checked in (c) below).
3849 if not Range_Checks_Suppressed (Etype (Index_Constraint))
3850 and then not Others_Present (J)
3852 -- We don't use Checks.Apply_Range_Check here because it
3853 -- emits a spurious check. Namely it checks that the range
3854 -- defined by the aggregate bounds is non empty. But we know
3855 -- this already if we get here.
3857 Check_Bounds (Aggr_Index_Range, Index_Constraint);
3860 -- Save the low and high bounds of the aggregate index as well
3861 -- as the index type for later use in checks (b) and (c) below.
3863 Aggr_Low (J) := Low_Bound (Aggr_Index_Range);
3864 Aggr_High (J) := High_Bound (Aggr_Index_Range);
3866 Aggr_Index_Typ (J) := Etype (Index_Constraint);
3868 Next_Index (Aggr_Index_Range);
3869 Next_Index (Index_Constraint);
3871 end Index_Compatibility_Check;
3875 -- If an others choice is present check that no aggregate
3876 -- index is outside the bounds of the index constraint.
3878 Others_Check (N, 1);
3882 -- For multidimensional arrays make sure that all subaggregates
3883 -- corresponding to the same dimension have the same bounds.
3885 if Aggr_Dimension > 1 then
3886 Check_Same_Aggr_Bounds (N, 1);
3891 -- Here we test for is packed array aggregate that we can handle
3892 -- at compile time. If so, return with transformation done. Note
3893 -- that we do this even if the aggregate is nested, because once
3894 -- we have done this processing, there is no more nested aggregate!
3896 if Packed_Array_Aggregate_Handled (N) then
3900 -- At this point we try to convert to positional form
3902 Convert_To_Positional (N);
3904 -- if the result is no longer an aggregate (e.g. it may be a string
3905 -- literal, or a temporary which has the needed value), then we are
3906 -- done, since there is no longer a nested aggregate.
3908 if Nkind (N) /= N_Aggregate then
3911 -- We are also done if the result is an analyzed aggregate
3912 -- This case could use more comments ???
3915 and then N /= Original_Node (N)
3920 -- Now see if back end processing is possible
3922 if Backend_Processing_Possible (N) then
3924 -- If the aggregate is static but the constraints are not, build
3925 -- a static subtype for the aggregate, so that Gigi can place it
3926 -- in static memory. Perform an unchecked_conversion to the non-
3927 -- static type imposed by the context.
3930 Itype : constant Entity_Id := Etype (N);
3932 Needs_Type : Boolean := False;
3935 Index := First_Index (Itype);
3937 while Present (Index) loop
3938 if not Is_Static_Subtype (Etype (Index)) then
3947 Build_Constrained_Type (Positional => True);
3948 Rewrite (N, Unchecked_Convert_To (Itype, N));
3958 -- Delay expansion for nested aggregates it will be taken care of
3959 -- when the parent aggregate is expanded
3961 Parent_Node := Parent (N);
3962 Parent_Kind := Nkind (Parent_Node);
3964 if Parent_Kind = N_Qualified_Expression then
3965 Parent_Node := Parent (Parent_Node);
3966 Parent_Kind := Nkind (Parent_Node);
3969 if Parent_Kind = N_Aggregate
3970 or else Parent_Kind = N_Extension_Aggregate
3971 or else Parent_Kind = N_Component_Association
3972 or else (Parent_Kind = N_Object_Declaration
3973 and then Controlled_Type (Typ))
3974 or else (Parent_Kind = N_Assignment_Statement
3975 and then Inside_Init_Proc)
3977 Set_Expansion_Delayed (N);
3983 -- Look if in place aggregate expansion is possible
3985 -- For object declarations we build the aggregate in place, unless
3986 -- the array is bit-packed or the component is controlled.
3988 -- For assignments we do the assignment in place if all the component
3989 -- associations have compile-time known values. For other cases we
3990 -- create a temporary. The analysis for safety of on-line assignment
3991 -- is delicate, i.e. we don't know how to do it fully yet ???
3993 if Requires_Transient_Scope (Typ) then
3994 Establish_Transient_Scope
3995 (N, Sec_Stack => Has_Controlled_Component (Typ));
3998 if Has_Default_Init_Comps (N) then
3999 Maybe_In_Place_OK := False;
4001 Maybe_In_Place_OK :=
4002 Comes_From_Source (N)
4003 and then Nkind (Parent (N)) = N_Assignment_Statement
4004 and then not Is_Bit_Packed_Array (Typ)
4005 and then not Has_Controlled_Component (Typ)
4006 and then In_Place_Assign_OK;
4009 if not Has_Default_Init_Comps (N)
4010 and then Comes_From_Source (Parent (N))
4011 and then Nkind (Parent (N)) = N_Object_Declaration
4012 and then not Must_Slide (N, Typ)
4013 and then N = Expression (Parent (N))
4014 and then not Is_Bit_Packed_Array (Typ)
4015 and then not Has_Controlled_Component (Typ)
4016 and then not Has_Address_Clause (Parent (N))
4018 Tmp := Defining_Identifier (Parent (N));
4019 Set_No_Initialization (Parent (N));
4020 Set_Expression (Parent (N), Empty);
4022 -- Set the type of the entity, for use in the analysis of the
4023 -- subsequent indexed assignments. If the nominal type is not
4024 -- constrained, build a subtype from the known bounds of the
4025 -- aggregate. If the declaration has a subtype mark, use it,
4026 -- otherwise use the itype of the aggregate.
4028 if not Is_Constrained (Typ) then
4029 Build_Constrained_Type (Positional => False);
4030 elsif Is_Entity_Name (Object_Definition (Parent (N)))
4031 and then Is_Constrained (Entity (Object_Definition (Parent (N))))
4033 Set_Etype (Tmp, Entity (Object_Definition (Parent (N))));
4035 Set_Size_Known_At_Compile_Time (Typ, False);
4036 Set_Etype (Tmp, Typ);
4039 elsif Maybe_In_Place_OK
4040 and then Is_Entity_Name (Name (Parent (N)))
4042 Tmp := Entity (Name (Parent (N)));
4044 if Etype (Tmp) /= Etype (N) then
4045 Apply_Length_Check (N, Etype (Tmp));
4047 if Nkind (N) = N_Raise_Constraint_Error then
4049 -- Static error, nothing further to expand
4055 elsif Maybe_In_Place_OK
4056 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
4057 and then Is_Entity_Name (Prefix (Name (Parent (N))))
4059 Tmp := Name (Parent (N));
4061 if Etype (Tmp) /= Etype (N) then
4062 Apply_Length_Check (N, Etype (Tmp));
4065 elsif Maybe_In_Place_OK
4066 and then Nkind (Name (Parent (N))) = N_Slice
4067 and then Safe_Slice_Assignment (N)
4069 -- Safe_Slice_Assignment rewrites assignment as a loop
4075 -- In place aggregate expansion is not possible
4078 Maybe_In_Place_OK := False;
4079 Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
4081 Make_Object_Declaration
4083 Defining_Identifier => Tmp,
4084 Object_Definition => New_Occurrence_Of (Typ, Loc));
4085 Set_No_Initialization (Tmp_Decl, True);
4087 -- If we are within a loop, the temporary will be pushed on the
4088 -- stack at each iteration. If the aggregate is the expression for
4089 -- an allocator, it will be immediately copied to the heap and can
4090 -- be reclaimed at once. We create a transient scope around the
4091 -- aggregate for this purpose.
4093 if Ekind (Current_Scope) = E_Loop
4094 and then Nkind (Parent (Parent (N))) = N_Allocator
4096 Establish_Transient_Scope (N, False);
4099 Insert_Action (N, Tmp_Decl);
4102 -- Construct and insert the aggregate code. We can safely suppress
4103 -- index checks because this code is guaranteed not to raise CE
4104 -- on index checks. However we should *not* suppress all checks.
4110 if Nkind (Tmp) = N_Defining_Identifier then
4111 Target := New_Reference_To (Tmp, Loc);
4115 if Has_Default_Init_Comps (N) then
4117 -- Ada0Y (AI-287): This case has not been analyzed???
4119 pragma Assert (False);
4123 -- Name in assignment is explicit dereference.
4125 Target := New_Copy (Tmp);
4129 Build_Array_Aggr_Code (N,
4131 Index => First_Index (Typ),
4133 Scalar_Comp => Is_Scalar_Type (Ctyp));
4136 if Comes_From_Source (Tmp) then
4137 Insert_Actions_After (Parent (N), Aggr_Code);
4140 Insert_Actions (N, Aggr_Code);
4143 -- If the aggregate has been assigned in place, remove the original
4146 if Nkind (Parent (N)) = N_Assignment_Statement
4147 and then Maybe_In_Place_OK
4149 Rewrite (Parent (N), Make_Null_Statement (Loc));
4151 elsif Nkind (Parent (N)) /= N_Object_Declaration
4152 or else Tmp /= Defining_Identifier (Parent (N))
4154 Rewrite (N, New_Occurrence_Of (Tmp, Loc));
4155 Analyze_And_Resolve (N, Typ);
4157 end Expand_Array_Aggregate;
4159 ------------------------
4160 -- Expand_N_Aggregate --
4161 ------------------------
4163 procedure Expand_N_Aggregate (N : Node_Id) is
4165 if Is_Record_Type (Etype (N)) then
4166 Expand_Record_Aggregate (N);
4168 Expand_Array_Aggregate (N);
4172 when RE_Not_Available =>
4174 end Expand_N_Aggregate;
4176 ----------------------------------
4177 -- Expand_N_Extension_Aggregate --
4178 ----------------------------------
4180 -- If the ancestor part is an expression, add a component association for
4181 -- the parent field. If the type of the ancestor part is not the direct
4182 -- parent of the expected type, build recursively the needed ancestors.
4183 -- If the ancestor part is a subtype_mark, replace aggregate with a decla-
4184 -- ration for a temporary of the expected type, followed by individual
4185 -- assignments to the given components.
4187 procedure Expand_N_Extension_Aggregate (N : Node_Id) is
4188 Loc : constant Source_Ptr := Sloc (N);
4189 A : constant Node_Id := Ancestor_Part (N);
4190 Typ : constant Entity_Id := Etype (N);
4193 -- If the ancestor is a subtype mark, an init proc must be called
4194 -- on the resulting object which thus has to be materialized in
4197 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
4198 Convert_To_Assignments (N, Typ);
4200 -- The extension aggregate is transformed into a record aggregate
4201 -- of the following form (c1 and c2 are inherited components)
4203 -- (Exp with c3 => a, c4 => b)
4204 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b)
4209 -- No tag is needed in the case of Java_VM
4212 Expand_Record_Aggregate (N,
4215 Expand_Record_Aggregate (N,
4216 Orig_Tag => New_Occurrence_Of (Access_Disp_Table (Typ), Loc),
4222 when RE_Not_Available =>
4224 end Expand_N_Extension_Aggregate;
4226 -----------------------------
4227 -- Expand_Record_Aggregate --
4228 -----------------------------
4230 procedure Expand_Record_Aggregate
4232 Orig_Tag : Node_Id := Empty;
4233 Parent_Expr : Node_Id := Empty)
4235 Loc : constant Source_Ptr := Sloc (N);
4236 Comps : constant List_Id := Component_Associations (N);
4237 Typ : constant Entity_Id := Etype (N);
4238 Base_Typ : constant Entity_Id := Base_Type (Typ);
4240 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean;
4241 -- Checks the presence of a nested aggregate which needs Late_Expansion
4242 -- or the presence of tagged components which may need tag adjustment.
4244 --------------------------------------------------
4245 -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
4246 --------------------------------------------------
4248 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is
4258 while Present (C) loop
4259 if Nkind (Expression (C)) = N_Qualified_Expression then
4260 Expr_Q := Expression (Expression (C));
4262 Expr_Q := Expression (C);
4265 -- Return true if the aggregate has any associations for
4266 -- tagged components that may require tag adjustment.
4267 -- These are cases where the source expression may have
4268 -- a tag that could differ from the component tag (e.g.,
4269 -- can occur for type conversions and formal parameters).
4270 -- (Tag adjustment is not needed if Java_VM because object
4271 -- tags are implicit in the JVM.)
4273 if Is_Tagged_Type (Etype (Expr_Q))
4274 and then (Nkind (Expr_Q) = N_Type_Conversion
4275 or else (Is_Entity_Name (Expr_Q)
4276 and then Ekind (Entity (Expr_Q)) in Formal_Kind))
4277 and then not Java_VM
4282 if Is_Delayed_Aggregate (Expr_Q) then
4290 end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps;
4292 -- Remaining Expand_Record_Aggregate variables
4294 Tag_Value : Node_Id;
4298 -- Start of processing for Expand_Record_Aggregate
4301 -- If the aggregate is to be assigned to an atomic variable, we
4302 -- have to prevent a piecemeal assignment even if the aggregate
4303 -- is to be expanded. We create a temporary for the aggregate, and
4304 -- assign the temporary instead, so that the back end can generate
4305 -- an atomic move for it.
4308 and then (Nkind (Parent (N)) = N_Object_Declaration
4309 or else Nkind (Parent (N)) = N_Assignment_Statement)
4310 and then Comes_From_Source (Parent (N))
4312 Expand_Atomic_Aggregate (N, Typ);
4316 -- Gigi doesn't handle properly temporaries of variable size
4317 -- so we generate it in the front-end
4319 if not Size_Known_At_Compile_Time (Typ) then
4320 Convert_To_Assignments (N, Typ);
4322 -- Temporaries for controlled aggregates need to be attached to a
4323 -- final chain in order to be properly finalized, so it has to
4324 -- be created in the front-end
4326 elsif Is_Controlled (Typ)
4327 or else Has_Controlled_Component (Base_Type (Typ))
4329 Convert_To_Assignments (N, Typ);
4331 -- Ada0Y (AI-287): In case of default initialized components we convert
4332 -- the aggregate into assignments.
4334 elsif Has_Default_Init_Comps (N) then
4335 Convert_To_Assignments (N, Typ);
4337 elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then
4338 Convert_To_Assignments (N, Typ);
4340 -- If an ancestor is private, some components are not inherited and
4341 -- we cannot expand into a record aggregate
4343 elsif Has_Private_Ancestor (Typ) then
4344 Convert_To_Assignments (N, Typ);
4346 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
4347 -- is not able to handle the aggregate for Late_Request.
4349 elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
4350 Convert_To_Assignments (N, Typ);
4352 -- If some components are mutable, the size of the aggregate component
4353 -- may be disctinct from the default size of the type component, so
4354 -- we need to expand to insure that the back-end copies the proper
4355 -- size of the data.
4357 elsif Has_Mutable_Components (Typ) then
4358 Convert_To_Assignments (N, Typ);
4360 -- If the type involved has any non-bit aligned components, then
4361 -- we are not sure that the back end can handle this case correctly.
4363 elsif Type_May_Have_Bit_Aligned_Components (Typ) then
4364 Convert_To_Assignments (N, Typ);
4366 -- In all other cases we generate a proper aggregate that
4367 -- can be handled by gigi.
4370 -- If no discriminants, nothing special to do
4372 if not Has_Discriminants (Typ) then
4375 -- Case of discriminants present
4377 elsif Is_Derived_Type (Typ) then
4379 -- For untagged types, non-stored discriminants are replaced
4380 -- with stored discriminants, which are the ones that gigi uses
4381 -- to describe the type and its components.
4383 Generate_Aggregate_For_Derived_Type : declare
4384 Constraints : constant List_Id := New_List;
4385 First_Comp : Node_Id;
4386 Discriminant : Entity_Id;
4388 Num_Disc : Int := 0;
4389 Num_Gird : Int := 0;
4391 procedure Prepend_Stored_Values (T : Entity_Id);
4392 -- Scan the list of stored discriminants of the type, and
4393 -- add their values to the aggregate being built.
4395 ---------------------------
4396 -- Prepend_Stored_Values --
4397 ---------------------------
4399 procedure Prepend_Stored_Values (T : Entity_Id) is
4401 Discriminant := First_Stored_Discriminant (T);
4403 while Present (Discriminant) loop
4405 Make_Component_Association (Loc,
4407 New_List (New_Occurrence_Of (Discriminant, Loc)),
4411 Get_Discriminant_Value (
4414 Discriminant_Constraint (Typ))));
4416 if No (First_Comp) then
4417 Prepend_To (Component_Associations (N), New_Comp);
4419 Insert_After (First_Comp, New_Comp);
4422 First_Comp := New_Comp;
4423 Next_Stored_Discriminant (Discriminant);
4425 end Prepend_Stored_Values;
4427 -- Start of processing for Generate_Aggregate_For_Derived_Type
4430 -- Remove the associations for the discriminant of
4431 -- the derived type.
4433 First_Comp := First (Component_Associations (N));
4435 while Present (First_Comp) loop
4439 if Ekind (Entity (First (Choices (Comp)))) =
4443 Num_Disc := Num_Disc + 1;
4447 -- Insert stored discriminant associations in the correct
4448 -- order. If there are more stored discriminants than new
4449 -- discriminants, there is at least one new discriminant
4450 -- that constrains more than one of the stored discriminants.
4451 -- In this case we need to construct a proper subtype of
4452 -- the parent type, in order to supply values to all the
4453 -- components. Otherwise there is one-one correspondence
4454 -- between the constraints and the stored discriminants.
4456 First_Comp := Empty;
4458 Discriminant := First_Stored_Discriminant (Base_Type (Typ));
4460 while Present (Discriminant) loop
4461 Num_Gird := Num_Gird + 1;
4462 Next_Stored_Discriminant (Discriminant);
4465 -- Case of more stored discriminants than new discriminants
4467 if Num_Gird > Num_Disc then
4469 -- Create a proper subtype of the parent type, which is
4470 -- the proper implementation type for the aggregate, and
4471 -- convert it to the intended target type.
4473 Discriminant := First_Stored_Discriminant (Base_Type (Typ));
4475 while Present (Discriminant) loop
4478 Get_Discriminant_Value (
4481 Discriminant_Constraint (Typ)));
4482 Append (New_Comp, Constraints);
4483 Next_Stored_Discriminant (Discriminant);
4487 Make_Subtype_Declaration (Loc,
4488 Defining_Identifier =>
4489 Make_Defining_Identifier (Loc,
4490 New_Internal_Name ('T')),
4491 Subtype_Indication =>
4492 Make_Subtype_Indication (Loc,
4494 New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
4496 Make_Index_Or_Discriminant_Constraint
4497 (Loc, Constraints)));
4499 Insert_Action (N, Decl);
4500 Prepend_Stored_Values (Base_Type (Typ));
4502 Set_Etype (N, Defining_Identifier (Decl));
4505 Rewrite (N, Unchecked_Convert_To (Typ, N));
4508 -- Case where we do not have fewer new discriminants than
4509 -- stored discriminants, so in this case we can simply
4510 -- use the stored discriminants of the subtype.
4513 Prepend_Stored_Values (Typ);
4515 end Generate_Aggregate_For_Derived_Type;
4518 if Is_Tagged_Type (Typ) then
4520 -- The tagged case, _parent and _tag component must be created.
4522 -- Reset null_present unconditionally. tagged records always have
4523 -- at least one field (the tag or the parent)
4525 Set_Null_Record_Present (N, False);
4527 -- When the current aggregate comes from the expansion of an
4528 -- extension aggregate, the parent expr is replaced by an
4529 -- aggregate formed by selected components of this expr
4531 if Present (Parent_Expr)
4532 and then Is_Empty_List (Comps)
4534 Comp := First_Entity (Typ);
4535 while Present (Comp) loop
4537 -- Skip all entities that aren't discriminants or components
4539 if Ekind (Comp) /= E_Discriminant
4540 and then Ekind (Comp) /= E_Component
4544 -- Skip all expander-generated components
4547 not Comes_From_Source (Original_Record_Component (Comp))
4553 Make_Selected_Component (Loc,
4555 Unchecked_Convert_To (Typ,
4556 Duplicate_Subexpr (Parent_Expr, True)),
4558 Selector_Name => New_Occurrence_Of (Comp, Loc));
4561 Make_Component_Association (Loc,
4563 New_List (New_Occurrence_Of (Comp, Loc)),
4567 Analyze_And_Resolve (New_Comp, Etype (Comp));
4574 -- Compute the value for the Tag now, if the type is a root it
4575 -- will be included in the aggregate right away, otherwise it will
4576 -- be propagated to the parent aggregate
4578 if Present (Orig_Tag) then
4579 Tag_Value := Orig_Tag;
4583 Tag_Value := New_Occurrence_Of (Access_Disp_Table (Typ), Loc);
4586 -- For a derived type, an aggregate for the parent is formed with
4587 -- all the inherited components.
4589 if Is_Derived_Type (Typ) then
4592 First_Comp : Node_Id;
4593 Parent_Comps : List_Id;
4594 Parent_Aggr : Node_Id;
4595 Parent_Name : Node_Id;
4598 -- Remove the inherited component association from the
4599 -- aggregate and store them in the parent aggregate
4601 First_Comp := First (Component_Associations (N));
4602 Parent_Comps := New_List;
4604 while Present (First_Comp)
4605 and then Scope (Original_Record_Component (
4606 Entity (First (Choices (First_Comp))))) /= Base_Typ
4611 Append (Comp, Parent_Comps);
4614 Parent_Aggr := Make_Aggregate (Loc,
4615 Component_Associations => Parent_Comps);
4616 Set_Etype (Parent_Aggr, Etype (Base_Type (Typ)));
4618 -- Find the _parent component
4620 Comp := First_Component (Typ);
4621 while Chars (Comp) /= Name_uParent loop
4622 Comp := Next_Component (Comp);
4625 Parent_Name := New_Occurrence_Of (Comp, Loc);
4627 -- Insert the parent aggregate
4629 Prepend_To (Component_Associations (N),
4630 Make_Component_Association (Loc,
4631 Choices => New_List (Parent_Name),
4632 Expression => Parent_Aggr));
4634 -- Expand recursively the parent propagating the right Tag
4636 Expand_Record_Aggregate (
4637 Parent_Aggr, Tag_Value, Parent_Expr);
4640 -- For a root type, the tag component is added (unless compiling
4641 -- for the Java VM, where tags are implicit).
4643 elsif not Java_VM then
4645 Tag_Name : constant Node_Id :=
4646 New_Occurrence_Of (Tag_Component (Typ), Loc);
4647 Typ_Tag : constant Entity_Id := RTE (RE_Tag);
4648 Conv_Node : constant Node_Id :=
4649 Unchecked_Convert_To (Typ_Tag, Tag_Value);
4652 Set_Etype (Conv_Node, Typ_Tag);
4653 Prepend_To (Component_Associations (N),
4654 Make_Component_Association (Loc,
4655 Choices => New_List (Tag_Name),
4656 Expression => Conv_Node));
4661 end Expand_Record_Aggregate;
4663 ----------------------------
4664 -- Has_Default_Init_Comps --
4665 ----------------------------
4667 function Has_Default_Init_Comps (N : Node_Id) return Boolean is
4668 Comps : constant List_Id := Component_Associations (N);
4672 pragma Assert (Nkind (N) = N_Aggregate
4673 or else Nkind (N) = N_Extension_Aggregate);
4679 -- Check if any direct component has default initialized components
4682 while Present (C) loop
4683 if Box_Present (C) then
4690 -- Recursive call in case of aggregate expression
4693 while Present (C) loop
4694 Expr := Expression (C);
4697 and then (Nkind (Expr) = N_Aggregate
4698 or else Nkind (Expr) = N_Extension_Aggregate)
4699 and then Has_Default_Init_Comps (Expr)
4708 end Has_Default_Init_Comps;
4710 --------------------------
4711 -- Is_Delayed_Aggregate --
4712 --------------------------
4714 function Is_Delayed_Aggregate (N : Node_Id) return Boolean is
4715 Node : Node_Id := N;
4716 Kind : Node_Kind := Nkind (Node);
4719 if Kind = N_Qualified_Expression then
4720 Node := Expression (Node);
4721 Kind := Nkind (Node);
4724 if Kind /= N_Aggregate and then Kind /= N_Extension_Aggregate then
4727 return Expansion_Delayed (Node);
4729 end Is_Delayed_Aggregate;
4731 --------------------
4732 -- Late_Expansion --
4733 --------------------
4735 function Late_Expansion
4739 Flist : Node_Id := Empty;
4740 Obj : Entity_Id := Empty) return List_Id is
4742 if Is_Record_Type (Etype (N)) then
4743 return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj);
4744 elsif Is_Array_Type (Etype (N)) then
4746 Build_Array_Aggr_Code
4748 Ctype => Component_Type (Etype (N)),
4749 Index => First_Index (Typ),
4751 Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
4755 pragma Assert (False);
4760 ----------------------------------
4761 -- Make_OK_Assignment_Statement --
4762 ----------------------------------
4764 function Make_OK_Assignment_Statement
4767 Expression : Node_Id) return Node_Id
4770 Set_Assignment_OK (Name);
4771 return Make_Assignment_Statement (Sloc, Name, Expression);
4772 end Make_OK_Assignment_Statement;
4774 -----------------------
4775 -- Number_Of_Choices --
4776 -----------------------
4778 function Number_Of_Choices (N : Node_Id) return Nat is
4782 Nb_Choices : Nat := 0;
4785 if Present (Expressions (N)) then
4789 Assoc := First (Component_Associations (N));
4790 while Present (Assoc) loop
4792 Choice := First (Choices (Assoc));
4793 while Present (Choice) loop
4795 if Nkind (Choice) /= N_Others_Choice then
4796 Nb_Choices := Nb_Choices + 1;
4806 end Number_Of_Choices;
4808 ------------------------------------
4809 -- Packed_Array_Aggregate_Handled --
4810 ------------------------------------
4812 -- The current version of this procedure will handle at compile time
4813 -- any array aggregate that meets these conditions:
4815 -- One dimensional, bit packed
4816 -- Underlying packed type is modular type
4817 -- Bounds are within 32-bit Int range
4818 -- All bounds and values are static
4820 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is
4821 Loc : constant Source_Ptr := Sloc (N);
4822 Typ : constant Entity_Id := Etype (N);
4823 Ctyp : constant Entity_Id := Component_Type (Typ);
4825 Not_Handled : exception;
4826 -- Exception raised if this aggregate cannot be handled
4829 -- For now, handle only one dimensional bit packed arrays
4831 if not Is_Bit_Packed_Array (Typ)
4832 or else Number_Dimensions (Typ) > 1
4833 or else not Is_Modular_Integer_Type (Packed_Array_Type (Typ))
4839 Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
4843 -- Bounds of index type
4847 -- Values of bounds if compile time known
4849 function Get_Component_Val (N : Node_Id) return Uint;
4850 -- Given a expression value N of the component type Ctyp, returns
4851 -- A value of Csiz (component size) bits representing this value.
4852 -- If the value is non-static or any other reason exists why the
4853 -- value cannot be returned, then Not_Handled is raised.
4855 -----------------------
4856 -- Get_Component_Val --
4857 -----------------------
4859 function Get_Component_Val (N : Node_Id) return Uint is
4863 -- We have to analyze the expression here before doing any further
4864 -- processing here. The analysis of such expressions is deferred
4865 -- till expansion to prevent some problems of premature analysis.
4867 Analyze_And_Resolve (N, Ctyp);
4869 -- Must have a compile time value
4871 if not Compile_Time_Known_Value (N) then
4875 Val := Expr_Rep_Value (N);
4877 -- Adjust for bias, and strip proper number of bits
4879 if Has_Biased_Representation (Ctyp) then
4880 Val := Val - Expr_Value (Type_Low_Bound (Ctyp));
4883 return Val mod Uint_2 ** Csiz;
4884 end Get_Component_Val;
4886 -- Here we know we have a one dimensional bit packed array
4889 Get_Index_Bounds (First_Index (Typ), Lo, Hi);
4891 -- Cannot do anything if bounds are dynamic
4893 if not Compile_Time_Known_Value (Lo)
4895 not Compile_Time_Known_Value (Hi)
4900 -- Or are silly out of range of int bounds
4902 Lob := Expr_Value (Lo);
4903 Hib := Expr_Value (Hi);
4905 if not UI_Is_In_Int_Range (Lob)
4907 not UI_Is_In_Int_Range (Hib)
4912 -- At this stage we have a suitable aggregate for handling
4913 -- at compile time (the only remaining checks, are that the
4914 -- values of expressions in the aggregate are compile time
4915 -- known (check performed by Get_Component_Val), and that
4916 -- any subtypes or ranges are statically known.
4918 -- If the aggregate is not fully positional at this stage,
4919 -- then convert it to positional form. Either this will fail,
4920 -- in which case we can do nothing, or it will succeed, in
4921 -- which case we have succeeded in handling the aggregate,
4922 -- or it will stay an aggregate, in which case we have failed
4923 -- to handle this case.
4925 if Present (Component_Associations (N)) then
4926 Convert_To_Positional
4927 (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
4928 return Nkind (N) /= N_Aggregate;
4931 -- Otherwise we are all positional, so convert to proper value
4934 Lov : constant Nat := UI_To_Int (Lob);
4935 Hiv : constant Nat := UI_To_Int (Hib);
4937 Len : constant Nat := Int'Max (0, Hiv - Lov + 1);
4938 -- The length of the array (number of elements)
4940 Aggregate_Val : Uint;
4941 -- Value of aggregate. The value is set in the low order
4942 -- bits of this value. For the little-endian case, the
4943 -- values are stored from low-order to high-order and
4944 -- for the big-endian case the values are stored from
4945 -- high-order to low-order. Note that gigi will take care
4946 -- of the conversions to left justify the value in the big
4947 -- endian case (because of left justified modular type
4948 -- processing), so we do not have to worry about that here.
4951 -- Integer literal for resulting constructed value
4954 -- Shift count from low order for next value
4957 -- Shift increment for loop
4960 -- Next expression from positional parameters of aggregate
4963 -- For little endian, we fill up the low order bits of the
4964 -- target value. For big endian we fill up the high order
4965 -- bits of the target value (which is a left justified
4968 if Bytes_Big_Endian xor Debug_Flag_8 then
4969 Shift := Csiz * (Len - 1);
4976 -- Loop to set the values
4979 Aggregate_Val := Uint_0;
4981 Expr := First (Expressions (N));
4982 Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
4984 for J in 2 .. Len loop
4985 Shift := Shift + Incr;
4988 Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
4992 -- Now we can rewrite with the proper value
4995 Make_Integer_Literal (Loc,
4996 Intval => Aggregate_Val);
4997 Set_Print_In_Hex (Lit);
4999 -- Construct the expression using this literal. Note that it is
5000 -- important to qualify the literal with its proper modular type
5001 -- since universal integer does not have the required range and
5002 -- also this is a left justified modular type, which is important
5003 -- in the big-endian case.
5006 Unchecked_Convert_To (Typ,
5007 Make_Qualified_Expression (Loc,
5009 New_Occurrence_Of (Packed_Array_Type (Typ), Loc),
5010 Expression => Lit)));
5012 Analyze_And_Resolve (N, Typ);
5020 end Packed_Array_Aggregate_Handled;
5022 ----------------------------
5023 -- Has_Mutable_Components --
5024 ----------------------------
5026 function Has_Mutable_Components (Typ : Entity_Id) return Boolean is
5030 Comp := First_Component (Typ);
5032 while Present (Comp) loop
5033 if Is_Record_Type (Etype (Comp))
5034 and then Has_Discriminants (Etype (Comp))
5035 and then not Is_Constrained (Etype (Comp))
5040 Next_Component (Comp);
5044 end Has_Mutable_Components;
5046 ------------------------------
5047 -- Initialize_Discriminants --
5048 ------------------------------
5050 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is
5051 Loc : constant Source_Ptr := Sloc (N);
5052 Bas : constant Entity_Id := Base_Type (Typ);
5053 Par : constant Entity_Id := Etype (Bas);
5054 Decl : constant Node_Id := Parent (Par);
5058 if Is_Tagged_Type (Bas)
5059 and then Is_Derived_Type (Bas)
5060 and then Has_Discriminants (Par)
5061 and then Has_Discriminants (Bas)
5062 and then Number_Discriminants (Bas) /= Number_Discriminants (Par)
5063 and then Nkind (Decl) = N_Full_Type_Declaration
5064 and then Nkind (Type_Definition (Decl)) = N_Record_Definition
5066 (Variant_Part (Component_List (Type_Definition (Decl))))
5067 and then Nkind (N) /= N_Extension_Aggregate
5070 -- Call init proc to set discriminants.
5071 -- There should eventually be a special procedure for this ???
5073 Ref := New_Reference_To (Defining_Identifier (N), Loc);
5074 Insert_Actions_After (N,
5075 Build_Initialization_Call (Sloc (N), Ref, Typ));
5077 end Initialize_Discriminants;
5079 ---------------------------
5080 -- Safe_Slice_Assignment --
5081 ---------------------------
5083 function Safe_Slice_Assignment (N : Node_Id) return Boolean is
5084 Loc : constant Source_Ptr := Sloc (Parent (N));
5085 Pref : constant Node_Id := Prefix (Name (Parent (N)));
5086 Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N)));
5094 -- Generate: for J in Range loop Pref (J) := Expr; end loop;
5096 if Comes_From_Source (N)
5097 and then No (Expressions (N))
5098 and then Nkind (First (Choices (First (Component_Associations (N)))))
5102 Expression (First (Component_Associations (N)));
5103 L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
5106 Make_Iteration_Scheme (Loc,
5107 Loop_Parameter_Specification =>
5108 Make_Loop_Parameter_Specification
5110 Defining_Identifier => L_J,
5111 Discrete_Subtype_Definition => Relocate_Node (Range_Node)));
5114 Make_Assignment_Statement (Loc,
5116 Make_Indexed_Component (Loc,
5117 Prefix => Relocate_Node (Pref),
5118 Expressions => New_List (New_Occurrence_Of (L_J, Loc))),
5119 Expression => Relocate_Node (Expr));
5121 -- Construct the final loop
5124 Make_Implicit_Loop_Statement
5125 (Node => Parent (N),
5126 Identifier => Empty,
5127 Iteration_Scheme => L_Iter,
5128 Statements => New_List (L_Body));
5130 -- Set type of aggregate to be type of lhs in assignment,
5131 -- to suppress redundant length checks.
5133 Set_Etype (N, Etype (Name (Parent (N))));
5135 Rewrite (Parent (N), Stat);
5136 Analyze (Parent (N));
5142 end Safe_Slice_Assignment;
5144 ---------------------
5145 -- Sort_Case_Table --
5146 ---------------------
5148 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
5149 L : constant Int := Case_Table'First;
5150 U : constant Int := Case_Table'Last;
5159 T := Case_Table (K + 1);
5163 and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
5164 Expr_Value (T.Choice_Lo)
5166 Case_Table (J) := Case_Table (J - 1);
5170 Case_Table (J) := T;
5173 end Sort_Case_Table;