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 Rident; use Rident;
45 with Rtsfind; use Rtsfind;
46 with Ttypes; use Ttypes;
48 with Sem_Ch3; use Sem_Ch3;
49 with Sem_Eval; use Sem_Eval;
50 with Sem_Res; use Sem_Res;
51 with Sem_Util; use Sem_Util;
52 with Sinfo; use Sinfo;
53 with Snames; use Snames;
54 with Stand; use Stand;
55 with Tbuild; use Tbuild;
56 with Uintp; use Uintp;
58 package body Exp_Aggr is
60 type Case_Bounds is record
63 Choice_Node : Node_Id;
66 type Case_Table_Type is array (Nat range <>) of Case_Bounds;
67 -- Table type used by Check_Case_Choices procedure
69 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
70 -- Sort the Case Table using the Lower Bound of each Choice as the key.
71 -- A simple insertion sort is used since the number of choices in a case
72 -- statement of variant part will usually be small and probably in near
75 function Has_Default_Init_Comps (N : Node_Id) return Boolean;
76 -- N is an aggregate (record or array). Checks the presence of default
77 -- initialization (<>) in any component (Ada 0Y: AI-287)
79 ------------------------------------------------------
80 -- Local subprograms for Record Aggregate Expansion --
81 ------------------------------------------------------
83 procedure Expand_Record_Aggregate
85 Orig_Tag : Node_Id := Empty;
86 Parent_Expr : Node_Id := Empty);
87 -- This is the top level procedure for record aggregate expansion.
88 -- Expansion for record aggregates needs expand aggregates for tagged
89 -- record types. Specifically Expand_Record_Aggregate adds the Tag
90 -- field in front of the Component_Association list that was created
91 -- during resolution by Resolve_Record_Aggregate.
93 -- N is the record aggregate node.
94 -- Orig_Tag is the value of the Tag that has to be provided for this
95 -- specific aggregate. It carries the tag corresponding to the type
96 -- of the outermost aggregate during the recursive expansion
97 -- Parent_Expr is the ancestor part of the original extension
100 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
101 -- N is an N_Aggregate of a N_Extension_Aggregate. Typ is the type of
102 -- the aggregate. Transform the given aggregate into a sequence of
103 -- assignments component per component.
105 function Build_Record_Aggr_Code
109 Flist : Node_Id := Empty;
110 Obj : Entity_Id := Empty;
111 Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id;
112 -- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type
113 -- of the aggregate. Target is an expression containing the
114 -- location on which the component by component assignments will
115 -- take place. Returns the list of assignments plus all other
116 -- adjustments needed for tagged and controlled types. Flist is an
117 -- expression representing the finalization list on which to
118 -- attach the controlled components if any. Obj is present in the
119 -- object declaration and dynamic allocation cases, it contains
120 -- an entity that allows to know if the value being created needs to be
121 -- attached to the final list in case of pragma finalize_Storage_Only.
122 -- Is_Limited_Ancestor_Expansion indicates that the function has been
123 -- called recursively to expand the limited ancestor to avoid copying it.
125 function Has_Mutable_Components (Typ : Entity_Id) return Boolean;
126 -- Return true if one of the component is of a discriminated type with
127 -- defaults. An aggregate for a type with mutable components must be
128 -- expanded into individual assignments.
130 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);
131 -- If the type of the aggregate is a type extension with renamed discrimi-
132 -- nants, we must initialize the hidden discriminants of the parent.
133 -- Otherwise, the target object must not be initialized. The discriminants
134 -- are initialized by calling the initialization procedure for the type.
135 -- This is incorrect if the initialization of other components has any
136 -- side effects. We restrict this call to the case where the parent type
137 -- has a variant part, because this is the only case where the hidden
138 -- discriminants are accessed, namely when calling discriminant checking
139 -- functions of the parent type, and when applying a stream attribute to
140 -- an object of the derived type.
142 -----------------------------------------------------
143 -- Local Subprograms for Array Aggregate Expansion --
144 -----------------------------------------------------
146 procedure Convert_To_Positional
148 Max_Others_Replicate : Nat := 5;
149 Handle_Bit_Packed : Boolean := False);
150 -- If possible, convert named notation to positional notation. This
151 -- conversion is possible only in some static cases. If the conversion
152 -- is possible, then N is rewritten with the analyzed converted
153 -- aggregate. The parameter Max_Others_Replicate controls the maximum
154 -- number of values corresponding to an others choice that will be
155 -- converted to positional notation (the default of 5 is the normal
156 -- limit, and reflects the fact that normally the loop is better than
157 -- a lot of separate assignments). Note that this limit gets overridden
158 -- in any case if either of the restrictions No_Elaboration_Code or
159 -- No_Implicit_Loops is set. The parameter Handle_Bit_Packed is usually
160 -- set False (since we do not expect the back end to handle bit packed
161 -- arrays, so the normal case of conversion is pointless), but in the
162 -- special case of a call from Packed_Array_Aggregate_Handled, we set
163 -- this parameter to True, since these are cases we handle in there.
165 procedure Expand_Array_Aggregate (N : Node_Id);
166 -- This is the top-level routine to perform array aggregate expansion.
167 -- N is the N_Aggregate node to be expanded.
169 function Backend_Processing_Possible (N : Node_Id) return Boolean;
170 -- This function checks if array aggregate N can be processed directly
171 -- by Gigi. If this is the case True is returned.
173 function Build_Array_Aggr_Code
178 Scalar_Comp : Boolean;
179 Indices : List_Id := No_List;
180 Flist : Node_Id := Empty) return List_Id;
181 -- This recursive routine returns a list of statements containing the
182 -- loops and assignments that are needed for the expansion of the array
185 -- N is the (sub-)aggregate node to be expanded into code. This node
186 -- has been fully analyzed, and its Etype is properly set.
188 -- Index is the index node corresponding to the array sub-aggregate N.
190 -- Into is the target expression into which we are copying the aggregate.
191 -- Note that this node may not have been analyzed yet, and so the Etype
192 -- field may not be set.
194 -- Scalar_Comp is True if the component type of the aggregate is scalar.
196 -- Indices is the current list of expressions used to index the
197 -- object we are writing into.
199 -- Flist is an expression representing the finalization list on which
200 -- to attach the controlled components if any.
202 function Number_Of_Choices (N : Node_Id) return Nat;
203 -- Returns the number of discrete choices (not including the others choice
204 -- if present) contained in (sub-)aggregate N.
206 function Late_Expansion
210 Flist : Node_Id := Empty;
211 Obj : Entity_Id := Empty) return List_Id;
212 -- N is a nested (record or array) aggregate that has been marked
213 -- with 'Delay_Expansion'. Typ is the expected type of the
214 -- aggregate and Target is a (duplicable) expression that will
215 -- hold the result of the aggregate expansion. Flist is the
216 -- finalization list to be used to attach controlled
217 -- components. 'Obj' when non empty, carries the original object
218 -- being initialized in order to know if it needs to be attached
219 -- to the previous parameter which may not be the case when
220 -- Finalize_Storage_Only is set. Basically this procedure is used
221 -- to implement top-down expansions of nested aggregates. This is
222 -- necessary for avoiding temporaries at each level as well as for
223 -- propagating the right internal finalization list.
225 function Make_OK_Assignment_Statement
228 Expression : Node_Id) return Node_Id;
229 -- This is like Make_Assignment_Statement, except that Assignment_OK
230 -- is set in the left operand. All assignments built by this unit
231 -- use this routine. This is needed to deal with assignments to
232 -- initialized constants that are done in place.
234 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
235 -- Given an array aggregate, this function handles the case of a packed
236 -- array aggregate with all constant values, where the aggregate can be
237 -- evaluated at compile time. If this is possible, then N is rewritten
238 -- to be its proper compile time value with all the components properly
239 -- assembled. The expression is analyzed and resolved and True is
240 -- returned. If this transformation is not possible, N is unchanged
241 -- and False is returned
243 function Safe_Slice_Assignment (N : Node_Id) return Boolean;
244 -- If a slice assignment has an aggregate with a single others_choice,
245 -- the assignment can be done in place even if bounds are not static,
246 -- by converting it into a loop over the discrete range of the slice.
248 ---------------------------------
249 -- Backend_Processing_Possible --
250 ---------------------------------
252 -- Backend processing by Gigi/gcc is possible only if all the following
253 -- conditions are met:
255 -- 1. N is fully positional
257 -- 2. N is not a bit-packed array aggregate;
259 -- 3. The size of N's array type must be known at compile time. Note
260 -- that this implies that the component size is also known
262 -- 4. The array type of N does not follow the Fortran layout convention
263 -- or if it does it must be 1 dimensional.
265 -- 5. The array component type is tagged, which may necessitate
266 -- reassignment of proper tags.
268 -- 6. The array component type might have unaligned bit components
270 function Backend_Processing_Possible (N : Node_Id) return Boolean is
271 Typ : constant Entity_Id := Etype (N);
272 -- Typ is the correct constrained array subtype of the aggregate.
274 function Static_Check (N : Node_Id; Index : Node_Id) return Boolean;
275 -- Recursively checks that N is fully positional, returns true if so.
281 function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is
285 -- Check for component associations
287 if Present (Component_Associations (N)) then
291 -- Recurse to check subaggregates, which may appear in qualified
292 -- expressions. If delayed, the front-end will have to expand.
294 Expr := First (Expressions (N));
296 while Present (Expr) loop
298 if Is_Delayed_Aggregate (Expr) then
302 if Present (Next_Index (Index))
303 and then not Static_Check (Expr, Next_Index (Index))
314 -- Start of processing for Backend_Processing_Possible
317 -- Checks 2 (array must not be bit packed)
319 if Is_Bit_Packed_Array (Typ) then
323 -- Checks 4 (array must not be multi-dimensional Fortran case)
325 if Convention (Typ) = Convention_Fortran
326 and then Number_Dimensions (Typ) > 1
331 -- Checks 3 (size of array must be known at compile time)
333 if not Size_Known_At_Compile_Time (Typ) then
337 -- Checks 1 (aggregate must be fully positional)
339 if not Static_Check (N, First_Index (Typ)) then
343 -- Checks 5 (if the component type is tagged, then we may need
344 -- to do tag adjustments; perhaps this should be refined to
345 -- check for any component associations that actually
346 -- need tag adjustment, along the lines of the test that's
347 -- done in Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
348 -- for record aggregates with tagged components, but not
349 -- clear whether it's worthwhile ???; in the case of the
350 -- JVM, object tags are handled implicitly)
352 if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then
356 -- Checks 6 (component type must not have bit aligned components)
358 if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then
362 -- Backend processing is possible
364 Set_Compile_Time_Known_Aggregate (N, True);
365 Set_Size_Known_At_Compile_Time (Etype (N), True);
367 end Backend_Processing_Possible;
369 ---------------------------
370 -- Build_Array_Aggr_Code --
371 ---------------------------
373 -- The code that we generate from a one dimensional aggregate is
375 -- 1. If the sub-aggregate contains discrete choices we
377 -- (a) Sort the discrete choices
379 -- (b) Otherwise for each discrete choice that specifies a range we
380 -- emit a loop. If a range specifies a maximum of three values, or
381 -- we are dealing with an expression we emit a sequence of
382 -- assignments instead of a loop.
384 -- (c) Generate the remaining loops to cover the others choice if any.
386 -- 2. If the aggregate contains positional elements we
388 -- (a) translate the positional elements in a series of assignments.
390 -- (b) Generate a final loop to cover the others choice if any.
391 -- Note that this final loop has to be a while loop since the case
393 -- L : Integer := Integer'Last;
394 -- H : Integer := Integer'Last;
395 -- A : array (L .. H) := (1, others =>0);
397 -- cannot be handled by a for loop. Thus for the following
399 -- array (L .. H) := (.. positional elements.., others =>E);
401 -- we always generate something like:
403 -- J : Index_Type := Index_Of_Last_Positional_Element;
405 -- J := Index_Base'Succ (J)
409 function Build_Array_Aggr_Code
414 Scalar_Comp : Boolean;
415 Indices : List_Id := No_List;
416 Flist : Node_Id := Empty) return List_Id
418 Loc : constant Source_Ptr := Sloc (N);
419 Index_Base : constant Entity_Id := Base_Type (Etype (Index));
420 Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base);
421 Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);
423 function Add (Val : Int; To : Node_Id) return Node_Id;
424 -- Returns an expression where Val is added to expression To,
425 -- unless To+Val is provably out of To's base type range.
426 -- To must be an already analyzed expression.
428 function Empty_Range (L, H : Node_Id) return Boolean;
429 -- Returns True if the range defined by L .. H is certainly empty.
431 function Equal (L, H : Node_Id) return Boolean;
432 -- Returns True if L = H for sure.
434 function Index_Base_Name return Node_Id;
435 -- Returns a new reference to the index type name.
437 function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
438 -- Ind must be a side-effect free expression. If the input aggregate
439 -- N to Build_Loop contains no sub-aggregates, then this function
440 -- returns the assignment statement:
442 -- Into (Indices, Ind) := Expr;
444 -- Otherwise we call Build_Code recursively.
446 -- Ada 0Y (AI-287): In case of default initialized component, Expr is
447 -- empty and we generate a call to the corresponding IP subprogram.
449 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
450 -- Nodes L and H must be side-effect free expressions.
451 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
452 -- This routine returns the for loop statement
454 -- for J in Index_Base'(L) .. Index_Base'(H) loop
455 -- Into (Indices, J) := Expr;
458 -- Otherwise we call Build_Code recursively.
459 -- As an optimization if the loop covers 3 or less scalar elements we
460 -- generate a sequence of assignments.
462 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
463 -- Nodes L and H must be side-effect free expressions.
464 -- If the input aggregate N to Build_Loop contains no sub-aggregates,
465 -- This routine returns the while loop statement
467 -- J : Index_Base := L;
469 -- J := Index_Base'Succ (J);
470 -- Into (Indices, J) := Expr;
473 -- Otherwise we call Build_Code recursively
475 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
476 function Local_Expr_Value (E : Node_Id) return Uint;
477 -- These two Local routines are used to replace the corresponding ones
478 -- in sem_eval because while processing the bounds of an aggregate with
479 -- discrete choices whose index type is an enumeration, we build static
480 -- expressions not recognized by Compile_Time_Known_Value as such since
481 -- they have not yet been analyzed and resolved. All the expressions in
482 -- question are things like Index_Base_Name'Val (Const) which we can
483 -- easily recognize as being constant.
489 function Add (Val : Int; To : Node_Id) return Node_Id is
494 U_Val : constant Uint := UI_From_Int (Val);
497 -- Note: do not try to optimize the case of Val = 0, because
498 -- we need to build a new node with the proper Sloc value anyway.
500 -- First test if we can do constant folding
502 if Local_Compile_Time_Known_Value (To) then
503 U_To := Local_Expr_Value (To) + Val;
505 -- Determine if our constant is outside the range of the index.
506 -- If so return an Empty node. This empty node will be caught
507 -- by Empty_Range below.
509 if Compile_Time_Known_Value (Index_Base_L)
510 and then U_To < Expr_Value (Index_Base_L)
514 elsif Compile_Time_Known_Value (Index_Base_H)
515 and then U_To > Expr_Value (Index_Base_H)
520 Expr_Pos := Make_Integer_Literal (Loc, U_To);
521 Set_Is_Static_Expression (Expr_Pos);
523 if not Is_Enumeration_Type (Index_Base) then
526 -- If we are dealing with enumeration return
527 -- Index_Base'Val (Expr_Pos)
531 Make_Attribute_Reference
533 Prefix => Index_Base_Name,
534 Attribute_Name => Name_Val,
535 Expressions => New_List (Expr_Pos));
541 -- If we are here no constant folding possible
543 if not Is_Enumeration_Type (Index_Base) then
546 Left_Opnd => Duplicate_Subexpr (To),
547 Right_Opnd => Make_Integer_Literal (Loc, U_Val));
549 -- If we are dealing with enumeration return
550 -- Index_Base'Val (Index_Base'Pos (To) + Val)
554 Make_Attribute_Reference
556 Prefix => Index_Base_Name,
557 Attribute_Name => Name_Pos,
558 Expressions => New_List (Duplicate_Subexpr (To)));
563 Right_Opnd => Make_Integer_Literal (Loc, U_Val));
566 Make_Attribute_Reference
568 Prefix => Index_Base_Name,
569 Attribute_Name => Name_Val,
570 Expressions => New_List (Expr_Pos));
580 function Empty_Range (L, H : Node_Id) return Boolean is
581 Is_Empty : Boolean := False;
586 -- First check if L or H were already detected as overflowing the
587 -- index base range type by function Add above. If this is so Add
588 -- returns the empty node.
590 if No (L) or else No (H) then
597 -- L > H range is empty
603 -- B_L > H range must be empty
609 -- L > B_H range must be empty
613 High := Index_Base_H;
616 if Local_Compile_Time_Known_Value (Low)
617 and then Local_Compile_Time_Known_Value (High)
620 UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High));
633 function Equal (L, H : Node_Id) return Boolean is
638 elsif Local_Compile_Time_Known_Value (L)
639 and then Local_Compile_Time_Known_Value (H)
641 return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H));
651 function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
652 L : constant List_Id := New_List;
656 New_Indices : List_Id;
657 Indexed_Comp : Node_Id;
659 Comp_Type : Entity_Id := Empty;
661 function Add_Loop_Actions (Lis : List_Id) return List_Id;
662 -- Collect insert_actions generated in the construction of a
663 -- loop, and prepend them to the sequence of assignments to
664 -- complete the eventual body of the loop.
666 ----------------------
667 -- Add_Loop_Actions --
668 ----------------------
670 function Add_Loop_Actions (Lis : List_Id) return List_Id is
674 -- Ada 0Y (AI-287): Do nothing else in case of default
675 -- initialized component.
677 if not Present (Expr) then
680 elsif Nkind (Parent (Expr)) = N_Component_Association
681 and then Present (Loop_Actions (Parent (Expr)))
683 Append_List (Lis, Loop_Actions (Parent (Expr)));
684 Res := Loop_Actions (Parent (Expr));
685 Set_Loop_Actions (Parent (Expr), No_List);
691 end Add_Loop_Actions;
693 -- Start of processing for Gen_Assign
697 New_Indices := New_List;
699 New_Indices := New_Copy_List_Tree (Indices);
702 Append_To (New_Indices, Ind);
704 if Present (Flist) then
705 F := New_Copy_Tree (Flist);
707 elsif Present (Etype (N)) and then Controlled_Type (Etype (N)) then
708 if Is_Entity_Name (Into)
709 and then Present (Scope (Entity (Into)))
711 F := Find_Final_List (Scope (Entity (Into)));
713 F := Find_Final_List (Current_Scope);
719 if Present (Next_Index (Index)) then
722 Build_Array_Aggr_Code
725 Index => Next_Index (Index),
727 Scalar_Comp => Scalar_Comp,
728 Indices => New_Indices,
732 -- If we get here then we are at a bottom-level (sub-)aggregate
736 (Make_Indexed_Component (Loc,
737 Prefix => New_Copy_Tree (Into),
738 Expressions => New_Indices));
740 Set_Assignment_OK (Indexed_Comp);
742 -- Ada 0Y (AI-287): In case of default initialized component, Expr
743 -- is not present (and therefore we also initialize Expr_Q to empty).
745 if not Present (Expr) then
747 elsif Nkind (Expr) = N_Qualified_Expression then
748 Expr_Q := Expression (Expr);
753 if Present (Etype (N))
754 and then Etype (N) /= Any_Composite
756 Comp_Type := Component_Type (Etype (N));
757 pragma Assert (Comp_Type = Ctype); -- AI-287
759 elsif Present (Next (First (New_Indices))) then
761 -- Ada 0Y (AI-287): Do nothing in case of default initialized
762 -- component because we have received the component type in
763 -- the formal parameter Ctype.
765 -- ??? Some assert pragmas have been added to check if this new
766 -- formal can be used to replace this code in all cases.
768 if Present (Expr) then
770 -- This is a multidimensional array. Recover the component
771 -- type from the outermost aggregate, because subaggregates
772 -- do not have an assigned type.
775 P : Node_Id := Parent (Expr);
778 while Present (P) loop
779 if Nkind (P) = N_Aggregate
780 and then Present (Etype (P))
782 Comp_Type := Component_Type (Etype (P));
790 pragma Assert (Comp_Type = Ctype); -- AI-287
795 -- Ada 0Y (AI-287): We only analyze the expression in case of non
796 -- default initialized components (otherwise Expr_Q is not present).
799 and then (Nkind (Expr_Q) = N_Aggregate
800 or else Nkind (Expr_Q) = N_Extension_Aggregate)
802 -- At this stage the Expression may not have been
803 -- analyzed yet because the array aggregate code has not
804 -- been updated to use the Expansion_Delayed flag and
805 -- avoid analysis altogether to solve the same problem
806 -- (see Resolve_Aggr_Expr). So let us do the analysis of
807 -- non-array aggregates now in order to get the value of
808 -- Expansion_Delayed flag for the inner aggregate ???
810 if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then
811 Analyze_And_Resolve (Expr_Q, Comp_Type);
814 if Is_Delayed_Aggregate (Expr_Q) then
817 Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp, F));
821 -- Ada 0Y (AI-287): In case of default initialized component, call
822 -- the initialization subprogram associated with the component type.
824 if not Present (Expr) then
827 Build_Initialization_Call (Loc,
828 Id_Ref => Indexed_Comp,
830 With_Default_Init => True));
834 -- Now generate the assignment with no associated controlled
835 -- actions since the target of the assignment may not have
836 -- been initialized, it is not possible to Finalize it as
837 -- expected by normal controlled assignment. The rest of the
838 -- controlled actions are done manually with the proper
839 -- finalization list coming from the context.
842 Make_OK_Assignment_Statement (Loc,
843 Name => Indexed_Comp,
844 Expression => New_Copy_Tree (Expr));
846 if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
847 Set_No_Ctrl_Actions (A);
852 -- Adjust the tag if tagged (because of possible view
853 -- conversions), unless compiling for the Java VM
854 -- where tags are implicit.
856 if Present (Comp_Type)
857 and then Is_Tagged_Type (Comp_Type)
861 Make_OK_Assignment_Statement (Loc,
863 Make_Selected_Component (Loc,
864 Prefix => New_Copy_Tree (Indexed_Comp),
866 New_Reference_To (Tag_Component (Comp_Type), Loc)),
869 Unchecked_Convert_To (RTE (RE_Tag),
871 Access_Disp_Table (Comp_Type), Loc)));
876 -- Adjust and Attach the component to the proper final list
877 -- which can be the controller of the outer record object or
878 -- the final list associated with the scope
880 if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
883 Ref => New_Copy_Tree (Indexed_Comp),
886 With_Attach => Make_Integer_Literal (Loc, 1)));
890 return Add_Loop_Actions (L);
897 function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
901 -- Index_Base'(L) .. Index_Base'(H)
903 L_Iteration_Scheme : Node_Id;
904 -- L_J in Index_Base'(L) .. Index_Base'(H)
907 -- The statements to execute in the loop
909 S : constant List_Id := New_List;
910 -- List of statements
913 -- Copy of expression tree, used for checking purposes
916 -- If loop bounds define an empty range return the null statement
918 if Empty_Range (L, H) then
919 Append_To (S, Make_Null_Statement (Loc));
921 -- Ada 0Y (AI-287): Nothing else need to be done in case of
922 -- default initialized component.
924 if not Present (Expr) then
928 -- The expression must be type-checked even though no component
929 -- of the aggregate will have this value. This is done only for
930 -- actual components of the array, not for subaggregates. Do
931 -- the check on a copy, because the expression may be shared
932 -- among several choices, some of which might be non-null.
934 if Present (Etype (N))
935 and then Is_Array_Type (Etype (N))
936 and then No (Next_Index (Index))
938 Expander_Mode_Save_And_Set (False);
939 Tcopy := New_Copy_Tree (Expr);
940 Set_Parent (Tcopy, N);
941 Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
942 Expander_Mode_Restore;
948 -- If loop bounds are the same then generate an assignment
950 elsif Equal (L, H) then
951 return Gen_Assign (New_Copy_Tree (L), Expr);
953 -- If H - L <= 2 then generate a sequence of assignments
954 -- when we are processing the bottom most aggregate and it contains
955 -- scalar components.
957 elsif No (Next_Index (Index))
959 and then Local_Compile_Time_Known_Value (L)
960 and then Local_Compile_Time_Known_Value (H)
961 and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
964 Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
965 Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
967 if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then
968 Append_List_To (S, Gen_Assign (Add (2, To => L), Expr));
974 -- Otherwise construct the loop, starting with the loop index L_J
976 L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
978 -- Construct "L .. H"
983 Low_Bound => Make_Qualified_Expression
985 Subtype_Mark => Index_Base_Name,
987 High_Bound => Make_Qualified_Expression
989 Subtype_Mark => Index_Base_Name,
992 -- Construct "for L_J in Index_Base range L .. H"
994 L_Iteration_Scheme :=
995 Make_Iteration_Scheme
997 Loop_Parameter_Specification =>
998 Make_Loop_Parameter_Specification
1000 Defining_Identifier => L_J,
1001 Discrete_Subtype_Definition => L_Range));
1003 -- Construct the statements to execute in the loop body
1005 L_Body := Gen_Assign (New_Reference_To (L_J, Loc), Expr);
1007 -- Construct the final loop
1009 Append_To (S, Make_Implicit_Loop_Statement
1011 Identifier => Empty,
1012 Iteration_Scheme => L_Iteration_Scheme,
1013 Statements => L_Body));
1022 -- The code built is
1024 -- W_J : Index_Base := L;
1025 -- while W_J < H loop
1026 -- W_J := Index_Base'Succ (W);
1030 function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is
1034 -- W_J : Base_Type := L;
1036 W_Iteration_Scheme : Node_Id;
1039 W_Index_Succ : Node_Id;
1040 -- Index_Base'Succ (J)
1042 W_Increment : Node_Id;
1043 -- W_J := Index_Base'Succ (W)
1045 W_Body : constant List_Id := New_List;
1046 -- The statements to execute in the loop
1048 S : constant List_Id := New_List;
1049 -- list of statement
1052 -- If loop bounds define an empty range or are equal return null
1054 if Empty_Range (L, H) or else Equal (L, H) then
1055 Append_To (S, Make_Null_Statement (Loc));
1059 -- Build the decl of W_J
1061 W_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
1063 Make_Object_Declaration
1065 Defining_Identifier => W_J,
1066 Object_Definition => Index_Base_Name,
1069 -- Theoretically we should do a New_Copy_Tree (L) here, but we know
1070 -- that in this particular case L is a fresh Expr generated by
1071 -- Add which we are the only ones to use.
1073 Append_To (S, W_Decl);
1075 -- Construct " while W_J < H"
1077 W_Iteration_Scheme :=
1078 Make_Iteration_Scheme
1080 Condition => Make_Op_Lt
1082 Left_Opnd => New_Reference_To (W_J, Loc),
1083 Right_Opnd => New_Copy_Tree (H)));
1085 -- Construct the statements to execute in the loop body
1088 Make_Attribute_Reference
1090 Prefix => Index_Base_Name,
1091 Attribute_Name => Name_Succ,
1092 Expressions => New_List (New_Reference_To (W_J, Loc)));
1095 Make_OK_Assignment_Statement
1097 Name => New_Reference_To (W_J, Loc),
1098 Expression => W_Index_Succ);
1100 Append_To (W_Body, W_Increment);
1101 Append_List_To (W_Body,
1102 Gen_Assign (New_Reference_To (W_J, Loc), Expr));
1104 -- Construct the final loop
1106 Append_To (S, Make_Implicit_Loop_Statement
1108 Identifier => Empty,
1109 Iteration_Scheme => W_Iteration_Scheme,
1110 Statements => W_Body));
1115 ---------------------
1116 -- Index_Base_Name --
1117 ---------------------
1119 function Index_Base_Name return Node_Id is
1121 return New_Reference_To (Index_Base, Sloc (N));
1122 end Index_Base_Name;
1124 ------------------------------------
1125 -- Local_Compile_Time_Known_Value --
1126 ------------------------------------
1128 function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is
1130 return Compile_Time_Known_Value (E)
1132 (Nkind (E) = N_Attribute_Reference
1133 and then Attribute_Name (E) = Name_Val
1134 and then Compile_Time_Known_Value (First (Expressions (E))));
1135 end Local_Compile_Time_Known_Value;
1137 ----------------------
1138 -- Local_Expr_Value --
1139 ----------------------
1141 function Local_Expr_Value (E : Node_Id) return Uint is
1143 if Compile_Time_Known_Value (E) then
1144 return Expr_Value (E);
1146 return Expr_Value (First (Expressions (E)));
1148 end Local_Expr_Value;
1150 -- Build_Array_Aggr_Code Variables
1157 Others_Expr : Node_Id := Empty;
1158 Others_Mbox_Present : Boolean := False;
1160 Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
1161 Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
1162 -- The aggregate bounds of this specific sub-aggregate. Note that if
1163 -- the code generated by Build_Array_Aggr_Code is executed then these
1164 -- bounds are OK. Otherwise a Constraint_Error would have been raised.
1166 Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L);
1167 Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
1168 -- After Duplicate_Subexpr these are side-effect free.
1173 Nb_Choices : Nat := 0;
1174 Table : Case_Table_Type (1 .. Number_Of_Choices (N));
1175 -- Used to sort all the different choice values
1178 -- Number of elements in the positional aggregate
1180 New_Code : constant List_Id := New_List;
1182 -- Start of processing for Build_Array_Aggr_Code
1185 -- First before we start, a special case. if we have a bit packed
1186 -- array represented as a modular type, then clear the value to
1187 -- zero first, to ensure that unused bits are properly cleared.
1192 and then Is_Bit_Packed_Array (Typ)
1193 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ))
1195 Append_To (New_Code,
1196 Make_Assignment_Statement (Loc,
1197 Name => New_Copy_Tree (Into),
1199 Unchecked_Convert_To (Typ,
1200 Make_Integer_Literal (Loc, Uint_0))));
1204 -- STEP 1: Process component associations
1205 -- For those associations that may generate a loop, initialize
1206 -- Loop_Actions to collect inserted actions that may be crated.
1208 if No (Expressions (N)) then
1210 -- STEP 1 (a): Sort the discrete choices
1212 Assoc := First (Component_Associations (N));
1213 while Present (Assoc) loop
1214 Choice := First (Choices (Assoc));
1215 while Present (Choice) loop
1216 if Nkind (Choice) = N_Others_Choice then
1217 Set_Loop_Actions (Assoc, New_List);
1219 if Box_Present (Assoc) then
1220 Others_Mbox_Present := True;
1222 Others_Expr := Expression (Assoc);
1227 Get_Index_Bounds (Choice, Low, High);
1230 Set_Loop_Actions (Assoc, New_List);
1233 Nb_Choices := Nb_Choices + 1;
1234 if Box_Present (Assoc) then
1235 Table (Nb_Choices) := (Choice_Lo => Low,
1237 Choice_Node => Empty);
1239 Table (Nb_Choices) := (Choice_Lo => Low,
1241 Choice_Node => Expression (Assoc));
1249 -- If there is more than one set of choices these must be static
1250 -- and we can therefore sort them. Remember that Nb_Choices does not
1251 -- account for an others choice.
1253 if Nb_Choices > 1 then
1254 Sort_Case_Table (Table);
1257 -- STEP 1 (b): take care of the whole set of discrete choices.
1259 for J in 1 .. Nb_Choices loop
1260 Low := Table (J).Choice_Lo;
1261 High := Table (J).Choice_Hi;
1262 Expr := Table (J).Choice_Node;
1263 Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
1266 -- STEP 1 (c): generate the remaining loops to cover others choice
1267 -- We don't need to generate loops over empty gaps, but if there is
1268 -- a single empty range we must analyze the expression for semantics
1270 if Present (Others_Expr) or else Others_Mbox_Present then
1272 First : Boolean := True;
1275 for J in 0 .. Nb_Choices loop
1279 Low := Add (1, To => Table (J).Choice_Hi);
1282 if J = Nb_Choices then
1285 High := Add (-1, To => Table (J + 1).Choice_Lo);
1288 -- If this is an expansion within an init proc, make
1289 -- sure that discriminant references are replaced by
1290 -- the corresponding discriminal.
1292 if Inside_Init_Proc then
1293 if Is_Entity_Name (Low)
1294 and then Ekind (Entity (Low)) = E_Discriminant
1296 Set_Entity (Low, Discriminal (Entity (Low)));
1299 if Is_Entity_Name (High)
1300 and then Ekind (Entity (High)) = E_Discriminant
1302 Set_Entity (High, Discriminal (Entity (High)));
1307 or else not Empty_Range (Low, High)
1311 (Gen_Loop (Low, High, Others_Expr), To => New_Code);
1317 -- STEP 2: Process positional components
1320 -- STEP 2 (a): Generate the assignments for each positional element
1321 -- Note that here we have to use Aggr_L rather than Aggr_Low because
1322 -- Aggr_L is analyzed and Add wants an analyzed expression.
1324 Expr := First (Expressions (N));
1327 while Present (Expr) loop
1328 Nb_Elements := Nb_Elements + 1;
1329 Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr),
1334 -- STEP 2 (b): Generate final loop if an others choice is present
1335 -- Here Nb_Elements gives the offset of the last positional element.
1337 if Present (Component_Associations (N)) then
1338 Assoc := Last (Component_Associations (N));
1342 if Box_Present (Assoc) then
1343 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1348 Expr := Expression (Assoc);
1350 Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
1359 end Build_Array_Aggr_Code;
1361 ----------------------------
1362 -- Build_Record_Aggr_Code --
1363 ----------------------------
1365 function Build_Record_Aggr_Code
1369 Flist : Node_Id := Empty;
1370 Obj : Entity_Id := Empty;
1371 Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id
1373 Loc : constant Source_Ptr := Sloc (N);
1374 L : constant List_Id := New_List;
1375 Start_L : constant List_Id := New_List;
1376 N_Typ : constant Entity_Id := Etype (N);
1382 Comp_Type : Entity_Id;
1383 Selector : Entity_Id;
1384 Comp_Expr : Node_Id;
1387 Internal_Final_List : Node_Id;
1389 -- If this is an internal aggregate, the External_Final_List is an
1390 -- expression for the controller record of the enclosing type.
1391 -- If the current aggregate has several controlled components, this
1392 -- expression will appear in several calls to attach to the finali-
1393 -- zation list, and it must not be shared.
1395 External_Final_List : Node_Id;
1396 Ancestor_Is_Expression : Boolean := False;
1397 Ancestor_Is_Subtype_Mark : Boolean := False;
1399 Init_Typ : Entity_Id := Empty;
1402 function Get_Constraint_Association (T : Entity_Id) return Node_Id;
1403 -- Returns the first discriminant association in the constraint
1404 -- associated with T, if any, otherwise returns Empty.
1406 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
1407 -- Returns the value that the given discriminant of an ancestor
1408 -- type should receive (in the absence of a conflict with the
1409 -- value provided by an ancestor part of an extension aggregate).
1411 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id);
1412 -- Check that each of the discriminant values defined by the
1413 -- ancestor part of an extension aggregate match the corresponding
1414 -- values provided by either an association of the aggregate or
1415 -- by the constraint imposed by a parent type (RM95-4.3.2(8)).
1417 function Init_Controller
1422 Init_Pr : Boolean) return List_Id;
1423 -- returns the list of statements necessary to initialize the internal
1424 -- controller of the (possible) ancestor typ into target and attach
1425 -- it to finalization list F. Init_Pr conditions the call to the
1426 -- init proc since it may already be done due to ancestor initialization
1428 ---------------------------------
1429 -- Ancestor_Discriminant_Value --
1430 ---------------------------------
1432 function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is
1434 Assoc_Elmt : Elmt_Id;
1435 Aggr_Comp : Entity_Id;
1436 Corresp_Disc : Entity_Id;
1437 Current_Typ : Entity_Id := Base_Type (Typ);
1438 Parent_Typ : Entity_Id;
1439 Parent_Disc : Entity_Id;
1440 Save_Assoc : Node_Id := Empty;
1443 -- First check any discriminant associations to see if
1444 -- any of them provide a value for the discriminant.
1446 if Present (Discriminant_Specifications (Parent (Current_Typ))) then
1447 Assoc := First (Component_Associations (N));
1448 while Present (Assoc) loop
1449 Aggr_Comp := Entity (First (Choices (Assoc)));
1451 if Ekind (Aggr_Comp) = E_Discriminant then
1452 Save_Assoc := Expression (Assoc);
1454 Corresp_Disc := Corresponding_Discriminant (Aggr_Comp);
1455 while Present (Corresp_Disc) loop
1456 -- If found a corresponding discriminant then return
1457 -- the value given in the aggregate. (Note: this is
1458 -- not correct in the presence of side effects. ???)
1460 if Disc = Corresp_Disc then
1461 return Duplicate_Subexpr (Expression (Assoc));
1465 Corresponding_Discriminant (Corresp_Disc);
1473 -- No match found in aggregate, so chain up parent types to find
1474 -- a constraint that defines the value of the discriminant.
1476 Parent_Typ := Etype (Current_Typ);
1477 while Current_Typ /= Parent_Typ loop
1478 if Has_Discriminants (Parent_Typ) then
1479 Parent_Disc := First_Discriminant (Parent_Typ);
1481 -- We either get the association from the subtype indication
1482 -- of the type definition itself, or from the discriminant
1483 -- constraint associated with the type entity (which is
1484 -- preferable, but it's not always present ???)
1486 if Is_Empty_Elmt_List (
1487 Discriminant_Constraint (Current_Typ))
1489 Assoc := Get_Constraint_Association (Current_Typ);
1490 Assoc_Elmt := No_Elmt;
1493 First_Elmt (Discriminant_Constraint (Current_Typ));
1494 Assoc := Node (Assoc_Elmt);
1497 -- Traverse the discriminants of the parent type looking
1498 -- for one that corresponds.
1500 while Present (Parent_Disc) and then Present (Assoc) loop
1501 Corresp_Disc := Parent_Disc;
1502 while Present (Corresp_Disc)
1503 and then Disc /= Corresp_Disc
1506 Corresponding_Discriminant (Corresp_Disc);
1509 if Disc = Corresp_Disc then
1510 if Nkind (Assoc) = N_Discriminant_Association then
1511 Assoc := Expression (Assoc);
1514 -- If the located association directly denotes
1515 -- a discriminant, then use the value of a saved
1516 -- association of the aggregate. This is a kludge
1517 -- to handle certain cases involving multiple
1518 -- discriminants mapped to a single discriminant
1519 -- of a descendant. It's not clear how to locate the
1520 -- appropriate discriminant value for such cases. ???
1522 if Is_Entity_Name (Assoc)
1523 and then Ekind (Entity (Assoc)) = E_Discriminant
1525 Assoc := Save_Assoc;
1528 return Duplicate_Subexpr (Assoc);
1531 Next_Discriminant (Parent_Disc);
1533 if No (Assoc_Elmt) then
1536 Next_Elmt (Assoc_Elmt);
1537 if Present (Assoc_Elmt) then
1538 Assoc := Node (Assoc_Elmt);
1546 Current_Typ := Parent_Typ;
1547 Parent_Typ := Etype (Current_Typ);
1550 -- In some cases there's no ancestor value to locate (such as
1551 -- when an ancestor part given by an expression defines the
1552 -- discriminant value).
1555 end Ancestor_Discriminant_Value;
1557 ----------------------------------
1558 -- Check_Ancestor_Discriminants --
1559 ----------------------------------
1561 procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is
1562 Discr : Entity_Id := First_Discriminant (Base_Type (Anc_Typ));
1563 Disc_Value : Node_Id;
1567 while Present (Discr) loop
1568 Disc_Value := Ancestor_Discriminant_Value (Discr);
1570 if Present (Disc_Value) then
1571 Cond := Make_Op_Ne (Loc,
1573 Make_Selected_Component (Loc,
1574 Prefix => New_Copy_Tree (Target),
1575 Selector_Name => New_Occurrence_Of (Discr, Loc)),
1576 Right_Opnd => Disc_Value);
1579 Make_Raise_Constraint_Error (Loc,
1581 Reason => CE_Discriminant_Check_Failed));
1584 Next_Discriminant (Discr);
1586 end Check_Ancestor_Discriminants;
1588 --------------------------------
1589 -- Get_Constraint_Association --
1590 --------------------------------
1592 function Get_Constraint_Association (T : Entity_Id) return Node_Id is
1593 Typ_Def : constant Node_Id := Type_Definition (Parent (T));
1594 Indic : constant Node_Id := Subtype_Indication (Typ_Def);
1597 -- ??? Also need to cover case of a type mark denoting a subtype
1600 if Nkind (Indic) = N_Subtype_Indication
1601 and then Present (Constraint (Indic))
1603 return First (Constraints (Constraint (Indic)));
1607 end Get_Constraint_Association;
1609 ---------------------
1610 -- Init_controller --
1611 ---------------------
1613 function Init_Controller
1618 Init_Pr : Boolean) return List_Id
1620 L : constant List_Id := New_List;
1625 -- init-proc (target._controller);
1626 -- initialize (target._controller);
1627 -- Attach_to_Final_List (target._controller, F);
1630 Make_Selected_Component (Loc,
1631 Prefix => Convert_To (Typ, New_Copy_Tree (Target)),
1632 Selector_Name => Make_Identifier (Loc, Name_uController));
1633 Set_Assignment_OK (Ref);
1635 -- Ada 0Y (AI-287): Give support to default initialization of limited
1636 -- types and components.
1638 if (Nkind (Target) = N_Identifier
1639 and then Present (Etype (Target))
1640 and then Is_Limited_Type (Etype (Target)))
1642 (Nkind (Target) = N_Selected_Component
1643 and then Present (Etype (Selector_Name (Target)))
1644 and then Is_Limited_Type (Etype (Selector_Name (Target))))
1646 (Nkind (Target) = N_Unchecked_Type_Conversion
1647 and then Present (Etype (Target))
1648 and then Is_Limited_Type (Etype (Target)))
1650 (Nkind (Target) = N_Unchecked_Expression
1651 and then Nkind (Expression (Target)) = N_Indexed_Component
1652 and then Present (Etype (Prefix (Expression (Target))))
1653 and then Is_Limited_Type (Etype (Prefix (Expression (Target)))))
1657 Build_Initialization_Call (Loc,
1659 Typ => RTE (RE_Limited_Record_Controller),
1660 In_Init_Proc => Within_Init_Proc));
1664 Make_Procedure_Call_Statement (Loc,
1667 (Find_Prim_Op (RTE (RE_Limited_Record_Controller),
1668 Name_Initialize), Loc),
1669 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
1674 Build_Initialization_Call (Loc,
1676 Typ => RTE (RE_Record_Controller),
1677 In_Init_Proc => Within_Init_Proc));
1681 Make_Procedure_Call_Statement (Loc,
1683 New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
1684 Name_Initialize), Loc),
1685 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
1691 Obj_Ref => New_Copy_Tree (Ref),
1693 With_Attach => Attach));
1695 end Init_Controller;
1697 -- Start of processing for Build_Record_Aggr_Code
1700 -- Deal with the ancestor part of extension aggregates
1701 -- or with the discriminants of the root type
1703 if Nkind (N) = N_Extension_Aggregate then
1705 A : constant Node_Id := Ancestor_Part (N);
1708 -- If the ancestor part is a subtype mark "T", we generate
1710 -- init-proc (T(tmp)); if T is constrained and
1711 -- init-proc (S(tmp)); where S applies an appropriate
1712 -- constraint if T is unconstrained
1714 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
1715 Ancestor_Is_Subtype_Mark := True;
1717 if Is_Constrained (Entity (A)) then
1718 Init_Typ := Entity (A);
1720 -- For an ancestor part given by an unconstrained type
1721 -- mark, create a subtype constrained by appropriate
1722 -- corresponding discriminant values coming from either
1723 -- associations of the aggregate or a constraint on
1724 -- a parent type. The subtype will be used to generate
1725 -- the correct default value for the ancestor part.
1727 elsif Has_Discriminants (Entity (A)) then
1729 Anc_Typ : constant Entity_Id := Entity (A);
1730 Anc_Constr : constant List_Id := New_List;
1731 Discrim : Entity_Id;
1732 Disc_Value : Node_Id;
1733 New_Indic : Node_Id;
1734 Subt_Decl : Node_Id;
1737 Discrim := First_Discriminant (Anc_Typ);
1738 while Present (Discrim) loop
1739 Disc_Value := Ancestor_Discriminant_Value (Discrim);
1740 Append_To (Anc_Constr, Disc_Value);
1741 Next_Discriminant (Discrim);
1745 Make_Subtype_Indication (Loc,
1746 Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc),
1748 Make_Index_Or_Discriminant_Constraint (Loc,
1749 Constraints => Anc_Constr));
1751 Init_Typ := Create_Itype (Ekind (Anc_Typ), N);
1754 Make_Subtype_Declaration (Loc,
1755 Defining_Identifier => Init_Typ,
1756 Subtype_Indication => New_Indic);
1758 -- Itypes must be analyzed with checks off
1759 -- Declaration must have a parent for proper
1760 -- handling of subsidiary actions.
1762 Set_Parent (Subt_Decl, N);
1763 Analyze (Subt_Decl, Suppress => All_Checks);
1767 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
1768 Set_Assignment_OK (Ref);
1770 if Has_Default_Init_Comps (N)
1771 or else Has_Task (Base_Type (Init_Typ))
1773 Append_List_To (Start_L,
1774 Build_Initialization_Call (Loc,
1777 In_Init_Proc => Within_Init_Proc,
1778 With_Default_Init => True));
1780 Append_List_To (Start_L,
1781 Build_Initialization_Call (Loc,
1784 In_Init_Proc => Within_Init_Proc));
1787 if Is_Constrained (Entity (A))
1788 and then Has_Discriminants (Entity (A))
1790 Check_Ancestor_Discriminants (Entity (A));
1793 -- Ada 0Y (AI-287): If the ancestor part is a limited type,
1794 -- a recursive call expands the ancestor.
1796 elsif Is_Limited_Type (Etype (A)) then
1797 Ancestor_Is_Expression := True;
1799 Append_List_To (Start_L,
1800 Build_Record_Aggr_Code (
1801 N => Expression (A),
1802 Typ => Etype (Expression (A)),
1806 Is_Limited_Ancestor_Expansion => True));
1808 -- If the ancestor part is an expression "E", we generate
1812 Ancestor_Is_Expression := True;
1813 Init_Typ := Etype (A);
1815 -- Assign the tag before doing the assignment to make sure
1816 -- that the dispatching call in the subsequent deep_adjust
1817 -- works properly (unless Java_VM, where tags are implicit).
1821 Make_OK_Assignment_Statement (Loc,
1823 Make_Selected_Component (Loc,
1824 Prefix => New_Copy_Tree (Target),
1825 Selector_Name => New_Reference_To (
1826 Tag_Component (Base_Type (Typ)), Loc)),
1829 Unchecked_Convert_To (RTE (RE_Tag),
1831 Access_Disp_Table (Base_Type (Typ)), Loc)));
1833 Set_Assignment_OK (Name (Instr));
1834 Append_To (L, Instr);
1837 -- If the ancestor part is an aggregate, force its full
1838 -- expansion, which was delayed.
1840 if Nkind (A) = N_Qualified_Expression
1841 and then (Nkind (Expression (A)) = N_Aggregate
1843 Nkind (Expression (A)) = N_Extension_Aggregate)
1845 Set_Analyzed (A, False);
1846 Set_Analyzed (Expression (A), False);
1849 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
1850 Set_Assignment_OK (Ref);
1852 Make_Unsuppress_Block (Loc,
1853 Name_Discriminant_Check,
1855 Make_OK_Assignment_Statement (Loc,
1857 Expression => A))));
1859 if Has_Discriminants (Init_Typ) then
1860 Check_Ancestor_Discriminants (Init_Typ);
1865 -- Normal case (not an extension aggregate)
1868 -- Generate the discriminant expressions, component by component.
1869 -- If the base type is an unchecked union, the discriminants are
1870 -- unknown to the back-end and absent from a value of the type, so
1871 -- assignments for them are not emitted.
1873 if Has_Discriminants (Typ)
1874 and then not Is_Unchecked_Union (Base_Type (Typ))
1876 -- ??? The discriminants of the object not inherited in the type
1877 -- of the object should be initialized here
1881 -- Generate discriminant init values
1884 Discriminant : Entity_Id;
1885 Discriminant_Value : Node_Id;
1888 Discriminant := First_Stored_Discriminant (Typ);
1890 while Present (Discriminant) loop
1893 Make_Selected_Component (Loc,
1894 Prefix => New_Copy_Tree (Target),
1895 Selector_Name => New_Occurrence_Of (Discriminant, Loc));
1897 Discriminant_Value :=
1898 Get_Discriminant_Value (
1901 Discriminant_Constraint (N_Typ));
1904 Make_OK_Assignment_Statement (Loc,
1906 Expression => New_Copy_Tree (Discriminant_Value));
1908 Set_No_Ctrl_Actions (Instr);
1909 Append_To (L, Instr);
1911 Next_Stored_Discriminant (Discriminant);
1917 -- Generate the assignments, component by component
1919 -- tmp.comp1 := Expr1_From_Aggr;
1920 -- tmp.comp2 := Expr2_From_Aggr;
1923 Comp := First (Component_Associations (N));
1924 while Present (Comp) loop
1925 Selector := Entity (First (Choices (Comp)));
1927 -- Ada 0Y (AI-287): Default initialization of a limited component
1929 if Box_Present (Comp)
1930 and then Is_Limited_Type (Etype (Selector))
1932 -- Ada 0Y (AI-287): If the component type has tasks then generate
1933 -- the activation chain and master entities (except in case of an
1934 -- allocator because in that case these entities are generated
1935 -- by Build_Task_Allocate_Block_With_Init_Stmts).
1938 Ctype : constant Entity_Id := Etype (Selector);
1939 Inside_Allocator : Boolean := False;
1940 P : Node_Id := Parent (N);
1943 if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
1944 while Present (P) loop
1945 if Nkind (P) = N_Allocator then
1946 Inside_Allocator := True;
1953 if not Inside_Init_Proc and not Inside_Allocator then
1954 Build_Activation_Chain_Entity (N);
1956 if not Has_Master_Entity (Current_Scope) then
1957 Build_Master_Entity (Etype (N));
1964 Build_Initialization_Call (Loc,
1965 Id_Ref => Make_Selected_Component (Loc,
1966 Prefix => New_Copy_Tree (Target),
1967 Selector_Name => New_Occurrence_Of (Selector,
1969 Typ => Etype (Selector),
1970 With_Default_Init => True));
1977 if Ekind (Selector) /= E_Discriminant
1978 or else Nkind (N) = N_Extension_Aggregate
1980 Comp_Type := Etype (Selector);
1982 Make_Selected_Component (Loc,
1983 Prefix => New_Copy_Tree (Target),
1984 Selector_Name => New_Occurrence_Of (Selector, Loc));
1986 if Nkind (Expression (Comp)) = N_Qualified_Expression then
1987 Expr_Q := Expression (Expression (Comp));
1989 Expr_Q := Expression (Comp);
1992 -- The controller is the one of the parent type defining
1993 -- the component (in case of inherited components).
1995 if Controlled_Type (Comp_Type) then
1996 Internal_Final_List :=
1997 Make_Selected_Component (Loc,
1998 Prefix => Convert_To (
1999 Scope (Original_Record_Component (Selector)),
2000 New_Copy_Tree (Target)),
2002 Make_Identifier (Loc, Name_uController));
2004 Internal_Final_List :=
2005 Make_Selected_Component (Loc,
2006 Prefix => Internal_Final_List,
2007 Selector_Name => Make_Identifier (Loc, Name_F));
2009 -- The internal final list can be part of a constant object
2011 Set_Assignment_OK (Internal_Final_List);
2014 Internal_Final_List := Empty;
2019 if Is_Delayed_Aggregate (Expr_Q) then
2021 Late_Expansion (Expr_Q, Comp_Type, Comp_Expr,
2022 Internal_Final_List));
2026 Make_OK_Assignment_Statement (Loc,
2028 Expression => Expression (Comp));
2030 Set_No_Ctrl_Actions (Instr);
2031 Append_To (L, Instr);
2033 -- Adjust the tag if tagged (because of possible view
2034 -- conversions), unless compiling for the Java VM
2035 -- where tags are implicit.
2037 -- tmp.comp._tag := comp_typ'tag;
2039 if Is_Tagged_Type (Comp_Type) and then not Java_VM then
2041 Make_OK_Assignment_Statement (Loc,
2043 Make_Selected_Component (Loc,
2044 Prefix => New_Copy_Tree (Comp_Expr),
2046 New_Reference_To (Tag_Component (Comp_Type), Loc)),
2049 Unchecked_Convert_To (RTE (RE_Tag),
2051 Access_Disp_Table (Comp_Type), Loc)));
2053 Append_To (L, Instr);
2056 -- Adjust and Attach the component to the proper controller
2057 -- Adjust (tmp.comp);
2058 -- Attach_To_Final_List (tmp.comp,
2059 -- comp_typ (tmp)._record_controller.f)
2061 if Controlled_Type (Comp_Type) then
2064 Ref => New_Copy_Tree (Comp_Expr),
2066 Flist_Ref => Internal_Final_List,
2067 With_Attach => Make_Integer_Literal (Loc, 1)));
2073 elsif Ekind (Selector) = E_Discriminant
2074 and then Nkind (N) /= N_Extension_Aggregate
2075 and then Nkind (Parent (N)) = N_Component_Association
2076 and then Is_Constrained (Typ)
2078 -- We must check that the discriminant value imposed by the
2079 -- context is the same as the value given in the subaggregate,
2080 -- because after the expansion into assignments there is no
2081 -- record on which to perform a regular discriminant check.
2088 D_Val := First_Elmt (Discriminant_Constraint (Typ));
2089 Disc := First_Discriminant (Typ);
2091 while Chars (Disc) /= Chars (Selector) loop
2092 Next_Discriminant (Disc);
2096 pragma Assert (Present (D_Val));
2099 Make_Raise_Constraint_Error (Loc,
2102 Left_Opnd => New_Copy_Tree (Node (D_Val)),
2103 Right_Opnd => Expression (Comp)),
2104 Reason => CE_Discriminant_Check_Failed));
2113 -- If the type is tagged, the tag needs to be initialized (unless
2114 -- compiling for the Java VM where tags are implicit). It is done
2115 -- late in the initialization process because in some cases, we call
2116 -- the init proc of an ancestor which will not leave out the right tag
2118 if Ancestor_Is_Expression then
2121 elsif Is_Tagged_Type (Typ) and then not Java_VM then
2123 Make_OK_Assignment_Statement (Loc,
2125 Make_Selected_Component (Loc,
2126 Prefix => New_Copy_Tree (Target),
2128 New_Reference_To (Tag_Component (Base_Type (Typ)), Loc)),
2131 Unchecked_Convert_To (RTE (RE_Tag),
2132 New_Reference_To (Access_Disp_Table (Base_Type (Typ)), Loc)));
2134 Append_To (L, Instr);
2137 -- Now deal with the various controlled type data structure
2141 and then Finalize_Storage_Only (Typ)
2142 and then (Is_Library_Level_Entity (Obj)
2143 or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
2146 Attach := Make_Integer_Literal (Loc, 0);
2148 elsif Nkind (Parent (N)) = N_Qualified_Expression
2149 and then Nkind (Parent (Parent (N))) = N_Allocator
2151 Attach := Make_Integer_Literal (Loc, 2);
2154 Attach := Make_Integer_Literal (Loc, 1);
2157 -- Determine the external finalization list. It is either the
2158 -- finalization list of the outer-scope or the one coming from
2159 -- an outer aggregate. When the target is not a temporary, the
2160 -- proper scope is the scope of the target rather than the
2161 -- potentially transient current scope.
2163 if Controlled_Type (Typ) then
2164 if Present (Flist) then
2165 External_Final_List := New_Copy_Tree (Flist);
2167 elsif Is_Entity_Name (Target)
2168 and then Present (Scope (Entity (Target)))
2170 External_Final_List := Find_Final_List (Scope (Entity (Target)));
2173 External_Final_List := Find_Final_List (Current_Scope);
2177 External_Final_List := Empty;
2180 -- Initialize and attach the outer object in the is_controlled case
2182 if Is_Controlled (Typ) then
2183 if Ancestor_Is_Subtype_Mark then
2184 Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
2185 Set_Assignment_OK (Ref);
2187 Make_Procedure_Call_Statement (Loc,
2188 Name => New_Reference_To (
2189 Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
2190 Parameter_Associations => New_List (New_Copy_Tree (Ref))));
2193 if not Has_Controlled_Component (Typ) then
2194 Ref := New_Copy_Tree (Target);
2195 Set_Assignment_OK (Ref);
2199 Flist_Ref => New_Copy_Tree (External_Final_List),
2200 With_Attach => Attach));
2204 -- In the Has_Controlled component case, all the intermediate
2205 -- controllers must be initialized
2207 if Has_Controlled_Component (Typ)
2208 and not Is_Limited_Ancestor_Expansion
2211 Inner_Typ : Entity_Id;
2212 Outer_Typ : Entity_Id;
2217 Outer_Typ := Base_Type (Typ);
2219 -- Find outer type with a controller
2221 while Outer_Typ /= Init_Typ
2222 and then not Has_New_Controlled_Component (Outer_Typ)
2224 Outer_Typ := Etype (Outer_Typ);
2227 -- Attach it to the outer record controller to the
2228 -- external final list
2230 if Outer_Typ = Init_Typ then
2231 Append_List_To (Start_L,
2235 F => External_Final_List,
2237 Init_Pr => Ancestor_Is_Expression));
2240 Inner_Typ := Init_Typ;
2243 Append_List_To (Start_L,
2247 F => External_Final_List,
2251 Inner_Typ := Etype (Outer_Typ);
2253 not Is_Tagged_Type (Typ) or else Inner_Typ = Outer_Typ;
2256 -- The outer object has to be attached as well
2258 if Is_Controlled (Typ) then
2259 Ref := New_Copy_Tree (Target);
2260 Set_Assignment_OK (Ref);
2264 Flist_Ref => New_Copy_Tree (External_Final_List),
2265 With_Attach => New_Copy_Tree (Attach)));
2268 -- Initialize the internal controllers for tagged types with
2269 -- more than one controller.
2271 while not At_Root and then Inner_Typ /= Init_Typ loop
2272 if Has_New_Controlled_Component (Inner_Typ) then
2274 Make_Selected_Component (Loc,
2275 Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
2277 Make_Identifier (Loc, Name_uController));
2279 Make_Selected_Component (Loc,
2281 Selector_Name => Make_Identifier (Loc, Name_F));
2283 Append_List_To (Start_L,
2288 Attach => Make_Integer_Literal (Loc, 1),
2290 Outer_Typ := Inner_Typ;
2295 At_Root := Inner_Typ = Etype (Inner_Typ);
2296 Inner_Typ := Etype (Inner_Typ);
2299 -- If not done yet attach the controller of the ancestor part
2301 if Outer_Typ /= Init_Typ
2302 and then Inner_Typ = Init_Typ
2303 and then Has_Controlled_Component (Init_Typ)
2306 Make_Selected_Component (Loc,
2307 Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
2308 Selector_Name => Make_Identifier (Loc, Name_uController));
2310 Make_Selected_Component (Loc,
2312 Selector_Name => Make_Identifier (Loc, Name_F));
2314 Attach := Make_Integer_Literal (Loc, 1);
2315 Append_List_To (Start_L,
2321 Init_Pr => Ancestor_Is_Expression));
2326 Append_List_To (Start_L, L);
2328 end Build_Record_Aggr_Code;
2330 -------------------------------
2331 -- Convert_Aggr_In_Allocator --
2332 -------------------------------
2334 procedure Convert_Aggr_In_Allocator (Decl, Aggr : Node_Id) is
2335 Loc : constant Source_Ptr := Sloc (Aggr);
2336 Typ : constant Entity_Id := Etype (Aggr);
2337 Temp : constant Entity_Id := Defining_Identifier (Decl);
2339 Occ : constant Node_Id :=
2340 Unchecked_Convert_To (Typ,
2341 Make_Explicit_Dereference (Loc,
2342 New_Reference_To (Temp, Loc)));
2344 Access_Type : constant Entity_Id := Etype (Temp);
2347 if Has_Default_Init_Comps (Aggr) then
2349 L : constant List_Id := New_List;
2350 Init_Stmts : List_Id;
2353 Init_Stmts := Late_Expansion (Aggr, Typ, Occ,
2354 Find_Final_List (Access_Type),
2355 Associated_Final_Chain (Base_Type (Access_Type)));
2357 Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
2358 Insert_Actions_After (Decl, L);
2362 Insert_Actions_After (Decl,
2363 Late_Expansion (Aggr, Typ, Occ,
2364 Find_Final_List (Access_Type),
2365 Associated_Final_Chain (Base_Type (Access_Type))));
2367 end Convert_Aggr_In_Allocator;
2369 --------------------------------
2370 -- Convert_Aggr_In_Assignment --
2371 --------------------------------
2373 procedure Convert_Aggr_In_Assignment (N : Node_Id) is
2374 Aggr : Node_Id := Expression (N);
2375 Typ : constant Entity_Id := Etype (Aggr);
2376 Occ : constant Node_Id := New_Copy_Tree (Name (N));
2379 if Nkind (Aggr) = N_Qualified_Expression then
2380 Aggr := Expression (Aggr);
2383 Insert_Actions_After (N,
2384 Late_Expansion (Aggr, Typ, Occ,
2385 Find_Final_List (Typ, New_Copy_Tree (Occ))));
2386 end Convert_Aggr_In_Assignment;
2388 ---------------------------------
2389 -- Convert_Aggr_In_Object_Decl --
2390 ---------------------------------
2392 procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is
2393 Obj : constant Entity_Id := Defining_Identifier (N);
2394 Aggr : Node_Id := Expression (N);
2395 Loc : constant Source_Ptr := Sloc (Aggr);
2396 Typ : constant Entity_Id := Etype (Aggr);
2397 Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
2399 function Discriminants_Ok return Boolean;
2400 -- If the object type is constrained, the discriminants in the
2401 -- aggregate must be checked against the discriminants of the subtype.
2402 -- This cannot be done using Apply_Discriminant_Checks because after
2403 -- expansion there is no aggregate left to check.
2405 ----------------------
2406 -- Discriminants_Ok --
2407 ----------------------
2409 function Discriminants_Ok return Boolean is
2410 Cond : Node_Id := Empty;
2419 D := First_Discriminant (Typ);
2420 Disc1 := First_Elmt (Discriminant_Constraint (Typ));
2421 Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj)));
2423 while Present (Disc1) and then Present (Disc2) loop
2424 Val1 := Node (Disc1);
2425 Val2 := Node (Disc2);
2427 if not Is_OK_Static_Expression (Val1)
2428 or else not Is_OK_Static_Expression (Val2)
2430 Check := Make_Op_Ne (Loc,
2431 Left_Opnd => Duplicate_Subexpr (Val1),
2432 Right_Opnd => Duplicate_Subexpr (Val2));
2438 Cond := Make_Or_Else (Loc,
2440 Right_Opnd => Check);
2443 elsif Expr_Value (Val1) /= Expr_Value (Val2) then
2444 Apply_Compile_Time_Constraint_Error (Aggr,
2445 Msg => "incorrect value for discriminant&?",
2446 Reason => CE_Discriminant_Check_Failed,
2451 Next_Discriminant (D);
2456 -- If any discriminant constraint is non-static, emit a check.
2458 if Present (Cond) then
2460 Make_Raise_Constraint_Error (Loc,
2462 Reason => CE_Discriminant_Check_Failed));
2466 end Discriminants_Ok;
2468 -- Start of processing for Convert_Aggr_In_Object_Decl
2471 Set_Assignment_OK (Occ);
2473 if Nkind (Aggr) = N_Qualified_Expression then
2474 Aggr := Expression (Aggr);
2477 if Has_Discriminants (Typ)
2478 and then Typ /= Etype (Obj)
2479 and then Is_Constrained (Etype (Obj))
2480 and then not Discriminants_Ok
2485 Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj));
2486 Set_No_Initialization (N);
2487 Initialize_Discriminants (N, Typ);
2488 end Convert_Aggr_In_Object_Decl;
2490 ----------------------------
2491 -- Convert_To_Assignments --
2492 ----------------------------
2494 procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
2495 Loc : constant Source_Ptr := Sloc (N);
2499 Target_Expr : Node_Id;
2500 Parent_Kind : Node_Kind;
2501 Unc_Decl : Boolean := False;
2502 Parent_Node : Node_Id;
2505 Parent_Node := Parent (N);
2506 Parent_Kind := Nkind (Parent_Node);
2508 if Parent_Kind = N_Qualified_Expression then
2510 -- Check if we are in a unconstrained declaration because in this
2511 -- case the current delayed expansion mechanism doesn't work when
2512 -- the declared object size depend on the initializing expr.
2515 Parent_Node := Parent (Parent_Node);
2516 Parent_Kind := Nkind (Parent_Node);
2518 if Parent_Kind = N_Object_Declaration then
2520 not Is_Entity_Name (Object_Definition (Parent_Node))
2521 or else Has_Discriminants
2522 (Entity (Object_Definition (Parent_Node)))
2523 or else Is_Class_Wide_Type
2524 (Entity (Object_Definition (Parent_Node)));
2529 -- Just set the Delay flag in the following cases where the
2530 -- transformation will be done top down from above
2532 -- - internal aggregate (transformed when expanding the parent)
2533 -- - allocators (see Convert_Aggr_In_Allocator)
2534 -- - object decl (see Convert_Aggr_In_Object_Decl)
2535 -- - safe assignments (see Convert_Aggr_Assignments)
2536 -- so far only the assignments in the init procs are taken
2539 if Parent_Kind = N_Aggregate
2540 or else Parent_Kind = N_Extension_Aggregate
2541 or else Parent_Kind = N_Component_Association
2542 or else Parent_Kind = N_Allocator
2543 or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
2544 or else (Parent_Kind = N_Assignment_Statement
2545 and then Inside_Init_Proc)
2547 Set_Expansion_Delayed (N);
2551 if Requires_Transient_Scope (Typ) then
2552 Establish_Transient_Scope (N, Sec_Stack =>
2553 Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
2556 -- Create the temporary
2558 Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
2561 Make_Object_Declaration (Loc,
2562 Defining_Identifier => Temp,
2563 Object_Definition => New_Occurrence_Of (Typ, Loc));
2565 Set_No_Initialization (Instr);
2566 Insert_Action (N, Instr);
2567 Initialize_Discriminants (Instr, Typ);
2568 Target_Expr := New_Occurrence_Of (Temp, Loc);
2570 Insert_Actions (N, Build_Record_Aggr_Code (N, Typ, Target_Expr));
2571 Rewrite (N, New_Occurrence_Of (Temp, Loc));
2572 Analyze_And_Resolve (N, Typ);
2573 end Convert_To_Assignments;
2575 ---------------------------
2576 -- Convert_To_Positional --
2577 ---------------------------
2579 procedure Convert_To_Positional
2581 Max_Others_Replicate : Nat := 5;
2582 Handle_Bit_Packed : Boolean := False)
2584 Typ : constant Entity_Id := Etype (N);
2589 Ixb : Node_Id) return Boolean;
2590 -- Convert the aggregate into a purely positional form if possible.
2592 function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
2593 -- Non trivial for multidimensional aggregate.
2602 Ixb : Node_Id) return Boolean
2604 Loc : constant Source_Ptr := Sloc (N);
2605 Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb));
2606 Lo : constant Node_Id := Type_Low_Bound (Etype (Ix));
2607 Hi : constant Node_Id := Type_High_Bound (Etype (Ix));
2611 -- The following constant determines the maximum size of an
2612 -- aggregate produced by converting named to positional
2613 -- notation (e.g. from others clauses). This avoids running
2614 -- away with attempts to convert huge aggregates.
2616 -- The normal limit is 5000, but we increase this limit to
2617 -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code)
2618 -- or Restrictions (No_Implicit_Loops) is specified, since in
2619 -- either case, we are at risk of declaring the program illegal
2620 -- because of this limit.
2622 Max_Aggr_Size : constant Nat :=
2623 5000 + (2 ** 24 - 5000) *
2625 (Restriction_Active (No_Elaboration_Code)
2627 Restriction_Active (No_Implicit_Loops));
2630 if Nkind (Original_Node (N)) = N_String_Literal then
2634 -- Bounds need to be known at compile time
2636 if not Compile_Time_Known_Value (Lo)
2637 or else not Compile_Time_Known_Value (Hi)
2642 -- Get bounds and check reasonable size (positive, not too large)
2643 -- Also only handle bounds starting at the base type low bound
2644 -- for now since the compiler isn't able to handle different low
2645 -- bounds yet. Case such as new String'(3..5 => ' ') will get
2646 -- the wrong bounds, though it seems that the aggregate should
2647 -- retain the bounds set on its Etype (see C64103E and CC1311B).
2649 Lov := Expr_Value (Lo);
2650 Hiv := Expr_Value (Hi);
2653 or else (Hiv - Lov > Max_Aggr_Size)
2654 or else not Compile_Time_Known_Value (Blo)
2655 or else (Lov /= Expr_Value (Blo))
2660 -- Bounds must be in integer range (for array Vals below)
2662 if not UI_Is_In_Int_Range (Lov)
2664 not UI_Is_In_Int_Range (Hiv)
2669 -- Determine if set of alternatives is suitable for conversion
2670 -- and build an array containing the values in sequence.
2673 Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv))
2674 of Node_Id := (others => Empty);
2675 -- The values in the aggregate sorted appropriately
2678 -- Same data as Vals in list form
2681 -- Used to validate Max_Others_Replicate limit
2684 Num : Int := UI_To_Int (Lov);
2689 if Present (Expressions (N)) then
2690 Elmt := First (Expressions (N));
2692 while Present (Elmt) loop
2693 if Nkind (Elmt) = N_Aggregate
2694 and then Present (Next_Index (Ix))
2696 not Flatten (Elmt, Next_Index (Ix), Next_Index (Ixb))
2701 Vals (Num) := Relocate_Node (Elmt);
2708 if No (Component_Associations (N)) then
2712 Elmt := First (Component_Associations (N));
2714 if Nkind (Expression (Elmt)) = N_Aggregate then
2715 if Present (Next_Index (Ix))
2718 (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb))
2724 Component_Loop : while Present (Elmt) loop
2725 Choice := First (Choices (Elmt));
2726 Choice_Loop : while Present (Choice) loop
2728 -- If we have an others choice, fill in the missing elements
2729 -- subject to the limit established by Max_Others_Replicate.
2731 if Nkind (Choice) = N_Others_Choice then
2734 for J in Vals'Range loop
2735 if No (Vals (J)) then
2736 Vals (J) := New_Copy_Tree (Expression (Elmt));
2737 Rep_Count := Rep_Count + 1;
2739 -- Check for maximum others replication. Note that
2740 -- we skip this test if either of the restrictions
2741 -- No_Elaboration_Code or No_Implicit_Loops is
2742 -- active, or if this is a preelaborable unit.
2745 P : constant Entity_Id :=
2746 Cunit_Entity (Current_Sem_Unit);
2749 if Restriction_Active (No_Elaboration_Code)
2750 or else Restriction_Active (No_Implicit_Loops)
2751 or else Is_Preelaborated (P)
2752 or else (Ekind (P) = E_Package_Body
2754 Is_Preelaborated (Spec_Entity (P)))
2758 elsif Rep_Count > Max_Others_Replicate then
2765 exit Component_Loop;
2767 -- Case of a subtype mark
2769 elsif Nkind (Choice) = N_Identifier
2770 and then Is_Type (Entity (Choice))
2772 Lo := Type_Low_Bound (Etype (Choice));
2773 Hi := Type_High_Bound (Etype (Choice));
2775 -- Case of subtype indication
2777 elsif Nkind (Choice) = N_Subtype_Indication then
2778 Lo := Low_Bound (Range_Expression (Constraint (Choice)));
2779 Hi := High_Bound (Range_Expression (Constraint (Choice)));
2783 elsif Nkind (Choice) = N_Range then
2784 Lo := Low_Bound (Choice);
2785 Hi := High_Bound (Choice);
2787 -- Normal subexpression case
2789 else pragma Assert (Nkind (Choice) in N_Subexpr);
2790 if not Compile_Time_Known_Value (Choice) then
2794 Vals (UI_To_Int (Expr_Value (Choice))) :=
2795 New_Copy_Tree (Expression (Elmt));
2800 -- Range cases merge with Lo,Hi said
2802 if not Compile_Time_Known_Value (Lo)
2804 not Compile_Time_Known_Value (Hi)
2808 for J in UI_To_Int (Expr_Value (Lo)) ..
2809 UI_To_Int (Expr_Value (Hi))
2811 Vals (J) := New_Copy_Tree (Expression (Elmt));
2817 end loop Choice_Loop;
2820 end loop Component_Loop;
2822 -- If we get here the conversion is possible
2825 for J in Vals'Range loop
2826 Append (Vals (J), Vlist);
2829 Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist));
2830 Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N)));
2839 function Is_Flat (N : Node_Id; Dims : Int) return Boolean is
2846 elsif Nkind (N) = N_Aggregate then
2847 if Present (Component_Associations (N)) then
2851 Elmt := First (Expressions (N));
2853 while Present (Elmt) loop
2854 if not Is_Flat (Elmt, Dims - 1) then
2868 -- Start of processing for Convert_To_Positional
2871 -- Ada 0Y (AI-287): Do not convert in case of default initialized
2872 -- components because in this case will need to call the corresponding
2875 if Has_Default_Init_Comps (N) then
2879 if Is_Flat (N, Number_Dimensions (Typ)) then
2883 if Is_Bit_Packed_Array (Typ)
2884 and then not Handle_Bit_Packed
2889 -- Do not convert to positional if controlled components are
2890 -- involved since these require special processing
2892 if Has_Controlled_Component (Typ) then
2896 if Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ))) then
2897 Analyze_And_Resolve (N, Typ);
2899 end Convert_To_Positional;
2901 ----------------------------
2902 -- Expand_Array_Aggregate --
2903 ----------------------------
2905 -- Array aggregate expansion proceeds as follows:
2907 -- 1. If requested we generate code to perform all the array aggregate
2908 -- bound checks, specifically
2910 -- (a) Check that the index range defined by aggregate bounds is
2911 -- compatible with corresponding index subtype.
2913 -- (b) If an others choice is present check that no aggregate
2914 -- index is outside the bounds of the index constraint.
2916 -- (c) For multidimensional arrays make sure that all subaggregates
2917 -- corresponding to the same dimension have the same bounds.
2919 -- 2. Check for packed array aggregate which can be converted to a
2920 -- constant so that the aggregate disappeares completely.
2922 -- 3. Check case of nested aggregate. Generally nested aggregates are
2923 -- handled during the processing of the parent aggregate.
2925 -- 4. Check if the aggregate can be statically processed. If this is the
2926 -- case pass it as is to Gigi. Note that a necessary condition for
2927 -- static processing is that the aggregate be fully positional.
2929 -- 5. If in place aggregate expansion is possible (i.e. no need to create
2930 -- a temporary) then mark the aggregate as such and return. Otherwise
2931 -- create a new temporary and generate the appropriate initialization
2934 procedure Expand_Array_Aggregate (N : Node_Id) is
2935 Loc : constant Source_Ptr := Sloc (N);
2937 Typ : constant Entity_Id := Etype (N);
2938 Ctyp : constant Entity_Id := Component_Type (Typ);
2939 -- Typ is the correct constrained array subtype of the aggregate
2940 -- Ctyp is the corresponding component type.
2942 Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
2943 -- Number of aggregate index dimensions.
2945 Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id;
2946 Aggr_High : array (1 .. Aggr_Dimension) of Node_Id;
2947 -- Low and High bounds of the constraint for each aggregate index.
2949 Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
2950 -- The type of each index.
2952 Maybe_In_Place_OK : Boolean;
2953 -- If the type is neither controlled nor packed and the aggregate
2954 -- is the expression in an assignment, assignment in place may be
2955 -- possible, provided other conditions are met on the LHS.
2957 Others_Present : array (1 .. Aggr_Dimension) of Boolean :=
2959 -- If Others_Present (J) is True, then there is an others choice
2960 -- in one of the sub-aggregates of N at dimension J.
2962 procedure Build_Constrained_Type (Positional : Boolean);
2963 -- If the subtype is not static or unconstrained, build a constrained
2964 -- type using the computable sizes of the aggregate and its sub-
2967 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id);
2968 -- Checks that the bounds of Aggr_Bounds are within the bounds defined
2971 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos);
2972 -- Checks that in a multi-dimensional array aggregate all subaggregates
2973 -- corresponding to the same dimension have the same bounds.
2974 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
2975 -- corresponding to the sub-aggregate.
2977 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos);
2978 -- Computes the values of array Others_Present. Sub_Aggr is the
2979 -- array sub-aggregate we start the computation from. Dim is the
2980 -- dimension corresponding to the sub-aggregate.
2982 function Has_Address_Clause (D : Node_Id) return Boolean;
2983 -- If the aggregate is the expression in an object declaration, it
2984 -- cannot be expanded in place. This function does a lookahead in the
2985 -- current declarative part to find an address clause for the object
2988 function In_Place_Assign_OK return Boolean;
2989 -- Simple predicate to determine whether an aggregate assignment can
2990 -- be done in place, because none of the new values can depend on the
2991 -- components of the target of the assignment.
2993 function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean;
2994 -- A static aggregate in an object declaration can in most cases be
2995 -- expanded in place. The one exception is when the aggregate is given
2996 -- with component associations that specify different bounds from those
2997 -- of the type definition in the object declaration. In this rather
2998 -- pathological case the aggregate must slide, and we must introduce
2999 -- an intermediate temporary to hold it.
3001 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
3002 -- Checks that if an others choice is present in any sub-aggregate no
3003 -- aggregate index is outside the bounds of the index constraint.
3004 -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
3005 -- corresponding to the sub-aggregate.
3007 ----------------------------
3008 -- Build_Constrained_Type --
3009 ----------------------------
3011 procedure Build_Constrained_Type (Positional : Boolean) is
3012 Loc : constant Source_Ptr := Sloc (N);
3013 Agg_Type : Entity_Id;
3016 Typ : constant Entity_Id := Etype (N);
3017 Indices : constant List_Id := New_List;
3023 Make_Defining_Identifier (
3024 Loc, New_Internal_Name ('A'));
3026 -- If the aggregate is purely positional, all its subaggregates
3027 -- have the same size. We collect the dimensions from the first
3028 -- subaggregate at each level.
3033 for D in 1 .. Number_Dimensions (Typ) loop
3034 Comp := First (Expressions (Sub_Agg));
3039 while Present (Comp) loop
3046 Low_Bound => Make_Integer_Literal (Loc, 1),
3048 Make_Integer_Literal (Loc, Num)),
3053 -- We know the aggregate type is unconstrained and the
3054 -- aggregate is not processable by the back end, therefore
3055 -- not necessarily positional. Retrieve the bounds of each
3056 -- dimension as computed earlier.
3058 for D in 1 .. Number_Dimensions (Typ) loop
3061 Low_Bound => Aggr_Low (D),
3062 High_Bound => Aggr_High (D)),
3068 Make_Full_Type_Declaration (Loc,
3069 Defining_Identifier => Agg_Type,
3071 Make_Constrained_Array_Definition (Loc,
3072 Discrete_Subtype_Definitions => Indices,
3073 Component_Definition =>
3074 Make_Component_Definition (Loc,
3075 Aliased_Present => False,
3076 Subtype_Indication =>
3077 New_Occurrence_Of (Component_Type (Typ), Loc))));
3079 Insert_Action (N, Decl);
3081 Set_Etype (N, Agg_Type);
3082 Set_Is_Itype (Agg_Type);
3083 Freeze_Itype (Agg_Type, N);
3084 end Build_Constrained_Type;
3090 procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is
3097 Cond : Node_Id := Empty;
3100 Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi);
3101 Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi);
3103 -- Generate the following test:
3105 -- [constraint_error when
3106 -- Aggr_Lo <= Aggr_Hi and then
3107 -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
3109 -- As an optimization try to see if some tests are trivially vacuos
3110 -- because we are comparing an expression against itself.
3112 if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then
3115 elsif Aggr_Hi = Ind_Hi then
3118 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3119 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo));
3121 elsif Aggr_Lo = Ind_Lo then
3124 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
3125 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Hi));
3132 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3133 Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)),
3137 Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
3138 Right_Opnd => Duplicate_Subexpr (Ind_Hi)));
3141 if Present (Cond) then
3146 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3147 Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)),
3149 Right_Opnd => Cond);
3151 Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False);
3152 Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False);
3154 Make_Raise_Constraint_Error (Loc,
3156 Reason => CE_Length_Check_Failed));
3160 ----------------------------
3161 -- Check_Same_Aggr_Bounds --
3162 ----------------------------
3164 procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
3165 Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr));
3166 Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr));
3167 -- The bounds of this specific sub-aggregate.
3169 Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
3170 Aggr_Hi : constant Node_Id := Aggr_High (Dim);
3171 -- The bounds of the aggregate for this dimension
3173 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
3174 -- The index type for this dimension.
3176 Cond : Node_Id := Empty;
3182 -- If index checks are on generate the test
3184 -- [constraint_error when
3185 -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi]
3187 -- As an optimization try to see if some tests are trivially vacuos
3188 -- because we are comparing an expression against itself. Also for
3189 -- the first dimension the test is trivially vacuous because there
3190 -- is just one aggregate for dimension 1.
3192 if Index_Checks_Suppressed (Ind_Typ) then
3196 or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi)
3200 elsif Aggr_Hi = Sub_Hi then
3203 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3204 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo));
3206 elsif Aggr_Lo = Sub_Lo then
3209 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
3210 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi));
3217 Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
3218 Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)),
3222 Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
3223 Right_Opnd => Duplicate_Subexpr (Sub_Hi)));
3226 if Present (Cond) then
3228 Make_Raise_Constraint_Error (Loc,
3230 Reason => CE_Length_Check_Failed));
3233 -- Now look inside the sub-aggregate to see if there is more work
3235 if Dim < Aggr_Dimension then
3237 -- Process positional components
3239 if Present (Expressions (Sub_Aggr)) then
3240 Expr := First (Expressions (Sub_Aggr));
3241 while Present (Expr) loop
3242 Check_Same_Aggr_Bounds (Expr, Dim + 1);
3247 -- Process component associations
3249 if Present (Component_Associations (Sub_Aggr)) then
3250 Assoc := First (Component_Associations (Sub_Aggr));
3251 while Present (Assoc) loop
3252 Expr := Expression (Assoc);
3253 Check_Same_Aggr_Bounds (Expr, Dim + 1);
3258 end Check_Same_Aggr_Bounds;
3260 ----------------------------
3261 -- Compute_Others_Present --
3262 ----------------------------
3264 procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is
3269 if Present (Component_Associations (Sub_Aggr)) then
3270 Assoc := Last (Component_Associations (Sub_Aggr));
3272 if Nkind (First (Choices (Assoc))) = N_Others_Choice then
3273 Others_Present (Dim) := True;
3277 -- Now look inside the sub-aggregate to see if there is more work
3279 if Dim < Aggr_Dimension then
3281 -- Process positional components
3283 if Present (Expressions (Sub_Aggr)) then
3284 Expr := First (Expressions (Sub_Aggr));
3285 while Present (Expr) loop
3286 Compute_Others_Present (Expr, Dim + 1);
3291 -- Process component associations
3293 if Present (Component_Associations (Sub_Aggr)) then
3294 Assoc := First (Component_Associations (Sub_Aggr));
3295 while Present (Assoc) loop
3296 Expr := Expression (Assoc);
3297 Compute_Others_Present (Expr, Dim + 1);
3302 end Compute_Others_Present;
3304 ------------------------
3305 -- Has_Address_Clause --
3306 ------------------------
3308 function Has_Address_Clause (D : Node_Id) return Boolean is
3309 Id : constant Entity_Id := Defining_Identifier (D);
3310 Decl : Node_Id := Next (D);
3313 while Present (Decl) loop
3314 if Nkind (Decl) = N_At_Clause
3315 and then Chars (Identifier (Decl)) = Chars (Id)
3319 elsif Nkind (Decl) = N_Attribute_Definition_Clause
3320 and then Chars (Decl) = Name_Address
3321 and then Chars (Name (Decl)) = Chars (Id)
3330 end Has_Address_Clause;
3332 ------------------------
3333 -- In_Place_Assign_OK --
3334 ------------------------
3336 function In_Place_Assign_OK return Boolean is
3344 function Is_Others_Aggregate (Aggr : Node_Id) return Boolean;
3345 -- Aggregates that consist of a single Others choice are safe
3346 -- if the single expression is.
3348 function Safe_Aggregate (Aggr : Node_Id) return Boolean;
3349 -- Check recursively that each component of a (sub)aggregate does
3350 -- not depend on the variable being assigned to.
3352 function Safe_Component (Expr : Node_Id) return Boolean;
3353 -- Verify that an expression cannot depend on the variable being
3354 -- assigned to. Room for improvement here (but less than before).
3356 -------------------------
3357 -- Is_Others_Aggregate --
3358 -------------------------
3360 function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is
3362 return No (Expressions (Aggr))
3364 (First (Choices (First (Component_Associations (Aggr)))))
3366 end Is_Others_Aggregate;
3368 --------------------
3369 -- Safe_Aggregate --
3370 --------------------
3372 function Safe_Aggregate (Aggr : Node_Id) return Boolean is
3376 if Present (Expressions (Aggr)) then
3377 Expr := First (Expressions (Aggr));
3379 while Present (Expr) loop
3380 if Nkind (Expr) = N_Aggregate then
3381 if not Safe_Aggregate (Expr) then
3385 elsif not Safe_Component (Expr) then
3393 if Present (Component_Associations (Aggr)) then
3394 Expr := First (Component_Associations (Aggr));
3396 while Present (Expr) loop
3397 if Nkind (Expression (Expr)) = N_Aggregate then
3398 if not Safe_Aggregate (Expression (Expr)) then
3402 elsif not Safe_Component (Expression (Expr)) then
3413 --------------------
3414 -- Safe_Component --
3415 --------------------
3417 function Safe_Component (Expr : Node_Id) return Boolean is
3418 Comp : Node_Id := Expr;
3420 function Check_Component (Comp : Node_Id) return Boolean;
3421 -- Do the recursive traversal, after copy.
3423 ---------------------
3424 -- Check_Component --
3425 ---------------------
3427 function Check_Component (Comp : Node_Id) return Boolean is
3429 if Is_Overloaded (Comp) then
3433 return Compile_Time_Known_Value (Comp)
3435 or else (Is_Entity_Name (Comp)
3436 and then Present (Entity (Comp))
3437 and then No (Renamed_Object (Entity (Comp))))
3439 or else (Nkind (Comp) = N_Attribute_Reference
3440 and then Check_Component (Prefix (Comp)))
3442 or else (Nkind (Comp) in N_Binary_Op
3443 and then Check_Component (Left_Opnd (Comp))
3444 and then Check_Component (Right_Opnd (Comp)))
3446 or else (Nkind (Comp) in N_Unary_Op
3447 and then Check_Component (Right_Opnd (Comp)))
3449 or else (Nkind (Comp) = N_Selected_Component
3450 and then Check_Component (Prefix (Comp)));
3451 end Check_Component;
3453 -- Start of processing for Safe_Component
3456 -- If the component appears in an association that may
3457 -- correspond to more than one element, it is not analyzed
3458 -- before the expansion into assignments, to avoid side effects.
3459 -- We analyze, but do not resolve the copy, to obtain sufficient
3460 -- entity information for the checks that follow. If component is
3461 -- overloaded we assume an unsafe function call.
3463 if not Analyzed (Comp) then
3464 if Is_Overloaded (Expr) then
3467 elsif Nkind (Expr) = N_Aggregate
3468 and then not Is_Others_Aggregate (Expr)
3472 elsif Nkind (Expr) = N_Allocator then
3473 -- For now, too complex to analyze.
3478 Comp := New_Copy_Tree (Expr);
3479 Set_Parent (Comp, Parent (Expr));
3483 if Nkind (Comp) = N_Aggregate then
3484 return Safe_Aggregate (Comp);
3486 return Check_Component (Comp);
3490 -- Start of processing for In_Place_Assign_OK
3493 if Present (Component_Associations (N)) then
3495 -- On assignment, sliding can take place, so we cannot do the
3496 -- assignment in place unless the bounds of the aggregate are
3497 -- statically equal to those of the target.
3499 -- If the aggregate is given by an others choice, the bounds
3500 -- are derived from the left-hand side, and the assignment is
3501 -- safe if the expression is.
3503 if Is_Others_Aggregate (N) then
3506 (Expression (First (Component_Associations (N))));
3509 Aggr_In := First_Index (Etype (N));
3510 Obj_In := First_Index (Etype (Name (Parent (N))));
3512 while Present (Aggr_In) loop
3513 Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
3514 Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
3516 if not Compile_Time_Known_Value (Aggr_Lo)
3517 or else not Compile_Time_Known_Value (Aggr_Hi)
3518 or else not Compile_Time_Known_Value (Obj_Lo)
3519 or else not Compile_Time_Known_Value (Obj_Hi)
3520 or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
3521 or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
3526 Next_Index (Aggr_In);
3527 Next_Index (Obj_In);
3531 -- Now check the component values themselves.
3533 return Safe_Aggregate (N);
3534 end In_Place_Assign_OK;
3540 function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean
3542 Obj_Type : constant Entity_Id :=
3543 Etype (Defining_Identifier (Parent (N)));
3545 L1, L2, H1, H2 : Node_Id;
3548 -- No sliding if the type of the object is not established yet, if
3549 -- it is an unconstrained type whose actual subtype comes from the
3550 -- aggregate, or if the two types are identical.
3552 if not Is_Array_Type (Obj_Type) then
3555 elsif not Is_Constrained (Obj_Type) then
3558 elsif Typ = Obj_Type then
3562 -- Sliding can only occur along the first dimension
3564 Get_Index_Bounds (First_Index (Typ), L1, H1);
3565 Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
3567 if not Is_Static_Expression (L1)
3568 or else not Is_Static_Expression (L2)
3569 or else not Is_Static_Expression (H1)
3570 or else not Is_Static_Expression (H2)
3574 return Expr_Value (L1) /= Expr_Value (L2)
3575 or else Expr_Value (H1) /= Expr_Value (H2);
3584 procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is
3585 Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
3586 Aggr_Hi : constant Node_Id := Aggr_High (Dim);
3587 -- The bounds of the aggregate for this dimension.
3589 Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
3590 -- The index type for this dimension.
3592 Need_To_Check : Boolean := False;
3594 Choices_Lo : Node_Id := Empty;
3595 Choices_Hi : Node_Id := Empty;
3596 -- The lowest and highest discrete choices for a named sub-aggregate
3598 Nb_Choices : Int := -1;
3599 -- The number of discrete non-others choices in this sub-aggregate
3601 Nb_Elements : Uint := Uint_0;
3602 -- The number of elements in a positional aggregate
3604 Cond : Node_Id := Empty;
3611 -- Check if we have an others choice. If we do make sure that this
3612 -- sub-aggregate contains at least one element in addition to the
3615 if Range_Checks_Suppressed (Ind_Typ) then
3616 Need_To_Check := False;
3618 elsif Present (Expressions (Sub_Aggr))
3619 and then Present (Component_Associations (Sub_Aggr))
3621 Need_To_Check := True;
3623 elsif Present (Component_Associations (Sub_Aggr)) then
3624 Assoc := Last (Component_Associations (Sub_Aggr));
3626 if Nkind (First (Choices (Assoc))) /= N_Others_Choice then
3627 Need_To_Check := False;
3630 -- Count the number of discrete choices. Start with -1
3631 -- because the others choice does not count.
3634 Assoc := First (Component_Associations (Sub_Aggr));
3635 while Present (Assoc) loop
3636 Choice := First (Choices (Assoc));
3637 while Present (Choice) loop
3638 Nb_Choices := Nb_Choices + 1;
3645 -- If there is only an others choice nothing to do
3647 Need_To_Check := (Nb_Choices > 0);
3651 Need_To_Check := False;
3654 -- If we are dealing with a positional sub-aggregate with an
3655 -- others choice then compute the number or positional elements.
3657 if Need_To_Check and then Present (Expressions (Sub_Aggr)) then
3658 Expr := First (Expressions (Sub_Aggr));
3659 Nb_Elements := Uint_0;
3660 while Present (Expr) loop
3661 Nb_Elements := Nb_Elements + 1;
3665 -- If the aggregate contains discrete choices and an others choice
3666 -- compute the smallest and largest discrete choice values.
3668 elsif Need_To_Check then
3669 Compute_Choices_Lo_And_Choices_Hi : declare
3671 Table : Case_Table_Type (1 .. Nb_Choices);
3672 -- Used to sort all the different choice values
3679 Assoc := First (Component_Associations (Sub_Aggr));
3680 while Present (Assoc) loop
3681 Choice := First (Choices (Assoc));
3682 while Present (Choice) loop
3683 if Nkind (Choice) = N_Others_Choice then
3687 Get_Index_Bounds (Choice, Low, High);
3688 Table (J).Choice_Lo := Low;
3689 Table (J).Choice_Hi := High;
3698 -- Sort the discrete choices
3700 Sort_Case_Table (Table);
3702 Choices_Lo := Table (1).Choice_Lo;
3703 Choices_Hi := Table (Nb_Choices).Choice_Hi;
3704 end Compute_Choices_Lo_And_Choices_Hi;
3707 -- If no others choice in this sub-aggregate, or the aggregate
3708 -- comprises only an others choice, nothing to do.
3710 if not Need_To_Check then
3713 -- If we are dealing with an aggregate containing an others
3714 -- choice and positional components, we generate the following test:
3716 -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) >
3717 -- Ind_Typ'Pos (Aggr_Hi)
3719 -- raise Constraint_Error;
3722 elsif Nb_Elements > Uint_0 then
3728 Make_Attribute_Reference (Loc,
3729 Prefix => New_Reference_To (Ind_Typ, Loc),
3730 Attribute_Name => Name_Pos,
3733 (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
3734 Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
3737 Make_Attribute_Reference (Loc,
3738 Prefix => New_Reference_To (Ind_Typ, Loc),
3739 Attribute_Name => Name_Pos,
3740 Expressions => New_List (
3741 Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
3743 -- If we are dealing with an aggregate containing an others
3744 -- choice and discrete choices we generate the following test:
3746 -- [constraint_error when
3747 -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi];
3755 Duplicate_Subexpr_Move_Checks (Choices_Lo),
3757 Duplicate_Subexpr_Move_Checks (Aggr_Lo)),
3762 Duplicate_Subexpr (Choices_Hi),
3764 Duplicate_Subexpr (Aggr_Hi)));
3767 if Present (Cond) then
3769 Make_Raise_Constraint_Error (Loc,
3771 Reason => CE_Length_Check_Failed));
3774 -- Now look inside the sub-aggregate to see if there is more work
3776 if Dim < Aggr_Dimension then
3778 -- Process positional components
3780 if Present (Expressions (Sub_Aggr)) then
3781 Expr := First (Expressions (Sub_Aggr));
3782 while Present (Expr) loop
3783 Others_Check (Expr, Dim + 1);
3788 -- Process component associations
3790 if Present (Component_Associations (Sub_Aggr)) then
3791 Assoc := First (Component_Associations (Sub_Aggr));
3792 while Present (Assoc) loop
3793 Expr := Expression (Assoc);
3794 Others_Check (Expr, Dim + 1);
3801 -- Remaining Expand_Array_Aggregate variables
3804 -- Holds the temporary aggregate value
3807 -- Holds the declaration of Tmp
3809 Aggr_Code : List_Id;
3810 Parent_Node : Node_Id;
3811 Parent_Kind : Node_Kind;
3813 -- Start of processing for Expand_Array_Aggregate
3816 -- Do not touch the special aggregates of attributes used for Asm calls
3818 if Is_RTE (Ctyp, RE_Asm_Input_Operand)
3819 or else Is_RTE (Ctyp, RE_Asm_Output_Operand)
3824 -- If the semantic analyzer has determined that aggregate N will raise
3825 -- Constraint_Error at run-time, then the aggregate node has been
3826 -- replaced with an N_Raise_Constraint_Error node and we should
3829 pragma Assert (not Raises_Constraint_Error (N));
3833 -- Check that the index range defined by aggregate bounds is
3834 -- compatible with corresponding index subtype.
3836 Index_Compatibility_Check : declare
3837 Aggr_Index_Range : Node_Id := First_Index (Typ);
3838 -- The current aggregate index range
3840 Index_Constraint : Node_Id := First_Index (Etype (Typ));
3841 -- The corresponding index constraint against which we have to
3842 -- check the above aggregate index range.
3845 Compute_Others_Present (N, 1);
3847 for J in 1 .. Aggr_Dimension loop
3848 -- There is no need to emit a check if an others choice is
3849 -- present for this array aggregate dimension since in this
3850 -- case one of N's sub-aggregates has taken its bounds from the
3851 -- context and these bounds must have been checked already. In
3852 -- addition all sub-aggregates corresponding to the same
3853 -- dimension must all have the same bounds (checked in (c) below).
3855 if not Range_Checks_Suppressed (Etype (Index_Constraint))
3856 and then not Others_Present (J)
3858 -- We don't use Checks.Apply_Range_Check here because it
3859 -- emits a spurious check. Namely it checks that the range
3860 -- defined by the aggregate bounds is non empty. But we know
3861 -- this already if we get here.
3863 Check_Bounds (Aggr_Index_Range, Index_Constraint);
3866 -- Save the low and high bounds of the aggregate index as well
3867 -- as the index type for later use in checks (b) and (c) below.
3869 Aggr_Low (J) := Low_Bound (Aggr_Index_Range);
3870 Aggr_High (J) := High_Bound (Aggr_Index_Range);
3872 Aggr_Index_Typ (J) := Etype (Index_Constraint);
3874 Next_Index (Aggr_Index_Range);
3875 Next_Index (Index_Constraint);
3877 end Index_Compatibility_Check;
3881 -- If an others choice is present check that no aggregate
3882 -- index is outside the bounds of the index constraint.
3884 Others_Check (N, 1);
3888 -- For multidimensional arrays make sure that all subaggregates
3889 -- corresponding to the same dimension have the same bounds.
3891 if Aggr_Dimension > 1 then
3892 Check_Same_Aggr_Bounds (N, 1);
3897 -- Here we test for is packed array aggregate that we can handle
3898 -- at compile time. If so, return with transformation done. Note
3899 -- that we do this even if the aggregate is nested, because once
3900 -- we have done this processing, there is no more nested aggregate!
3902 if Packed_Array_Aggregate_Handled (N) then
3906 -- At this point we try to convert to positional form
3908 Convert_To_Positional (N);
3910 -- if the result is no longer an aggregate (e.g. it may be a string
3911 -- literal, or a temporary which has the needed value), then we are
3912 -- done, since there is no longer a nested aggregate.
3914 if Nkind (N) /= N_Aggregate then
3917 -- We are also done if the result is an analyzed aggregate
3918 -- This case could use more comments ???
3921 and then N /= Original_Node (N)
3926 -- Now see if back end processing is possible
3928 if Backend_Processing_Possible (N) then
3930 -- If the aggregate is static but the constraints are not, build
3931 -- a static subtype for the aggregate, so that Gigi can place it
3932 -- in static memory. Perform an unchecked_conversion to the non-
3933 -- static type imposed by the context.
3936 Itype : constant Entity_Id := Etype (N);
3938 Needs_Type : Boolean := False;
3941 Index := First_Index (Itype);
3943 while Present (Index) loop
3944 if not Is_Static_Subtype (Etype (Index)) then
3953 Build_Constrained_Type (Positional => True);
3954 Rewrite (N, Unchecked_Convert_To (Itype, N));
3964 -- Delay expansion for nested aggregates it will be taken care of
3965 -- when the parent aggregate is expanded
3967 Parent_Node := Parent (N);
3968 Parent_Kind := Nkind (Parent_Node);
3970 if Parent_Kind = N_Qualified_Expression then
3971 Parent_Node := Parent (Parent_Node);
3972 Parent_Kind := Nkind (Parent_Node);
3975 if Parent_Kind = N_Aggregate
3976 or else Parent_Kind = N_Extension_Aggregate
3977 or else Parent_Kind = N_Component_Association
3978 or else (Parent_Kind = N_Object_Declaration
3979 and then Controlled_Type (Typ))
3980 or else (Parent_Kind = N_Assignment_Statement
3981 and then Inside_Init_Proc)
3983 Set_Expansion_Delayed (N);
3989 -- Look if in place aggregate expansion is possible
3991 -- For object declarations we build the aggregate in place, unless
3992 -- the array is bit-packed or the component is controlled.
3994 -- For assignments we do the assignment in place if all the component
3995 -- associations have compile-time known values. For other cases we
3996 -- create a temporary. The analysis for safety of on-line assignment
3997 -- is delicate, i.e. we don't know how to do it fully yet ???
3999 if Requires_Transient_Scope (Typ) then
4000 Establish_Transient_Scope
4001 (N, Sec_Stack => Has_Controlled_Component (Typ));
4004 if Has_Default_Init_Comps (N) then
4005 Maybe_In_Place_OK := False;
4007 Maybe_In_Place_OK :=
4008 Comes_From_Source (N)
4009 and then Nkind (Parent (N)) = N_Assignment_Statement
4010 and then not Is_Bit_Packed_Array (Typ)
4011 and then not Has_Controlled_Component (Typ)
4012 and then In_Place_Assign_OK;
4015 if not Has_Default_Init_Comps (N)
4016 and then Comes_From_Source (Parent (N))
4017 and then Nkind (Parent (N)) = N_Object_Declaration
4018 and then not Must_Slide (N, Typ)
4019 and then N = Expression (Parent (N))
4020 and then not Is_Bit_Packed_Array (Typ)
4021 and then not Has_Controlled_Component (Typ)
4022 and then not Has_Address_Clause (Parent (N))
4024 Tmp := Defining_Identifier (Parent (N));
4025 Set_No_Initialization (Parent (N));
4026 Set_Expression (Parent (N), Empty);
4028 -- Set the type of the entity, for use in the analysis of the
4029 -- subsequent indexed assignments. If the nominal type is not
4030 -- constrained, build a subtype from the known bounds of the
4031 -- aggregate. If the declaration has a subtype mark, use it,
4032 -- otherwise use the itype of the aggregate.
4034 if not Is_Constrained (Typ) then
4035 Build_Constrained_Type (Positional => False);
4036 elsif Is_Entity_Name (Object_Definition (Parent (N)))
4037 and then Is_Constrained (Entity (Object_Definition (Parent (N))))
4039 Set_Etype (Tmp, Entity (Object_Definition (Parent (N))));
4041 Set_Size_Known_At_Compile_Time (Typ, False);
4042 Set_Etype (Tmp, Typ);
4045 elsif Maybe_In_Place_OK
4046 and then Is_Entity_Name (Name (Parent (N)))
4048 Tmp := Entity (Name (Parent (N)));
4050 if Etype (Tmp) /= Etype (N) then
4051 Apply_Length_Check (N, Etype (Tmp));
4053 if Nkind (N) = N_Raise_Constraint_Error then
4055 -- Static error, nothing further to expand
4061 elsif Maybe_In_Place_OK
4062 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
4063 and then Is_Entity_Name (Prefix (Name (Parent (N))))
4065 Tmp := Name (Parent (N));
4067 if Etype (Tmp) /= Etype (N) then
4068 Apply_Length_Check (N, Etype (Tmp));
4071 elsif Maybe_In_Place_OK
4072 and then Nkind (Name (Parent (N))) = N_Slice
4073 and then Safe_Slice_Assignment (N)
4075 -- Safe_Slice_Assignment rewrites assignment as a loop
4081 -- In place aggregate expansion is not possible
4084 Maybe_In_Place_OK := False;
4085 Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
4087 Make_Object_Declaration
4089 Defining_Identifier => Tmp,
4090 Object_Definition => New_Occurrence_Of (Typ, Loc));
4091 Set_No_Initialization (Tmp_Decl, True);
4093 -- If we are within a loop, the temporary will be pushed on the
4094 -- stack at each iteration. If the aggregate is the expression for
4095 -- an allocator, it will be immediately copied to the heap and can
4096 -- be reclaimed at once. We create a transient scope around the
4097 -- aggregate for this purpose.
4099 if Ekind (Current_Scope) = E_Loop
4100 and then Nkind (Parent (Parent (N))) = N_Allocator
4102 Establish_Transient_Scope (N, False);
4105 Insert_Action (N, Tmp_Decl);
4108 -- Construct and insert the aggregate code. We can safely suppress
4109 -- index checks because this code is guaranteed not to raise CE
4110 -- on index checks. However we should *not* suppress all checks.
4116 if Nkind (Tmp) = N_Defining_Identifier then
4117 Target := New_Reference_To (Tmp, Loc);
4121 if Has_Default_Init_Comps (N) then
4123 -- Ada 0Y (AI-287): This case has not been analyzed???
4125 pragma Assert (False);
4129 -- Name in assignment is explicit dereference.
4131 Target := New_Copy (Tmp);
4135 Build_Array_Aggr_Code (N,
4137 Index => First_Index (Typ),
4139 Scalar_Comp => Is_Scalar_Type (Ctyp));
4142 if Comes_From_Source (Tmp) then
4143 Insert_Actions_After (Parent (N), Aggr_Code);
4146 Insert_Actions (N, Aggr_Code);
4149 -- If the aggregate has been assigned in place, remove the original
4152 if Nkind (Parent (N)) = N_Assignment_Statement
4153 and then Maybe_In_Place_OK
4155 Rewrite (Parent (N), Make_Null_Statement (Loc));
4157 elsif Nkind (Parent (N)) /= N_Object_Declaration
4158 or else Tmp /= Defining_Identifier (Parent (N))
4160 Rewrite (N, New_Occurrence_Of (Tmp, Loc));
4161 Analyze_And_Resolve (N, Typ);
4163 end Expand_Array_Aggregate;
4165 ------------------------
4166 -- Expand_N_Aggregate --
4167 ------------------------
4169 procedure Expand_N_Aggregate (N : Node_Id) is
4171 if Is_Record_Type (Etype (N)) then
4172 Expand_Record_Aggregate (N);
4174 Expand_Array_Aggregate (N);
4178 when RE_Not_Available =>
4180 end Expand_N_Aggregate;
4182 ----------------------------------
4183 -- Expand_N_Extension_Aggregate --
4184 ----------------------------------
4186 -- If the ancestor part is an expression, add a component association for
4187 -- the parent field. If the type of the ancestor part is not the direct
4188 -- parent of the expected type, build recursively the needed ancestors.
4189 -- If the ancestor part is a subtype_mark, replace aggregate with a decla-
4190 -- ration for a temporary of the expected type, followed by individual
4191 -- assignments to the given components.
4193 procedure Expand_N_Extension_Aggregate (N : Node_Id) is
4194 Loc : constant Source_Ptr := Sloc (N);
4195 A : constant Node_Id := Ancestor_Part (N);
4196 Typ : constant Entity_Id := Etype (N);
4199 -- If the ancestor is a subtype mark, an init proc must be called
4200 -- on the resulting object which thus has to be materialized in
4203 if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
4204 Convert_To_Assignments (N, Typ);
4206 -- The extension aggregate is transformed into a record aggregate
4207 -- of the following form (c1 and c2 are inherited components)
4209 -- (Exp with c3 => a, c4 => b)
4210 -- ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b)
4215 -- No tag is needed in the case of Java_VM
4218 Expand_Record_Aggregate (N,
4221 Expand_Record_Aggregate (N,
4222 Orig_Tag => New_Occurrence_Of (Access_Disp_Table (Typ), Loc),
4228 when RE_Not_Available =>
4230 end Expand_N_Extension_Aggregate;
4232 -----------------------------
4233 -- Expand_Record_Aggregate --
4234 -----------------------------
4236 procedure Expand_Record_Aggregate
4238 Orig_Tag : Node_Id := Empty;
4239 Parent_Expr : Node_Id := Empty)
4241 Loc : constant Source_Ptr := Sloc (N);
4242 Comps : constant List_Id := Component_Associations (N);
4243 Typ : constant Entity_Id := Etype (N);
4244 Base_Typ : constant Entity_Id := Base_Type (Typ);
4246 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean;
4247 -- Checks the presence of a nested aggregate which needs Late_Expansion
4248 -- or the presence of tagged components which may need tag adjustment.
4250 --------------------------------------------------
4251 -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
4252 --------------------------------------------------
4254 function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is
4264 while Present (C) loop
4265 if Nkind (Expression (C)) = N_Qualified_Expression then
4266 Expr_Q := Expression (Expression (C));
4268 Expr_Q := Expression (C);
4271 -- Return true if the aggregate has any associations for
4272 -- tagged components that may require tag adjustment.
4273 -- These are cases where the source expression may have
4274 -- a tag that could differ from the component tag (e.g.,
4275 -- can occur for type conversions and formal parameters).
4276 -- (Tag adjustment is not needed if Java_VM because object
4277 -- tags are implicit in the JVM.)
4279 if Is_Tagged_Type (Etype (Expr_Q))
4280 and then (Nkind (Expr_Q) = N_Type_Conversion
4281 or else (Is_Entity_Name (Expr_Q)
4282 and then Ekind (Entity (Expr_Q)) in Formal_Kind))
4283 and then not Java_VM
4288 if Is_Delayed_Aggregate (Expr_Q) then
4296 end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps;
4298 -- Remaining Expand_Record_Aggregate variables
4300 Tag_Value : Node_Id;
4304 -- Start of processing for Expand_Record_Aggregate
4307 -- If the aggregate is to be assigned to an atomic variable, we
4308 -- have to prevent a piecemeal assignment even if the aggregate
4309 -- is to be expanded. We create a temporary for the aggregate, and
4310 -- assign the temporary instead, so that the back end can generate
4311 -- an atomic move for it.
4314 and then (Nkind (Parent (N)) = N_Object_Declaration
4315 or else Nkind (Parent (N)) = N_Assignment_Statement)
4316 and then Comes_From_Source (Parent (N))
4318 Expand_Atomic_Aggregate (N, Typ);
4322 -- Gigi doesn't handle properly temporaries of variable size
4323 -- so we generate it in the front-end
4325 if not Size_Known_At_Compile_Time (Typ) then
4326 Convert_To_Assignments (N, Typ);
4328 -- Temporaries for controlled aggregates need to be attached to a
4329 -- final chain in order to be properly finalized, so it has to
4330 -- be created in the front-end
4332 elsif Is_Controlled (Typ)
4333 or else Has_Controlled_Component (Base_Type (Typ))
4335 Convert_To_Assignments (N, Typ);
4337 -- Ada 0Y (AI-287): In case of default initialized components we convert
4338 -- the aggregate into assignments.
4340 elsif Has_Default_Init_Comps (N) then
4341 Convert_To_Assignments (N, Typ);
4343 elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then
4344 Convert_To_Assignments (N, Typ);
4346 -- If an ancestor is private, some components are not inherited and
4347 -- we cannot expand into a record aggregate
4349 elsif Has_Private_Ancestor (Typ) then
4350 Convert_To_Assignments (N, Typ);
4352 -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
4353 -- is not able to handle the aggregate for Late_Request.
4355 elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
4356 Convert_To_Assignments (N, Typ);
4358 -- If some components are mutable, the size of the aggregate component
4359 -- may be disctinct from the default size of the type component, so
4360 -- we need to expand to insure that the back-end copies the proper
4361 -- size of the data.
4363 elsif Has_Mutable_Components (Typ) then
4364 Convert_To_Assignments (N, Typ);
4366 -- If the type involved has any non-bit aligned components, then
4367 -- we are not sure that the back end can handle this case correctly.
4369 elsif Type_May_Have_Bit_Aligned_Components (Typ) then
4370 Convert_To_Assignments (N, Typ);
4372 -- In all other cases we generate a proper aggregate that
4373 -- can be handled by gigi.
4376 -- If no discriminants, nothing special to do
4378 if not Has_Discriminants (Typ) then
4381 -- Case of discriminants present
4383 elsif Is_Derived_Type (Typ) then
4385 -- For untagged types, non-stored discriminants are replaced
4386 -- with stored discriminants, which are the ones that gigi uses
4387 -- to describe the type and its components.
4389 Generate_Aggregate_For_Derived_Type : declare
4390 Constraints : constant List_Id := New_List;
4391 First_Comp : Node_Id;
4392 Discriminant : Entity_Id;
4394 Num_Disc : Int := 0;
4395 Num_Gird : Int := 0;
4397 procedure Prepend_Stored_Values (T : Entity_Id);
4398 -- Scan the list of stored discriminants of the type, and
4399 -- add their values to the aggregate being built.
4401 ---------------------------
4402 -- Prepend_Stored_Values --
4403 ---------------------------
4405 procedure Prepend_Stored_Values (T : Entity_Id) is
4407 Discriminant := First_Stored_Discriminant (T);
4409 while Present (Discriminant) loop
4411 Make_Component_Association (Loc,
4413 New_List (New_Occurrence_Of (Discriminant, Loc)),
4417 Get_Discriminant_Value (
4420 Discriminant_Constraint (Typ))));
4422 if No (First_Comp) then
4423 Prepend_To (Component_Associations (N), New_Comp);
4425 Insert_After (First_Comp, New_Comp);
4428 First_Comp := New_Comp;
4429 Next_Stored_Discriminant (Discriminant);
4431 end Prepend_Stored_Values;
4433 -- Start of processing for Generate_Aggregate_For_Derived_Type
4436 -- Remove the associations for the discriminant of
4437 -- the derived type.
4439 First_Comp := First (Component_Associations (N));
4441 while Present (First_Comp) loop
4445 if Ekind (Entity (First (Choices (Comp)))) =
4449 Num_Disc := Num_Disc + 1;
4453 -- Insert stored discriminant associations in the correct
4454 -- order. If there are more stored discriminants than new
4455 -- discriminants, there is at least one new discriminant
4456 -- that constrains more than one of the stored discriminants.
4457 -- In this case we need to construct a proper subtype of
4458 -- the parent type, in order to supply values to all the
4459 -- components. Otherwise there is one-one correspondence
4460 -- between the constraints and the stored discriminants.
4462 First_Comp := Empty;
4464 Discriminant := First_Stored_Discriminant (Base_Type (Typ));
4466 while Present (Discriminant) loop
4467 Num_Gird := Num_Gird + 1;
4468 Next_Stored_Discriminant (Discriminant);
4471 -- Case of more stored discriminants than new discriminants
4473 if Num_Gird > Num_Disc then
4475 -- Create a proper subtype of the parent type, which is
4476 -- the proper implementation type for the aggregate, and
4477 -- convert it to the intended target type.
4479 Discriminant := First_Stored_Discriminant (Base_Type (Typ));
4481 while Present (Discriminant) loop
4484 Get_Discriminant_Value (
4487 Discriminant_Constraint (Typ)));
4488 Append (New_Comp, Constraints);
4489 Next_Stored_Discriminant (Discriminant);
4493 Make_Subtype_Declaration (Loc,
4494 Defining_Identifier =>
4495 Make_Defining_Identifier (Loc,
4496 New_Internal_Name ('T')),
4497 Subtype_Indication =>
4498 Make_Subtype_Indication (Loc,
4500 New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
4502 Make_Index_Or_Discriminant_Constraint
4503 (Loc, Constraints)));
4505 Insert_Action (N, Decl);
4506 Prepend_Stored_Values (Base_Type (Typ));
4508 Set_Etype (N, Defining_Identifier (Decl));
4511 Rewrite (N, Unchecked_Convert_To (Typ, N));
4514 -- Case where we do not have fewer new discriminants than
4515 -- stored discriminants, so in this case we can simply
4516 -- use the stored discriminants of the subtype.
4519 Prepend_Stored_Values (Typ);
4521 end Generate_Aggregate_For_Derived_Type;
4524 if Is_Tagged_Type (Typ) then
4526 -- The tagged case, _parent and _tag component must be created.
4528 -- Reset null_present unconditionally. tagged records always have
4529 -- at least one field (the tag or the parent)
4531 Set_Null_Record_Present (N, False);
4533 -- When the current aggregate comes from the expansion of an
4534 -- extension aggregate, the parent expr is replaced by an
4535 -- aggregate formed by selected components of this expr
4537 if Present (Parent_Expr)
4538 and then Is_Empty_List (Comps)
4540 Comp := First_Entity (Typ);
4541 while Present (Comp) loop
4543 -- Skip all entities that aren't discriminants or components
4545 if Ekind (Comp) /= E_Discriminant
4546 and then Ekind (Comp) /= E_Component
4550 -- Skip all expander-generated components
4553 not Comes_From_Source (Original_Record_Component (Comp))
4559 Make_Selected_Component (Loc,
4561 Unchecked_Convert_To (Typ,
4562 Duplicate_Subexpr (Parent_Expr, True)),
4564 Selector_Name => New_Occurrence_Of (Comp, Loc));
4567 Make_Component_Association (Loc,
4569 New_List (New_Occurrence_Of (Comp, Loc)),
4573 Analyze_And_Resolve (New_Comp, Etype (Comp));
4580 -- Compute the value for the Tag now, if the type is a root it
4581 -- will be included in the aggregate right away, otherwise it will
4582 -- be propagated to the parent aggregate
4584 if Present (Orig_Tag) then
4585 Tag_Value := Orig_Tag;
4589 Tag_Value := New_Occurrence_Of (Access_Disp_Table (Typ), Loc);
4592 -- For a derived type, an aggregate for the parent is formed with
4593 -- all the inherited components.
4595 if Is_Derived_Type (Typ) then
4598 First_Comp : Node_Id;
4599 Parent_Comps : List_Id;
4600 Parent_Aggr : Node_Id;
4601 Parent_Name : Node_Id;
4604 -- Remove the inherited component association from the
4605 -- aggregate and store them in the parent aggregate
4607 First_Comp := First (Component_Associations (N));
4608 Parent_Comps := New_List;
4610 while Present (First_Comp)
4611 and then Scope (Original_Record_Component (
4612 Entity (First (Choices (First_Comp))))) /= Base_Typ
4617 Append (Comp, Parent_Comps);
4620 Parent_Aggr := Make_Aggregate (Loc,
4621 Component_Associations => Parent_Comps);
4622 Set_Etype (Parent_Aggr, Etype (Base_Type (Typ)));
4624 -- Find the _parent component
4626 Comp := First_Component (Typ);
4627 while Chars (Comp) /= Name_uParent loop
4628 Comp := Next_Component (Comp);
4631 Parent_Name := New_Occurrence_Of (Comp, Loc);
4633 -- Insert the parent aggregate
4635 Prepend_To (Component_Associations (N),
4636 Make_Component_Association (Loc,
4637 Choices => New_List (Parent_Name),
4638 Expression => Parent_Aggr));
4640 -- Expand recursively the parent propagating the right Tag
4642 Expand_Record_Aggregate (
4643 Parent_Aggr, Tag_Value, Parent_Expr);
4646 -- For a root type, the tag component is added (unless compiling
4647 -- for the Java VM, where tags are implicit).
4649 elsif not Java_VM then
4651 Tag_Name : constant Node_Id :=
4652 New_Occurrence_Of (Tag_Component (Typ), Loc);
4653 Typ_Tag : constant Entity_Id := RTE (RE_Tag);
4654 Conv_Node : constant Node_Id :=
4655 Unchecked_Convert_To (Typ_Tag, Tag_Value);
4658 Set_Etype (Conv_Node, Typ_Tag);
4659 Prepend_To (Component_Associations (N),
4660 Make_Component_Association (Loc,
4661 Choices => New_List (Tag_Name),
4662 Expression => Conv_Node));
4667 end Expand_Record_Aggregate;
4669 ----------------------------
4670 -- Has_Default_Init_Comps --
4671 ----------------------------
4673 function Has_Default_Init_Comps (N : Node_Id) return Boolean is
4674 Comps : constant List_Id := Component_Associations (N);
4678 pragma Assert (Nkind (N) = N_Aggregate
4679 or else Nkind (N) = N_Extension_Aggregate);
4685 -- Check if any direct component has default initialized components
4688 while Present (C) loop
4689 if Box_Present (C) then
4696 -- Recursive call in case of aggregate expression
4699 while Present (C) loop
4700 Expr := Expression (C);
4703 and then (Nkind (Expr) = N_Aggregate
4704 or else Nkind (Expr) = N_Extension_Aggregate)
4705 and then Has_Default_Init_Comps (Expr)
4714 end Has_Default_Init_Comps;
4716 --------------------------
4717 -- Is_Delayed_Aggregate --
4718 --------------------------
4720 function Is_Delayed_Aggregate (N : Node_Id) return Boolean is
4721 Node : Node_Id := N;
4722 Kind : Node_Kind := Nkind (Node);
4725 if Kind = N_Qualified_Expression then
4726 Node := Expression (Node);
4727 Kind := Nkind (Node);
4730 if Kind /= N_Aggregate and then Kind /= N_Extension_Aggregate then
4733 return Expansion_Delayed (Node);
4735 end Is_Delayed_Aggregate;
4737 --------------------
4738 -- Late_Expansion --
4739 --------------------
4741 function Late_Expansion
4745 Flist : Node_Id := Empty;
4746 Obj : Entity_Id := Empty) return List_Id is
4748 if Is_Record_Type (Etype (N)) then
4749 return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj);
4750 elsif Is_Array_Type (Etype (N)) then
4752 Build_Array_Aggr_Code
4754 Ctype => Component_Type (Etype (N)),
4755 Index => First_Index (Typ),
4757 Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
4761 pragma Assert (False);
4766 ----------------------------------
4767 -- Make_OK_Assignment_Statement --
4768 ----------------------------------
4770 function Make_OK_Assignment_Statement
4773 Expression : Node_Id) return Node_Id
4776 Set_Assignment_OK (Name);
4777 return Make_Assignment_Statement (Sloc, Name, Expression);
4778 end Make_OK_Assignment_Statement;
4780 -----------------------
4781 -- Number_Of_Choices --
4782 -----------------------
4784 function Number_Of_Choices (N : Node_Id) return Nat is
4788 Nb_Choices : Nat := 0;
4791 if Present (Expressions (N)) then
4795 Assoc := First (Component_Associations (N));
4796 while Present (Assoc) loop
4798 Choice := First (Choices (Assoc));
4799 while Present (Choice) loop
4801 if Nkind (Choice) /= N_Others_Choice then
4802 Nb_Choices := Nb_Choices + 1;
4812 end Number_Of_Choices;
4814 ------------------------------------
4815 -- Packed_Array_Aggregate_Handled --
4816 ------------------------------------
4818 -- The current version of this procedure will handle at compile time
4819 -- any array aggregate that meets these conditions:
4821 -- One dimensional, bit packed
4822 -- Underlying packed type is modular type
4823 -- Bounds are within 32-bit Int range
4824 -- All bounds and values are static
4826 function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is
4827 Loc : constant Source_Ptr := Sloc (N);
4828 Typ : constant Entity_Id := Etype (N);
4829 Ctyp : constant Entity_Id := Component_Type (Typ);
4831 Not_Handled : exception;
4832 -- Exception raised if this aggregate cannot be handled
4835 -- For now, handle only one dimensional bit packed arrays
4837 if not Is_Bit_Packed_Array (Typ)
4838 or else Number_Dimensions (Typ) > 1
4839 or else not Is_Modular_Integer_Type (Packed_Array_Type (Typ))
4845 Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
4849 -- Bounds of index type
4853 -- Values of bounds if compile time known
4855 function Get_Component_Val (N : Node_Id) return Uint;
4856 -- Given a expression value N of the component type Ctyp, returns
4857 -- A value of Csiz (component size) bits representing this value.
4858 -- If the value is non-static or any other reason exists why the
4859 -- value cannot be returned, then Not_Handled is raised.
4861 -----------------------
4862 -- Get_Component_Val --
4863 -----------------------
4865 function Get_Component_Val (N : Node_Id) return Uint is
4869 -- We have to analyze the expression here before doing any further
4870 -- processing here. The analysis of such expressions is deferred
4871 -- till expansion to prevent some problems of premature analysis.
4873 Analyze_And_Resolve (N, Ctyp);
4875 -- Must have a compile time value. String literals have to
4876 -- be converted into temporaries as well, because they cannot
4877 -- easily be converted into their bit representation.
4879 if not Compile_Time_Known_Value (N)
4880 or else Nkind (N) = N_String_Literal
4885 Val := Expr_Rep_Value (N);
4887 -- Adjust for bias, and strip proper number of bits
4889 if Has_Biased_Representation (Ctyp) then
4890 Val := Val - Expr_Value (Type_Low_Bound (Ctyp));
4893 return Val mod Uint_2 ** Csiz;
4894 end Get_Component_Val;
4896 -- Here we know we have a one dimensional bit packed array
4899 Get_Index_Bounds (First_Index (Typ), Lo, Hi);
4901 -- Cannot do anything if bounds are dynamic
4903 if not Compile_Time_Known_Value (Lo)
4905 not Compile_Time_Known_Value (Hi)
4910 -- Or are silly out of range of int bounds
4912 Lob := Expr_Value (Lo);
4913 Hib := Expr_Value (Hi);
4915 if not UI_Is_In_Int_Range (Lob)
4917 not UI_Is_In_Int_Range (Hib)
4922 -- At this stage we have a suitable aggregate for handling
4923 -- at compile time (the only remaining checks, are that the
4924 -- values of expressions in the aggregate are compile time
4925 -- known (check performed by Get_Component_Val), and that
4926 -- any subtypes or ranges are statically known.
4928 -- If the aggregate is not fully positional at this stage,
4929 -- then convert it to positional form. Either this will fail,
4930 -- in which case we can do nothing, or it will succeed, in
4931 -- which case we have succeeded in handling the aggregate,
4932 -- or it will stay an aggregate, in which case we have failed
4933 -- to handle this case.
4935 if Present (Component_Associations (N)) then
4936 Convert_To_Positional
4937 (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
4938 return Nkind (N) /= N_Aggregate;
4941 -- Otherwise we are all positional, so convert to proper value
4944 Lov : constant Nat := UI_To_Int (Lob);
4945 Hiv : constant Nat := UI_To_Int (Hib);
4947 Len : constant Nat := Int'Max (0, Hiv - Lov + 1);
4948 -- The length of the array (number of elements)
4950 Aggregate_Val : Uint;
4951 -- Value of aggregate. The value is set in the low order
4952 -- bits of this value. For the little-endian case, the
4953 -- values are stored from low-order to high-order and
4954 -- for the big-endian case the values are stored from
4955 -- high-order to low-order. Note that gigi will take care
4956 -- of the conversions to left justify the value in the big
4957 -- endian case (because of left justified modular type
4958 -- processing), so we do not have to worry about that here.
4961 -- Integer literal for resulting constructed value
4964 -- Shift count from low order for next value
4967 -- Shift increment for loop
4970 -- Next expression from positional parameters of aggregate
4973 -- For little endian, we fill up the low order bits of the
4974 -- target value. For big endian we fill up the high order
4975 -- bits of the target value (which is a left justified
4978 if Bytes_Big_Endian xor Debug_Flag_8 then
4979 Shift := Csiz * (Len - 1);
4986 -- Loop to set the values
4989 Aggregate_Val := Uint_0;
4991 Expr := First (Expressions (N));
4992 Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
4994 for J in 2 .. Len loop
4995 Shift := Shift + Incr;
4998 Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
5002 -- Now we can rewrite with the proper value
5005 Make_Integer_Literal (Loc,
5006 Intval => Aggregate_Val);
5007 Set_Print_In_Hex (Lit);
5009 -- Construct the expression using this literal. Note that it is
5010 -- important to qualify the literal with its proper modular type
5011 -- since universal integer does not have the required range and
5012 -- also this is a left justified modular type, which is important
5013 -- in the big-endian case.
5016 Unchecked_Convert_To (Typ,
5017 Make_Qualified_Expression (Loc,
5019 New_Occurrence_Of (Packed_Array_Type (Typ), Loc),
5020 Expression => Lit)));
5022 Analyze_And_Resolve (N, Typ);
5030 end Packed_Array_Aggregate_Handled;
5032 ----------------------------
5033 -- Has_Mutable_Components --
5034 ----------------------------
5036 function Has_Mutable_Components (Typ : Entity_Id) return Boolean is
5040 Comp := First_Component (Typ);
5042 while Present (Comp) loop
5043 if Is_Record_Type (Etype (Comp))
5044 and then Has_Discriminants (Etype (Comp))
5045 and then not Is_Constrained (Etype (Comp))
5050 Next_Component (Comp);
5054 end Has_Mutable_Components;
5056 ------------------------------
5057 -- Initialize_Discriminants --
5058 ------------------------------
5060 procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is
5061 Loc : constant Source_Ptr := Sloc (N);
5062 Bas : constant Entity_Id := Base_Type (Typ);
5063 Par : constant Entity_Id := Etype (Bas);
5064 Decl : constant Node_Id := Parent (Par);
5068 if Is_Tagged_Type (Bas)
5069 and then Is_Derived_Type (Bas)
5070 and then Has_Discriminants (Par)
5071 and then Has_Discriminants (Bas)
5072 and then Number_Discriminants (Bas) /= Number_Discriminants (Par)
5073 and then Nkind (Decl) = N_Full_Type_Declaration
5074 and then Nkind (Type_Definition (Decl)) = N_Record_Definition
5076 (Variant_Part (Component_List (Type_Definition (Decl))))
5077 and then Nkind (N) /= N_Extension_Aggregate
5080 -- Call init proc to set discriminants.
5081 -- There should eventually be a special procedure for this ???
5083 Ref := New_Reference_To (Defining_Identifier (N), Loc);
5084 Insert_Actions_After (N,
5085 Build_Initialization_Call (Sloc (N), Ref, Typ));
5087 end Initialize_Discriminants;
5089 ---------------------------
5090 -- Safe_Slice_Assignment --
5091 ---------------------------
5093 function Safe_Slice_Assignment (N : Node_Id) return Boolean is
5094 Loc : constant Source_Ptr := Sloc (Parent (N));
5095 Pref : constant Node_Id := Prefix (Name (Parent (N)));
5096 Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N)));
5104 -- Generate: for J in Range loop Pref (J) := Expr; end loop;
5106 if Comes_From_Source (N)
5107 and then No (Expressions (N))
5108 and then Nkind (First (Choices (First (Component_Associations (N)))))
5112 Expression (First (Component_Associations (N)));
5113 L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
5116 Make_Iteration_Scheme (Loc,
5117 Loop_Parameter_Specification =>
5118 Make_Loop_Parameter_Specification
5120 Defining_Identifier => L_J,
5121 Discrete_Subtype_Definition => Relocate_Node (Range_Node)));
5124 Make_Assignment_Statement (Loc,
5126 Make_Indexed_Component (Loc,
5127 Prefix => Relocate_Node (Pref),
5128 Expressions => New_List (New_Occurrence_Of (L_J, Loc))),
5129 Expression => Relocate_Node (Expr));
5131 -- Construct the final loop
5134 Make_Implicit_Loop_Statement
5135 (Node => Parent (N),
5136 Identifier => Empty,
5137 Iteration_Scheme => L_Iter,
5138 Statements => New_List (L_Body));
5140 -- Set type of aggregate to be type of lhs in assignment,
5141 -- to suppress redundant length checks.
5143 Set_Etype (N, Etype (Name (Parent (N))));
5145 Rewrite (Parent (N), Stat);
5146 Analyze (Parent (N));
5152 end Safe_Slice_Assignment;
5154 ---------------------
5155 -- Sort_Case_Table --
5156 ---------------------
5158 procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
5159 L : constant Int := Case_Table'First;
5160 U : constant Int := Case_Table'Last;
5169 T := Case_Table (K + 1);
5173 and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
5174 Expr_Value (T.Choice_Lo)
5176 Case_Table (J) := Case_Table (J - 1);
5180 Case_Table (J) := T;
5183 end Sort_Case_Table;
OSDN Git Service
