PR c++/86728 - C variadic generic lambda.
[official-gcc.git] / gcc / ada / exp_ch5.adb
blob7a373ab883bc6b46d451a0bf752a494189b1492b
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 5 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
10 -- --
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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
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 Errout; use Errout;
33 with Exp_Aggr; use Exp_Aggr;
34 with Exp_Ch6; use Exp_Ch6;
35 with Exp_Ch7; use Exp_Ch7;
36 with Exp_Ch11; use Exp_Ch11;
37 with Exp_Dbug; use Exp_Dbug;
38 with Exp_Pakd; use Exp_Pakd;
39 with Exp_Tss; use Exp_Tss;
40 with Exp_Util; use Exp_Util;
41 with Inline; use Inline;
42 with Namet; use Namet;
43 with Nlists; use Nlists;
44 with Nmake; use Nmake;
45 with Opt; use Opt;
46 with Restrict; use Restrict;
47 with Rident; use Rident;
48 with Rtsfind; use Rtsfind;
49 with Sinfo; use Sinfo;
50 with Sem; use Sem;
51 with Sem_Aux; use Sem_Aux;
52 with Sem_Ch3; use Sem_Ch3;
53 with Sem_Ch8; use Sem_Ch8;
54 with Sem_Ch13; use Sem_Ch13;
55 with Sem_Eval; use Sem_Eval;
56 with Sem_Res; use Sem_Res;
57 with Sem_Util; use Sem_Util;
58 with Snames; use Snames;
59 with Stand; use Stand;
60 with Stringt; use Stringt;
61 with Tbuild; use Tbuild;
62 with Uintp; use Uintp;
63 with Validsw; use Validsw;
65 package body Exp_Ch5 is
67 procedure Build_Formal_Container_Iteration
68 (N : Node_Id;
69 Container : Entity_Id;
70 Cursor : Entity_Id;
71 Init : out Node_Id;
72 Advance : out Node_Id;
73 New_Loop : out Node_Id);
74 -- Utility to create declarations and loop statement for both forms
75 -- of formal container iterators.
77 function Convert_To_Iterable_Type
78 (Container : Entity_Id;
79 Loc : Source_Ptr) return Node_Id;
80 -- Returns New_Occurrence_Of (Container), possibly converted to an ancestor
81 -- type, if the type of Container inherited the Iterable aspect from that
82 -- ancestor.
84 function Change_Of_Representation (N : Node_Id) return Boolean;
85 -- Determine if the right-hand side of assignment N is a type conversion
86 -- which requires a change of representation. Called only for the array
87 -- and record cases.
89 procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id);
90 -- N is an assignment which assigns an array value. This routine process
91 -- the various special cases and checks required for such assignments,
92 -- including change of representation. Rhs is normally simply the right-
93 -- hand side of the assignment, except that if the right-hand side is a
94 -- type conversion or a qualified expression, then the RHS is the actual
95 -- expression inside any such type conversions or qualifications.
97 function Expand_Assign_Array_Loop
98 (N : Node_Id;
99 Larray : Entity_Id;
100 Rarray : Entity_Id;
101 L_Type : Entity_Id;
102 R_Type : Entity_Id;
103 Ndim : Pos;
104 Rev : Boolean) return Node_Id;
105 -- N is an assignment statement which assigns an array value. This routine
106 -- expands the assignment into a loop (or nested loops for the case of a
107 -- multi-dimensional array) to do the assignment component by component.
108 -- Larray and Rarray are the entities of the actual arrays on the left-hand
109 -- and right-hand sides. L_Type and R_Type are the types of these arrays
110 -- (which may not be the same, due to either sliding, or to a change of
111 -- representation case). Ndim is the number of dimensions and the parameter
112 -- Rev indicates if the loops run normally (Rev = False), or reversed
113 -- (Rev = True). The value returned is the constructed loop statement.
114 -- Auxiliary declarations are inserted before node N using the standard
115 -- Insert_Actions mechanism.
117 procedure Expand_Assign_Record (N : Node_Id);
118 -- N is an assignment of an untagged record value. This routine handles
119 -- the case where the assignment must be made component by component,
120 -- either because the target is not byte aligned, or there is a change
121 -- of representation, or when we have a tagged type with a representation
122 -- clause (this last case is required because holes in the tagged type
123 -- might be filled with components from child types).
125 procedure Expand_Assign_With_Target_Names (N : Node_Id);
126 -- (AI12-0125): N is an assignment statement whose RHS contains occurrences
127 -- of @ that designate the value of the LHS of the assignment. If the LHS
128 -- is side-effect free the target names can be replaced with a copy of the
129 -- LHS; otherwise the semantics of the assignment is described in terms of
130 -- a procedure with an in-out parameter, and expanded as such.
132 procedure Expand_Formal_Container_Loop (N : Node_Id);
133 -- Use the primitives specified in an Iterable aspect to expand a loop
134 -- over a so-called formal container, primarily for SPARK usage.
136 procedure Expand_Formal_Container_Element_Loop (N : Node_Id);
137 -- Same, for an iterator of the form " For E of C". In this case the
138 -- iterator provides the name of the element, and the cursor is generated
139 -- internally.
141 procedure Expand_Iterator_Loop (N : Node_Id);
142 -- Expand loop over arrays and containers that uses the form "for X of C"
143 -- with an optional subtype mark, or "for Y in C".
145 procedure Expand_Iterator_Loop_Over_Container
146 (N : Node_Id;
147 Isc : Node_Id;
148 I_Spec : Node_Id;
149 Container : Node_Id;
150 Container_Typ : Entity_Id);
151 -- Expand loop over containers that uses the form "for X of C" with an
152 -- optional subtype mark, or "for Y in C". Isc is the iteration scheme.
153 -- I_Spec is the iterator specification and Container is either the
154 -- Container (for OF) or the iterator (for IN).
156 procedure Expand_Predicated_Loop (N : Node_Id);
157 -- Expand for loop over predicated subtype
159 function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
160 -- Generate the necessary code for controlled and tagged assignment, that
161 -- is to say, finalization of the target before, adjustment of the target
162 -- after and save and restore of the tag and finalization pointers which
163 -- are not 'part of the value' and must not be changed upon assignment. N
164 -- is the original Assignment node.
166 --------------------------------------
167 -- Build_Formal_Container_Iteration --
168 --------------------------------------
170 procedure Build_Formal_Container_Iteration
171 (N : Node_Id;
172 Container : Entity_Id;
173 Cursor : Entity_Id;
174 Init : out Node_Id;
175 Advance : out Node_Id;
176 New_Loop : out Node_Id)
178 Loc : constant Source_Ptr := Sloc (N);
179 Stats : constant List_Id := Statements (N);
180 Typ : constant Entity_Id := Base_Type (Etype (Container));
182 Has_Element_Op : constant Entity_Id :=
183 Get_Iterable_Type_Primitive (Typ, Name_Has_Element);
185 First_Op : Entity_Id;
186 Next_Op : Entity_Id;
188 begin
189 -- Use the proper set of primitives depending on the direction of
190 -- iteration. The legality of a reverse iteration has been checked
191 -- during analysis.
193 if Reverse_Present (Iterator_Specification (Iteration_Scheme (N))) then
194 First_Op := Get_Iterable_Type_Primitive (Typ, Name_Last);
195 Next_Op := Get_Iterable_Type_Primitive (Typ, Name_Previous);
197 else
198 First_Op := Get_Iterable_Type_Primitive (Typ, Name_First);
199 Next_Op := Get_Iterable_Type_Primitive (Typ, Name_Next);
200 end if;
202 -- Declaration for Cursor
204 Init :=
205 Make_Object_Declaration (Loc,
206 Defining_Identifier => Cursor,
207 Object_Definition => New_Occurrence_Of (Etype (First_Op), Loc),
208 Expression =>
209 Make_Function_Call (Loc,
210 Name => New_Occurrence_Of (First_Op, Loc),
211 Parameter_Associations => New_List (
212 Convert_To_Iterable_Type (Container, Loc))));
214 -- Statement that advances (in the right direction) cursor in loop
216 Advance :=
217 Make_Assignment_Statement (Loc,
218 Name => New_Occurrence_Of (Cursor, Loc),
219 Expression =>
220 Make_Function_Call (Loc,
221 Name => New_Occurrence_Of (Next_Op, Loc),
222 Parameter_Associations => New_List (
223 Convert_To_Iterable_Type (Container, Loc),
224 New_Occurrence_Of (Cursor, Loc))));
226 -- Iterator is rewritten as a while_loop
228 New_Loop :=
229 Make_Loop_Statement (Loc,
230 Iteration_Scheme =>
231 Make_Iteration_Scheme (Loc,
232 Condition =>
233 Make_Function_Call (Loc,
234 Name => New_Occurrence_Of (Has_Element_Op, Loc),
235 Parameter_Associations => New_List (
236 Convert_To_Iterable_Type (Container, Loc),
237 New_Occurrence_Of (Cursor, Loc)))),
238 Statements => Stats,
239 End_Label => Empty);
241 -- If the contruct has a specified loop name, preserve it in the new
242 -- loop, for possible use in exit statements.
244 if Present (Identifier (N))
245 and then Comes_From_Source (Identifier (N))
246 then
247 Set_Identifier (New_Loop, Identifier (N));
248 end if;
249 end Build_Formal_Container_Iteration;
251 ------------------------------
252 -- Change_Of_Representation --
253 ------------------------------
255 function Change_Of_Representation (N : Node_Id) return Boolean is
256 Rhs : constant Node_Id := Expression (N);
257 begin
258 return
259 Nkind (Rhs) = N_Type_Conversion
260 and then
261 not Same_Representation (Etype (Rhs), Etype (Expression (Rhs)));
262 end Change_Of_Representation;
264 ------------------------------
265 -- Convert_To_Iterable_Type --
266 ------------------------------
268 function Convert_To_Iterable_Type
269 (Container : Entity_Id;
270 Loc : Source_Ptr) return Node_Id
272 Typ : constant Entity_Id := Base_Type (Etype (Container));
273 Aspect : constant Node_Id := Find_Aspect (Typ, Aspect_Iterable);
274 Result : Node_Id;
276 begin
277 Result := New_Occurrence_Of (Container, Loc);
279 if Entity (Aspect) /= Typ then
280 Result :=
281 Make_Type_Conversion (Loc,
282 Subtype_Mark => New_Occurrence_Of (Entity (Aspect), Loc),
283 Expression => Result);
284 end if;
286 return Result;
287 end Convert_To_Iterable_Type;
289 -------------------------
290 -- Expand_Assign_Array --
291 -------------------------
293 -- There are two issues here. First, do we let Gigi do a block move, or
294 -- do we expand out into a loop? Second, we need to set the two flags
295 -- Forwards_OK and Backwards_OK which show whether the block move (or
296 -- corresponding loops) can be legitimately done in a forwards (low to
297 -- high) or backwards (high to low) manner.
299 procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id) is
300 Loc : constant Source_Ptr := Sloc (N);
302 Lhs : constant Node_Id := Name (N);
304 Act_Lhs : constant Node_Id := Get_Referenced_Object (Lhs);
305 Act_Rhs : Node_Id := Get_Referenced_Object (Rhs);
307 L_Type : constant Entity_Id :=
308 Underlying_Type (Get_Actual_Subtype (Act_Lhs));
309 R_Type : Entity_Id :=
310 Underlying_Type (Get_Actual_Subtype (Act_Rhs));
312 L_Slice : constant Boolean := Nkind (Act_Lhs) = N_Slice;
313 R_Slice : constant Boolean := Nkind (Act_Rhs) = N_Slice;
315 Crep : constant Boolean := Change_Of_Representation (N);
317 Larray : Node_Id;
318 Rarray : Node_Id;
320 Ndim : constant Pos := Number_Dimensions (L_Type);
322 Loop_Required : Boolean := False;
323 -- This switch is set to True if the array move must be done using
324 -- an explicit front end generated loop.
326 procedure Apply_Dereference (Arg : Node_Id);
327 -- If the argument is an access to an array, and the assignment is
328 -- converted into a procedure call, apply explicit dereference.
330 function Has_Address_Clause (Exp : Node_Id) return Boolean;
331 -- Test if Exp is a reference to an array whose declaration has
332 -- an address clause, or it is a slice of such an array.
334 function Is_Formal_Array (Exp : Node_Id) return Boolean;
335 -- Test if Exp is a reference to an array which is either a formal
336 -- parameter or a slice of a formal parameter. These are the cases
337 -- where hidden aliasing can occur.
339 function Is_Non_Local_Array (Exp : Node_Id) return Boolean;
340 -- Determine if Exp is a reference to an array variable which is other
341 -- than an object defined in the current scope, or a component or a
342 -- slice of such an object. Such objects can be aliased to parameters
343 -- (unlike local array references).
345 -----------------------
346 -- Apply_Dereference --
347 -----------------------
349 procedure Apply_Dereference (Arg : Node_Id) is
350 Typ : constant Entity_Id := Etype (Arg);
351 begin
352 if Is_Access_Type (Typ) then
353 Rewrite (Arg, Make_Explicit_Dereference (Loc,
354 Prefix => Relocate_Node (Arg)));
355 Analyze_And_Resolve (Arg, Designated_Type (Typ));
356 end if;
357 end Apply_Dereference;
359 ------------------------
360 -- Has_Address_Clause --
361 ------------------------
363 function Has_Address_Clause (Exp : Node_Id) return Boolean is
364 begin
365 return
366 (Is_Entity_Name (Exp) and then
367 Present (Address_Clause (Entity (Exp))))
368 or else
369 (Nkind (Exp) = N_Slice and then Has_Address_Clause (Prefix (Exp)));
370 end Has_Address_Clause;
372 ---------------------
373 -- Is_Formal_Array --
374 ---------------------
376 function Is_Formal_Array (Exp : Node_Id) return Boolean is
377 begin
378 return
379 (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp)))
380 or else
381 (Nkind (Exp) = N_Slice and then Is_Formal_Array (Prefix (Exp)));
382 end Is_Formal_Array;
384 ------------------------
385 -- Is_Non_Local_Array --
386 ------------------------
388 function Is_Non_Local_Array (Exp : Node_Id) return Boolean is
389 begin
390 case Nkind (Exp) is
391 when N_Indexed_Component
392 | N_Selected_Component
393 | N_Slice
395 return Is_Non_Local_Array (Prefix (Exp));
397 when others =>
398 return
399 not (Is_Entity_Name (Exp)
400 and then Scope (Entity (Exp)) = Current_Scope);
401 end case;
402 end Is_Non_Local_Array;
404 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
406 Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs);
407 Rhs_Formal : constant Boolean := Is_Formal_Array (Act_Rhs);
409 Lhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Lhs);
410 Rhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Rhs);
412 -- Start of processing for Expand_Assign_Array
414 begin
415 -- Deal with length check. Note that the length check is done with
416 -- respect to the right-hand side as given, not a possible underlying
417 -- renamed object, since this would generate incorrect extra checks.
419 Apply_Length_Check (Rhs, L_Type);
421 -- We start by assuming that the move can be done in either direction,
422 -- i.e. that the two sides are completely disjoint.
424 Set_Forwards_OK (N, True);
425 Set_Backwards_OK (N, True);
427 -- Normally it is only the slice case that can lead to overlap, and
428 -- explicit checks for slices are made below. But there is one case
429 -- where the slice can be implicit and invisible to us: when we have a
430 -- one dimensional array, and either both operands are parameters, or
431 -- one is a parameter (which can be a slice passed by reference) and the
432 -- other is a non-local variable. In this case the parameter could be a
433 -- slice that overlaps with the other operand.
435 -- However, if the array subtype is a constrained first subtype in the
436 -- parameter case, then we don't have to worry about overlap, since
437 -- slice assignments aren't possible (other than for a slice denoting
438 -- the whole array).
440 -- Note: No overlap is possible if there is a change of representation,
441 -- so we can exclude this case.
443 if Ndim = 1
444 and then not Crep
445 and then
446 ((Lhs_Formal and Rhs_Formal)
447 or else
448 (Lhs_Formal and Rhs_Non_Local_Var)
449 or else
450 (Rhs_Formal and Lhs_Non_Local_Var))
451 and then
452 (not Is_Constrained (Etype (Lhs))
453 or else not Is_First_Subtype (Etype (Lhs)))
454 then
455 Set_Forwards_OK (N, False);
456 Set_Backwards_OK (N, False);
458 -- Note: the bit-packed case is not worrisome here, since if we have
459 -- a slice passed as a parameter, it is always aligned on a byte
460 -- boundary, and if there are no explicit slices, the assignment
461 -- can be performed directly.
462 end if;
464 -- If either operand has an address clause clear Backwards_OK and
465 -- Forwards_OK, since we cannot tell if the operands overlap. We
466 -- exclude this treatment when Rhs is an aggregate, since we know
467 -- that overlap can't occur.
469 if (Has_Address_Clause (Lhs) and then Nkind (Rhs) /= N_Aggregate)
470 or else Has_Address_Clause (Rhs)
471 then
472 Set_Forwards_OK (N, False);
473 Set_Backwards_OK (N, False);
474 end if;
476 -- We certainly must use a loop for change of representation and also
477 -- we use the operand of the conversion on the right-hand side as the
478 -- effective right-hand side (the component types must match in this
479 -- situation).
481 if Crep then
482 Act_Rhs := Get_Referenced_Object (Rhs);
483 R_Type := Get_Actual_Subtype (Act_Rhs);
484 Loop_Required := True;
486 -- We require a loop if the left side is possibly bit unaligned
488 elsif Possible_Bit_Aligned_Component (Lhs)
489 or else
490 Possible_Bit_Aligned_Component (Rhs)
491 then
492 Loop_Required := True;
494 -- Arrays with controlled components are expanded into a loop to force
495 -- calls to Adjust at the component level.
497 elsif Has_Controlled_Component (L_Type) then
498 Loop_Required := True;
500 -- If object is atomic/VFA, we cannot tolerate a loop
502 elsif Is_Atomic_Or_VFA_Object (Act_Lhs)
503 or else
504 Is_Atomic_Or_VFA_Object (Act_Rhs)
505 then
506 return;
508 -- Loop is required if we have atomic components since we have to
509 -- be sure to do any accesses on an element by element basis.
511 elsif Has_Atomic_Components (L_Type)
512 or else Has_Atomic_Components (R_Type)
513 or else Is_Atomic_Or_VFA (Component_Type (L_Type))
514 or else Is_Atomic_Or_VFA (Component_Type (R_Type))
515 then
516 Loop_Required := True;
518 -- Case where no slice is involved
520 elsif not L_Slice and not R_Slice then
522 -- The following code deals with the case of unconstrained bit packed
523 -- arrays. The problem is that the template for such arrays contains
524 -- the bounds of the actual source level array, but the copy of an
525 -- entire array requires the bounds of the underlying array. It would
526 -- be nice if the back end could take care of this, but right now it
527 -- does not know how, so if we have such a type, then we expand out
528 -- into a loop, which is inefficient but works correctly. If we don't
529 -- do this, we get the wrong length computed for the array to be
530 -- moved. The two cases we need to worry about are:
532 -- Explicit dereference of an unconstrained packed array type as in
533 -- the following example:
535 -- procedure C52 is
536 -- type BITS is array(INTEGER range <>) of BOOLEAN;
537 -- pragma PACK(BITS);
538 -- type A is access BITS;
539 -- P1,P2 : A;
540 -- begin
541 -- P1 := new BITS (1 .. 65_535);
542 -- P2 := new BITS (1 .. 65_535);
543 -- P2.ALL := P1.ALL;
544 -- end C52;
546 -- A formal parameter reference with an unconstrained bit array type
547 -- is the other case we need to worry about (here we assume the same
548 -- BITS type declared above):
550 -- procedure Write_All (File : out BITS; Contents : BITS);
551 -- begin
552 -- File.Storage := Contents;
553 -- end Write_All;
555 -- We expand to a loop in either of these two cases
557 -- Question for future thought. Another potentially more efficient
558 -- approach would be to create the actual subtype, and then do an
559 -- unchecked conversion to this actual subtype ???
561 Check_Unconstrained_Bit_Packed_Array : declare
563 function Is_UBPA_Reference (Opnd : Node_Id) return Boolean;
564 -- Function to perform required test for the first case, above
565 -- (dereference of an unconstrained bit packed array).
567 -----------------------
568 -- Is_UBPA_Reference --
569 -----------------------
571 function Is_UBPA_Reference (Opnd : Node_Id) return Boolean is
572 Typ : constant Entity_Id := Underlying_Type (Etype (Opnd));
573 P_Type : Entity_Id;
574 Des_Type : Entity_Id;
576 begin
577 if Present (Packed_Array_Impl_Type (Typ))
578 and then Is_Array_Type (Packed_Array_Impl_Type (Typ))
579 and then not Is_Constrained (Packed_Array_Impl_Type (Typ))
580 then
581 return True;
583 elsif Nkind (Opnd) = N_Explicit_Dereference then
584 P_Type := Underlying_Type (Etype (Prefix (Opnd)));
586 if not Is_Access_Type (P_Type) then
587 return False;
589 else
590 Des_Type := Designated_Type (P_Type);
591 return
592 Is_Bit_Packed_Array (Des_Type)
593 and then not Is_Constrained (Des_Type);
594 end if;
596 else
597 return False;
598 end if;
599 end Is_UBPA_Reference;
601 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
603 begin
604 if Is_UBPA_Reference (Lhs)
605 or else
606 Is_UBPA_Reference (Rhs)
607 then
608 Loop_Required := True;
610 -- Here if we do not have the case of a reference to a bit packed
611 -- unconstrained array case. In this case gigi can most certainly
612 -- handle the assignment if a forwards move is allowed.
614 -- (could it handle the backwards case also???)
616 elsif Forwards_OK (N) then
617 return;
618 end if;
619 end Check_Unconstrained_Bit_Packed_Array;
621 -- The back end can always handle the assignment if the right side is a
622 -- string literal (note that overlap is definitely impossible in this
623 -- case). If the type is packed, a string literal is always converted
624 -- into an aggregate, except in the case of a null slice, for which no
625 -- aggregate can be written. In that case, rewrite the assignment as a
626 -- null statement, a length check has already been emitted to verify
627 -- that the range of the left-hand side is empty.
629 -- Note that this code is not executed if we have an assignment of a
630 -- string literal to a non-bit aligned component of a record, a case
631 -- which cannot be handled by the backend.
633 elsif Nkind (Rhs) = N_String_Literal then
634 if String_Length (Strval (Rhs)) = 0
635 and then Is_Bit_Packed_Array (L_Type)
636 then
637 Rewrite (N, Make_Null_Statement (Loc));
638 Analyze (N);
639 end if;
641 return;
643 -- If either operand is bit packed, then we need a loop, since we can't
644 -- be sure that the slice is byte aligned. Similarly, if either operand
645 -- is a possibly unaligned slice, then we need a loop (since the back
646 -- end cannot handle unaligned slices).
648 elsif Is_Bit_Packed_Array (L_Type)
649 or else Is_Bit_Packed_Array (R_Type)
650 or else Is_Possibly_Unaligned_Slice (Lhs)
651 or else Is_Possibly_Unaligned_Slice (Rhs)
652 then
653 Loop_Required := True;
655 -- If we are not bit-packed, and we have only one slice, then no overlap
656 -- is possible except in the parameter case, so we can let the back end
657 -- handle things.
659 elsif not (L_Slice and R_Slice) then
660 if Forwards_OK (N) then
661 return;
662 end if;
663 end if;
665 -- If the right-hand side is a string literal, introduce a temporary for
666 -- it, for use in the generated loop that will follow.
668 if Nkind (Rhs) = N_String_Literal then
669 declare
670 Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Rhs);
671 Decl : Node_Id;
673 begin
674 Decl :=
675 Make_Object_Declaration (Loc,
676 Defining_Identifier => Temp,
677 Object_Definition => New_Occurrence_Of (L_Type, Loc),
678 Expression => Relocate_Node (Rhs));
680 Insert_Action (N, Decl);
681 Rewrite (Rhs, New_Occurrence_Of (Temp, Loc));
682 R_Type := Etype (Temp);
683 end;
684 end if;
686 -- Come here to complete the analysis
688 -- Loop_Required: Set to True if we know that a loop is required
689 -- regardless of overlap considerations.
691 -- Forwards_OK: Set to False if we already know that a forwards
692 -- move is not safe, else set to True.
694 -- Backwards_OK: Set to False if we already know that a backwards
695 -- move is not safe, else set to True
697 -- Our task at this stage is to complete the overlap analysis, which can
698 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
699 -- then generating the final code, either by deciding that it is OK
700 -- after all to let Gigi handle it, or by generating appropriate code
701 -- in the front end.
703 declare
704 L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type));
705 R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type));
707 Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ);
708 Left_Hi : constant Node_Id := Type_High_Bound (L_Index_Typ);
709 Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ);
710 Right_Hi : constant Node_Id := Type_High_Bound (R_Index_Typ);
712 Act_L_Array : Node_Id;
713 Act_R_Array : Node_Id;
715 Cleft_Lo : Node_Id;
716 Cright_Lo : Node_Id;
717 Condition : Node_Id;
719 Cresult : Compare_Result;
721 begin
722 -- Get the expressions for the arrays. If we are dealing with a
723 -- private type, then convert to the underlying type. We can do
724 -- direct assignments to an array that is a private type, but we
725 -- cannot assign to elements of the array without this extra
726 -- unchecked conversion.
728 -- Note: We propagate Parent to the conversion nodes to generate
729 -- a well-formed subtree.
731 if Nkind (Act_Lhs) = N_Slice then
732 Larray := Prefix (Act_Lhs);
733 else
734 Larray := Act_Lhs;
736 if Is_Private_Type (Etype (Larray)) then
737 declare
738 Par : constant Node_Id := Parent (Larray);
739 begin
740 Larray :=
741 Unchecked_Convert_To
742 (Underlying_Type (Etype (Larray)), Larray);
743 Set_Parent (Larray, Par);
744 end;
745 end if;
746 end if;
748 if Nkind (Act_Rhs) = N_Slice then
749 Rarray := Prefix (Act_Rhs);
750 else
751 Rarray := Act_Rhs;
753 if Is_Private_Type (Etype (Rarray)) then
754 declare
755 Par : constant Node_Id := Parent (Rarray);
756 begin
757 Rarray :=
758 Unchecked_Convert_To
759 (Underlying_Type (Etype (Rarray)), Rarray);
760 Set_Parent (Rarray, Par);
761 end;
762 end if;
763 end if;
765 -- If both sides are slices, we must figure out whether it is safe
766 -- to do the move in one direction or the other. It is always safe
767 -- if there is a change of representation since obviously two arrays
768 -- with different representations cannot possibly overlap.
770 if (not Crep) and L_Slice and R_Slice then
771 Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs));
772 Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs));
774 -- If both left- and right-hand arrays are entity names, and refer
775 -- to different entities, then we know that the move is safe (the
776 -- two storage areas are completely disjoint).
778 if Is_Entity_Name (Act_L_Array)
779 and then Is_Entity_Name (Act_R_Array)
780 and then Entity (Act_L_Array) /= Entity (Act_R_Array)
781 then
782 null;
784 -- Otherwise, we assume the worst, which is that the two arrays
785 -- are the same array. There is no need to check if we know that
786 -- is the case, because if we don't know it, we still have to
787 -- assume it.
789 -- Generally if the same array is involved, then we have an
790 -- overlapping case. We will have to really assume the worst (i.e.
791 -- set neither of the OK flags) unless we can determine the lower
792 -- or upper bounds at compile time and compare them.
794 else
795 Cresult :=
796 Compile_Time_Compare
797 (Left_Lo, Right_Lo, Assume_Valid => True);
799 if Cresult = Unknown then
800 Cresult :=
801 Compile_Time_Compare
802 (Left_Hi, Right_Hi, Assume_Valid => True);
803 end if;
805 case Cresult is
806 when EQ | LE | LT =>
807 Set_Backwards_OK (N, False);
809 when GE | GT =>
810 Set_Forwards_OK (N, False);
812 when NE | Unknown =>
813 Set_Backwards_OK (N, False);
814 Set_Forwards_OK (N, False);
815 end case;
816 end if;
817 end if;
819 -- If after that analysis Loop_Required is False, meaning that we
820 -- have not discovered some non-overlap reason for requiring a loop,
821 -- then the outcome depends on the capabilities of the back end.
823 if not Loop_Required then
824 -- Assume the back end can deal with all cases of overlap by
825 -- falling back to memmove if it cannot use a more efficient
826 -- approach.
828 return;
829 end if;
831 -- At this stage we have to generate an explicit loop, and we have
832 -- the following cases:
834 -- Forwards_OK = True
836 -- Rnn : right_index := right_index'First;
837 -- for Lnn in left-index loop
838 -- left (Lnn) := right (Rnn);
839 -- Rnn := right_index'Succ (Rnn);
840 -- end loop;
842 -- Note: the above code MUST be analyzed with checks off, because
843 -- otherwise the Succ could overflow. But in any case this is more
844 -- efficient.
846 -- Forwards_OK = False, Backwards_OK = True
848 -- Rnn : right_index := right_index'Last;
849 -- for Lnn in reverse left-index loop
850 -- left (Lnn) := right (Rnn);
851 -- Rnn := right_index'Pred (Rnn);
852 -- end loop;
854 -- Note: the above code MUST be analyzed with checks off, because
855 -- otherwise the Pred could overflow. But in any case this is more
856 -- efficient.
858 -- Forwards_OK = Backwards_OK = False
860 -- This only happens if we have the same array on each side. It is
861 -- possible to create situations using overlays that violate this,
862 -- but we simply do not promise to get this "right" in this case.
864 -- There are two possible subcases. If the No_Implicit_Conditionals
865 -- restriction is set, then we generate the following code:
867 -- declare
868 -- T : constant <operand-type> := rhs;
869 -- begin
870 -- lhs := T;
871 -- end;
873 -- If implicit conditionals are permitted, then we generate:
875 -- if Left_Lo <= Right_Lo then
876 -- <code for Forwards_OK = True above>
877 -- else
878 -- <code for Backwards_OK = True above>
879 -- end if;
881 -- In order to detect possible aliasing, we examine the renamed
882 -- expression when the source or target is a renaming. However,
883 -- the renaming may be intended to capture an address that may be
884 -- affected by subsequent code, and therefore we must recover
885 -- the actual entity for the expansion that follows, not the
886 -- object it renames. In particular, if source or target designate
887 -- a portion of a dynamically allocated object, the pointer to it
888 -- may be reassigned but the renaming preserves the proper location.
890 if Is_Entity_Name (Rhs)
891 and then
892 Nkind (Parent (Entity (Rhs))) = N_Object_Renaming_Declaration
893 and then Nkind (Act_Rhs) = N_Slice
894 then
895 Rarray := Rhs;
896 end if;
898 if Is_Entity_Name (Lhs)
899 and then
900 Nkind (Parent (Entity (Lhs))) = N_Object_Renaming_Declaration
901 and then Nkind (Act_Lhs) = N_Slice
902 then
903 Larray := Lhs;
904 end if;
906 -- Cases where either Forwards_OK or Backwards_OK is true
908 if Forwards_OK (N) or else Backwards_OK (N) then
909 if Needs_Finalization (Component_Type (L_Type))
910 and then Base_Type (L_Type) = Base_Type (R_Type)
911 and then Ndim = 1
912 and then not No_Ctrl_Actions (N)
913 then
914 declare
915 Proc : constant Entity_Id :=
916 TSS (Base_Type (L_Type), TSS_Slice_Assign);
917 Actuals : List_Id;
919 begin
920 Apply_Dereference (Larray);
921 Apply_Dereference (Rarray);
922 Actuals := New_List (
923 Duplicate_Subexpr (Larray, Name_Req => True),
924 Duplicate_Subexpr (Rarray, Name_Req => True),
925 Duplicate_Subexpr (Left_Lo, Name_Req => True),
926 Duplicate_Subexpr (Left_Hi, Name_Req => True),
927 Duplicate_Subexpr (Right_Lo, Name_Req => True),
928 Duplicate_Subexpr (Right_Hi, Name_Req => True));
930 Append_To (Actuals,
931 New_Occurrence_Of (
932 Boolean_Literals (not Forwards_OK (N)), Loc));
934 Rewrite (N,
935 Make_Procedure_Call_Statement (Loc,
936 Name => New_Occurrence_Of (Proc, Loc),
937 Parameter_Associations => Actuals));
938 end;
940 else
941 Rewrite (N,
942 Expand_Assign_Array_Loop
943 (N, Larray, Rarray, L_Type, R_Type, Ndim,
944 Rev => not Forwards_OK (N)));
945 end if;
947 -- Case of both are false with No_Implicit_Conditionals
949 elsif Restriction_Active (No_Implicit_Conditionals) then
950 declare
951 T : constant Entity_Id :=
952 Make_Defining_Identifier (Loc, Chars => Name_T);
954 begin
955 Rewrite (N,
956 Make_Block_Statement (Loc,
957 Declarations => New_List (
958 Make_Object_Declaration (Loc,
959 Defining_Identifier => T,
960 Constant_Present => True,
961 Object_Definition =>
962 New_Occurrence_Of (Etype (Rhs), Loc),
963 Expression => Relocate_Node (Rhs))),
965 Handled_Statement_Sequence =>
966 Make_Handled_Sequence_Of_Statements (Loc,
967 Statements => New_List (
968 Make_Assignment_Statement (Loc,
969 Name => Relocate_Node (Lhs),
970 Expression => New_Occurrence_Of (T, Loc))))));
971 end;
973 -- Case of both are false with implicit conditionals allowed
975 else
976 -- Before we generate this code, we must ensure that the left and
977 -- right side array types are defined. They may be itypes, and we
978 -- cannot let them be defined inside the if, since the first use
979 -- in the then may not be executed.
981 Ensure_Defined (L_Type, N);
982 Ensure_Defined (R_Type, N);
984 -- We normally compare addresses to find out which way round to
985 -- do the loop, since this is reliable, and handles the cases of
986 -- parameters, conversions etc. But we can't do that in the bit
987 -- packed case, because addresses don't work there.
989 if not Is_Bit_Packed_Array (L_Type) then
990 Condition :=
991 Make_Op_Le (Loc,
992 Left_Opnd =>
993 Unchecked_Convert_To (RTE (RE_Integer_Address),
994 Make_Attribute_Reference (Loc,
995 Prefix =>
996 Make_Indexed_Component (Loc,
997 Prefix =>
998 Duplicate_Subexpr_Move_Checks (Larray, True),
999 Expressions => New_List (
1000 Make_Attribute_Reference (Loc,
1001 Prefix =>
1002 New_Occurrence_Of
1003 (L_Index_Typ, Loc),
1004 Attribute_Name => Name_First))),
1005 Attribute_Name => Name_Address)),
1007 Right_Opnd =>
1008 Unchecked_Convert_To (RTE (RE_Integer_Address),
1009 Make_Attribute_Reference (Loc,
1010 Prefix =>
1011 Make_Indexed_Component (Loc,
1012 Prefix =>
1013 Duplicate_Subexpr_Move_Checks (Rarray, True),
1014 Expressions => New_List (
1015 Make_Attribute_Reference (Loc,
1016 Prefix =>
1017 New_Occurrence_Of
1018 (R_Index_Typ, Loc),
1019 Attribute_Name => Name_First))),
1020 Attribute_Name => Name_Address)));
1022 -- For the bit packed and VM cases we use the bounds. That's OK,
1023 -- because we don't have to worry about parameters, since they
1024 -- cannot cause overlap. Perhaps we should worry about weird slice
1025 -- conversions ???
1027 else
1028 -- Copy the bounds
1030 Cleft_Lo := New_Copy_Tree (Left_Lo);
1031 Cright_Lo := New_Copy_Tree (Right_Lo);
1033 -- If the types do not match we add an implicit conversion
1034 -- here to ensure proper match
1036 if Etype (Left_Lo) /= Etype (Right_Lo) then
1037 Cright_Lo :=
1038 Unchecked_Convert_To (Etype (Left_Lo), Cright_Lo);
1039 end if;
1041 -- Reset the Analyzed flag, because the bounds of the index
1042 -- type itself may be universal, and must must be reanalyzed
1043 -- to acquire the proper type for the back end.
1045 Set_Analyzed (Cleft_Lo, False);
1046 Set_Analyzed (Cright_Lo, False);
1048 Condition :=
1049 Make_Op_Le (Loc,
1050 Left_Opnd => Cleft_Lo,
1051 Right_Opnd => Cright_Lo);
1052 end if;
1054 if Needs_Finalization (Component_Type (L_Type))
1055 and then Base_Type (L_Type) = Base_Type (R_Type)
1056 and then Ndim = 1
1057 and then not No_Ctrl_Actions (N)
1058 then
1060 -- Call TSS procedure for array assignment, passing the
1061 -- explicit bounds of right- and left-hand sides.
1063 declare
1064 Proc : constant Entity_Id :=
1065 TSS (Base_Type (L_Type), TSS_Slice_Assign);
1066 Actuals : List_Id;
1068 begin
1069 Apply_Dereference (Larray);
1070 Apply_Dereference (Rarray);
1071 Actuals := New_List (
1072 Duplicate_Subexpr (Larray, Name_Req => True),
1073 Duplicate_Subexpr (Rarray, Name_Req => True),
1074 Duplicate_Subexpr (Left_Lo, Name_Req => True),
1075 Duplicate_Subexpr (Left_Hi, Name_Req => True),
1076 Duplicate_Subexpr (Right_Lo, Name_Req => True),
1077 Duplicate_Subexpr (Right_Hi, Name_Req => True));
1079 Append_To (Actuals,
1080 Make_Op_Not (Loc,
1081 Right_Opnd => Condition));
1083 Rewrite (N,
1084 Make_Procedure_Call_Statement (Loc,
1085 Name => New_Occurrence_Of (Proc, Loc),
1086 Parameter_Associations => Actuals));
1087 end;
1089 else
1090 Rewrite (N,
1091 Make_Implicit_If_Statement (N,
1092 Condition => Condition,
1094 Then_Statements => New_List (
1095 Expand_Assign_Array_Loop
1096 (N, Larray, Rarray, L_Type, R_Type, Ndim,
1097 Rev => False)),
1099 Else_Statements => New_List (
1100 Expand_Assign_Array_Loop
1101 (N, Larray, Rarray, L_Type, R_Type, Ndim,
1102 Rev => True))));
1103 end if;
1104 end if;
1106 Analyze (N, Suppress => All_Checks);
1107 end;
1109 exception
1110 when RE_Not_Available =>
1111 return;
1112 end Expand_Assign_Array;
1114 ------------------------------
1115 -- Expand_Assign_Array_Loop --
1116 ------------------------------
1118 -- The following is an example of the loop generated for the case of a
1119 -- two-dimensional array:
1121 -- declare
1122 -- R2b : Tm1X1 := 1;
1123 -- begin
1124 -- for L1b in 1 .. 100 loop
1125 -- declare
1126 -- R4b : Tm1X2 := 1;
1127 -- begin
1128 -- for L3b in 1 .. 100 loop
1129 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
1130 -- R4b := Tm1X2'succ(R4b);
1131 -- end loop;
1132 -- end;
1133 -- R2b := Tm1X1'succ(R2b);
1134 -- end loop;
1135 -- end;
1137 -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand
1138 -- side. The declarations of R2b and R4b are inserted before the original
1139 -- assignment statement.
1141 function Expand_Assign_Array_Loop
1142 (N : Node_Id;
1143 Larray : Entity_Id;
1144 Rarray : Entity_Id;
1145 L_Type : Entity_Id;
1146 R_Type : Entity_Id;
1147 Ndim : Pos;
1148 Rev : Boolean) return Node_Id
1150 Loc : constant Source_Ptr := Sloc (N);
1152 Lnn : array (1 .. Ndim) of Entity_Id;
1153 Rnn : array (1 .. Ndim) of Entity_Id;
1154 -- Entities used as subscripts on left and right sides
1156 L_Index_Type : array (1 .. Ndim) of Entity_Id;
1157 R_Index_Type : array (1 .. Ndim) of Entity_Id;
1158 -- Left and right index types
1160 Assign : Node_Id;
1162 F_Or_L : Name_Id;
1163 S_Or_P : Name_Id;
1165 function Build_Step (J : Nat) return Node_Id;
1166 -- The increment step for the index of the right-hand side is written
1167 -- as an attribute reference (Succ or Pred). This function returns
1168 -- the corresponding node, which is placed at the end of the loop body.
1170 ----------------
1171 -- Build_Step --
1172 ----------------
1174 function Build_Step (J : Nat) return Node_Id is
1175 Step : Node_Id;
1176 Lim : Name_Id;
1178 begin
1179 if Rev then
1180 Lim := Name_First;
1181 else
1182 Lim := Name_Last;
1183 end if;
1185 Step :=
1186 Make_Assignment_Statement (Loc,
1187 Name => New_Occurrence_Of (Rnn (J), Loc),
1188 Expression =>
1189 Make_Attribute_Reference (Loc,
1190 Prefix =>
1191 New_Occurrence_Of (R_Index_Type (J), Loc),
1192 Attribute_Name => S_Or_P,
1193 Expressions => New_List (
1194 New_Occurrence_Of (Rnn (J), Loc))));
1196 -- Note that on the last iteration of the loop, the index is increased
1197 -- (or decreased) past the corresponding bound. This is consistent with
1198 -- the C semantics of the back-end, where such an off-by-one value on a
1199 -- dead index variable is OK. However, in CodePeer mode this leads to
1200 -- spurious warnings, and thus we place a guard around the attribute
1201 -- reference. For obvious reasons we only do this for CodePeer.
1203 if CodePeer_Mode then
1204 Step :=
1205 Make_If_Statement (Loc,
1206 Condition =>
1207 Make_Op_Ne (Loc,
1208 Left_Opnd => New_Occurrence_Of (Lnn (J), Loc),
1209 Right_Opnd =>
1210 Make_Attribute_Reference (Loc,
1211 Prefix => New_Occurrence_Of (L_Index_Type (J), Loc),
1212 Attribute_Name => Lim)),
1213 Then_Statements => New_List (Step));
1214 end if;
1216 return Step;
1217 end Build_Step;
1219 -- Start of processing for Expand_Assign_Array_Loop
1221 begin
1222 if Rev then
1223 F_Or_L := Name_Last;
1224 S_Or_P := Name_Pred;
1225 else
1226 F_Or_L := Name_First;
1227 S_Or_P := Name_Succ;
1228 end if;
1230 -- Setup index types and subscript entities
1232 declare
1233 L_Index : Node_Id;
1234 R_Index : Node_Id;
1236 begin
1237 L_Index := First_Index (L_Type);
1238 R_Index := First_Index (R_Type);
1240 for J in 1 .. Ndim loop
1241 Lnn (J) := Make_Temporary (Loc, 'L');
1242 Rnn (J) := Make_Temporary (Loc, 'R');
1244 L_Index_Type (J) := Etype (L_Index);
1245 R_Index_Type (J) := Etype (R_Index);
1247 Next_Index (L_Index);
1248 Next_Index (R_Index);
1249 end loop;
1250 end;
1252 -- Now construct the assignment statement
1254 declare
1255 ExprL : constant List_Id := New_List;
1256 ExprR : constant List_Id := New_List;
1258 begin
1259 for J in 1 .. Ndim loop
1260 Append_To (ExprL, New_Occurrence_Of (Lnn (J), Loc));
1261 Append_To (ExprR, New_Occurrence_Of (Rnn (J), Loc));
1262 end loop;
1264 Assign :=
1265 Make_Assignment_Statement (Loc,
1266 Name =>
1267 Make_Indexed_Component (Loc,
1268 Prefix => Duplicate_Subexpr (Larray, Name_Req => True),
1269 Expressions => ExprL),
1270 Expression =>
1271 Make_Indexed_Component (Loc,
1272 Prefix => Duplicate_Subexpr (Rarray, Name_Req => True),
1273 Expressions => ExprR));
1275 -- We set assignment OK, since there are some cases, e.g. in object
1276 -- declarations, where we are actually assigning into a constant.
1277 -- If there really is an illegality, it was caught long before now,
1278 -- and was flagged when the original assignment was analyzed.
1280 Set_Assignment_OK (Name (Assign));
1282 -- Propagate the No_Ctrl_Actions flag to individual assignments
1284 Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N));
1285 end;
1287 -- Now construct the loop from the inside out, with the last subscript
1288 -- varying most rapidly. Note that Assign is first the raw assignment
1289 -- statement, and then subsequently the loop that wraps it up.
1291 for J in reverse 1 .. Ndim loop
1292 Assign :=
1293 Make_Block_Statement (Loc,
1294 Declarations => New_List (
1295 Make_Object_Declaration (Loc,
1296 Defining_Identifier => Rnn (J),
1297 Object_Definition =>
1298 New_Occurrence_Of (R_Index_Type (J), Loc),
1299 Expression =>
1300 Make_Attribute_Reference (Loc,
1301 Prefix => New_Occurrence_Of (R_Index_Type (J), Loc),
1302 Attribute_Name => F_Or_L))),
1304 Handled_Statement_Sequence =>
1305 Make_Handled_Sequence_Of_Statements (Loc,
1306 Statements => New_List (
1307 Make_Implicit_Loop_Statement (N,
1308 Iteration_Scheme =>
1309 Make_Iteration_Scheme (Loc,
1310 Loop_Parameter_Specification =>
1311 Make_Loop_Parameter_Specification (Loc,
1312 Defining_Identifier => Lnn (J),
1313 Reverse_Present => Rev,
1314 Discrete_Subtype_Definition =>
1315 New_Occurrence_Of (L_Index_Type (J), Loc))),
1317 Statements => New_List (Assign, Build_Step (J))))));
1318 end loop;
1320 return Assign;
1321 end Expand_Assign_Array_Loop;
1323 --------------------------
1324 -- Expand_Assign_Record --
1325 --------------------------
1327 procedure Expand_Assign_Record (N : Node_Id) is
1328 Lhs : constant Node_Id := Name (N);
1329 Rhs : Node_Id := Expression (N);
1330 L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
1332 begin
1333 -- If change of representation, then extract the real right-hand side
1334 -- from the type conversion, and proceed with component-wise assignment,
1335 -- since the two types are not the same as far as the back end is
1336 -- concerned.
1338 if Change_Of_Representation (N) then
1339 Rhs := Expression (Rhs);
1341 -- If this may be a case of a large bit aligned component, then proceed
1342 -- with component-wise assignment, to avoid possible clobbering of other
1343 -- components sharing bits in the first or last byte of the component to
1344 -- be assigned.
1346 elsif Possible_Bit_Aligned_Component (Lhs)
1348 Possible_Bit_Aligned_Component (Rhs)
1349 then
1350 null;
1352 -- If we have a tagged type that has a complete record representation
1353 -- clause, we must do we must do component-wise assignments, since child
1354 -- types may have used gaps for their components, and we might be
1355 -- dealing with a view conversion.
1357 elsif Is_Fully_Repped_Tagged_Type (L_Typ) then
1358 null;
1360 -- If neither condition met, then nothing special to do, the back end
1361 -- can handle assignment of the entire component as a single entity.
1363 else
1364 return;
1365 end if;
1367 -- At this stage we know that we must do a component wise assignment
1369 declare
1370 Loc : constant Source_Ptr := Sloc (N);
1371 R_Typ : constant Entity_Id := Base_Type (Etype (Rhs));
1372 Decl : constant Node_Id := Declaration_Node (R_Typ);
1373 RDef : Node_Id;
1374 F : Entity_Id;
1376 function Find_Component
1377 (Typ : Entity_Id;
1378 Comp : Entity_Id) return Entity_Id;
1379 -- Find the component with the given name in the underlying record
1380 -- declaration for Typ. We need to use the actual entity because the
1381 -- type may be private and resolution by identifier alone would fail.
1383 function Make_Component_List_Assign
1384 (CL : Node_Id;
1385 U_U : Boolean := False) return List_Id;
1386 -- Returns a sequence of statements to assign the components that
1387 -- are referenced in the given component list. The flag U_U is
1388 -- used to force the usage of the inferred value of the variant
1389 -- part expression as the switch for the generated case statement.
1391 function Make_Field_Assign
1392 (C : Entity_Id;
1393 U_U : Boolean := False) return Node_Id;
1394 -- Given C, the entity for a discriminant or component, build an
1395 -- assignment for the corresponding field values. The flag U_U
1396 -- signals the presence of an Unchecked_Union and forces the usage
1397 -- of the inferred discriminant value of C as the right-hand side
1398 -- of the assignment.
1400 function Make_Field_Assigns (CI : List_Id) return List_Id;
1401 -- Given CI, a component items list, construct series of statements
1402 -- for fieldwise assignment of the corresponding components.
1404 --------------------
1405 -- Find_Component --
1406 --------------------
1408 function Find_Component
1409 (Typ : Entity_Id;
1410 Comp : Entity_Id) return Entity_Id
1412 Utyp : constant Entity_Id := Underlying_Type (Typ);
1413 C : Entity_Id;
1415 begin
1416 C := First_Entity (Utyp);
1417 while Present (C) loop
1418 if Chars (C) = Chars (Comp) then
1419 return C;
1420 end if;
1422 Next_Entity (C);
1423 end loop;
1425 raise Program_Error;
1426 end Find_Component;
1428 --------------------------------
1429 -- Make_Component_List_Assign --
1430 --------------------------------
1432 function Make_Component_List_Assign
1433 (CL : Node_Id;
1434 U_U : Boolean := False) return List_Id
1436 CI : constant List_Id := Component_Items (CL);
1437 VP : constant Node_Id := Variant_Part (CL);
1439 Alts : List_Id;
1440 DC : Node_Id;
1441 DCH : List_Id;
1442 Expr : Node_Id;
1443 Result : List_Id;
1444 V : Node_Id;
1446 begin
1447 Result := Make_Field_Assigns (CI);
1449 if Present (VP) then
1450 V := First_Non_Pragma (Variants (VP));
1451 Alts := New_List;
1452 while Present (V) loop
1453 DCH := New_List;
1454 DC := First (Discrete_Choices (V));
1455 while Present (DC) loop
1456 Append_To (DCH, New_Copy_Tree (DC));
1457 Next (DC);
1458 end loop;
1460 Append_To (Alts,
1461 Make_Case_Statement_Alternative (Loc,
1462 Discrete_Choices => DCH,
1463 Statements =>
1464 Make_Component_List_Assign (Component_List (V))));
1465 Next_Non_Pragma (V);
1466 end loop;
1468 -- If we have an Unchecked_Union, use the value of the inferred
1469 -- discriminant of the variant part expression as the switch
1470 -- for the case statement. The case statement may later be
1471 -- folded.
1473 if U_U then
1474 Expr :=
1475 New_Copy (Get_Discriminant_Value (
1476 Entity (Name (VP)),
1477 Etype (Rhs),
1478 Discriminant_Constraint (Etype (Rhs))));
1479 else
1480 Expr :=
1481 Make_Selected_Component (Loc,
1482 Prefix => Duplicate_Subexpr (Rhs),
1483 Selector_Name =>
1484 Make_Identifier (Loc, Chars (Name (VP))));
1485 end if;
1487 Append_To (Result,
1488 Make_Case_Statement (Loc,
1489 Expression => Expr,
1490 Alternatives => Alts));
1491 end if;
1493 return Result;
1494 end Make_Component_List_Assign;
1496 -----------------------
1497 -- Make_Field_Assign --
1498 -----------------------
1500 function Make_Field_Assign
1501 (C : Entity_Id;
1502 U_U : Boolean := False) return Node_Id
1504 A : Node_Id;
1505 Disc : Entity_Id;
1506 Expr : Node_Id;
1508 begin
1509 -- The discriminant entity to be used in the retrieval below must
1510 -- be one in the corresponding type, given that the assignment may
1511 -- be between derived and parent types.
1513 if Is_Derived_Type (Etype (Rhs)) then
1514 Disc := Find_Component (R_Typ, C);
1515 else
1516 Disc := C;
1517 end if;
1519 -- In the case of an Unchecked_Union, use the discriminant
1520 -- constraint value as on the right-hand side of the assignment.
1522 if U_U then
1523 Expr :=
1524 New_Copy (Get_Discriminant_Value (C,
1525 Etype (Rhs),
1526 Discriminant_Constraint (Etype (Rhs))));
1527 else
1528 Expr :=
1529 Make_Selected_Component (Loc,
1530 Prefix => Duplicate_Subexpr (Rhs),
1531 Selector_Name => New_Occurrence_Of (Disc, Loc));
1532 end if;
1534 -- Generate the assignment statement. When the left-hand side
1535 -- is an object with an address clause present, force generated
1536 -- temporaries to be renamings so as to correctly assign to any
1537 -- overlaid objects.
1539 A :=
1540 Make_Assignment_Statement (Loc,
1541 Name =>
1542 Make_Selected_Component (Loc,
1543 Prefix =>
1544 Duplicate_Subexpr
1545 (Exp => Lhs,
1546 Name_Req => False,
1547 Renaming_Req =>
1548 Is_Entity_Name (Lhs)
1549 and then Present (Address_Clause (Entity (Lhs)))),
1550 Selector_Name =>
1551 New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
1552 Expression => Expr);
1554 -- Set Assignment_OK, so discriminants can be assigned
1556 Set_Assignment_OK (Name (A), True);
1558 if Componentwise_Assignment (N)
1559 and then Nkind (Name (A)) = N_Selected_Component
1560 and then Chars (Selector_Name (Name (A))) = Name_uParent
1561 then
1562 Set_Componentwise_Assignment (A);
1563 end if;
1565 return A;
1566 end Make_Field_Assign;
1568 ------------------------
1569 -- Make_Field_Assigns --
1570 ------------------------
1572 function Make_Field_Assigns (CI : List_Id) return List_Id is
1573 Item : Node_Id;
1574 Result : List_Id;
1576 begin
1577 Item := First (CI);
1578 Result := New_List;
1580 while Present (Item) loop
1582 -- Look for components, but exclude _tag field assignment if
1583 -- the special Componentwise_Assignment flag is set.
1585 if Nkind (Item) = N_Component_Declaration
1586 and then not (Is_Tag (Defining_Identifier (Item))
1587 and then Componentwise_Assignment (N))
1588 then
1589 Append_To
1590 (Result, Make_Field_Assign (Defining_Identifier (Item)));
1591 end if;
1593 Next (Item);
1594 end loop;
1596 return Result;
1597 end Make_Field_Assigns;
1599 -- Start of processing for Expand_Assign_Record
1601 begin
1602 -- Note that we use the base types for this processing. This results
1603 -- in some extra work in the constrained case, but the change of
1604 -- representation case is so unusual that it is not worth the effort.
1606 -- First copy the discriminants. This is done unconditionally. It
1607 -- is required in the unconstrained left side case, and also in the
1608 -- case where this assignment was constructed during the expansion
1609 -- of a type conversion (since initialization of discriminants is
1610 -- suppressed in this case). It is unnecessary but harmless in
1611 -- other cases.
1613 -- Special case: no copy if the target has no discriminants
1615 if Has_Discriminants (L_Typ)
1616 and then Is_Unchecked_Union (Base_Type (L_Typ))
1617 then
1618 null;
1620 elsif Has_Discriminants (L_Typ) then
1621 F := First_Discriminant (R_Typ);
1622 while Present (F) loop
1624 -- If we are expanding the initialization of a derived record
1625 -- that constrains or renames discriminants of the parent, we
1626 -- must use the corresponding discriminant in the parent.
1628 declare
1629 CF : Entity_Id;
1631 begin
1632 if Inside_Init_Proc
1633 and then Present (Corresponding_Discriminant (F))
1634 then
1635 CF := Corresponding_Discriminant (F);
1636 else
1637 CF := F;
1638 end if;
1640 if Is_Unchecked_Union (Base_Type (R_Typ)) then
1642 -- Within an initialization procedure this is the
1643 -- assignment to an unchecked union component, in which
1644 -- case there is no discriminant to initialize.
1646 if Inside_Init_Proc then
1647 null;
1649 else
1650 -- The assignment is part of a conversion from a
1651 -- derived unchecked union type with an inferable
1652 -- discriminant, to a parent type.
1654 Insert_Action (N, Make_Field_Assign (CF, True));
1655 end if;
1657 else
1658 Insert_Action (N, Make_Field_Assign (CF));
1659 end if;
1661 Next_Discriminant (F);
1662 end;
1663 end loop;
1665 -- If the derived type has a stored constraint, assign the value
1666 -- of the corresponding discriminants explicitly, skipping those
1667 -- that are renamed discriminants. We cannot just retrieve them
1668 -- from the Rhs by selected component because they are invisible
1669 -- in the type of the right-hand side.
1671 if Stored_Constraint (R_Typ) /= No_Elist then
1672 declare
1673 Assign : Node_Id;
1674 Discr_Val : Elmt_Id;
1676 begin
1677 Discr_Val := First_Elmt (Stored_Constraint (R_Typ));
1678 F := First_Entity (R_Typ);
1679 while Present (F) loop
1680 if Ekind (F) = E_Discriminant
1681 and then Is_Completely_Hidden (F)
1682 and then Present (Corresponding_Record_Component (F))
1683 and then
1684 (not Is_Entity_Name (Node (Discr_Val))
1685 or else Ekind (Entity (Node (Discr_Val))) /=
1686 E_Discriminant)
1687 then
1688 Assign :=
1689 Make_Assignment_Statement (Loc,
1690 Name =>
1691 Make_Selected_Component (Loc,
1692 Prefix => Duplicate_Subexpr (Lhs),
1693 Selector_Name =>
1694 New_Occurrence_Of
1695 (Corresponding_Record_Component (F), Loc)),
1696 Expression => New_Copy (Node (Discr_Val)));
1698 Set_Assignment_OK (Name (Assign));
1699 Insert_Action (N, Assign);
1700 Next_Elmt (Discr_Val);
1701 end if;
1703 Next_Entity (F);
1704 end loop;
1705 end;
1706 end if;
1707 end if;
1709 -- We know the underlying type is a record, but its current view
1710 -- may be private. We must retrieve the usable record declaration.
1712 if Nkind_In (Decl, N_Private_Type_Declaration,
1713 N_Private_Extension_Declaration)
1714 and then Present (Full_View (R_Typ))
1715 then
1716 RDef := Type_Definition (Declaration_Node (Full_View (R_Typ)));
1717 else
1718 RDef := Type_Definition (Decl);
1719 end if;
1721 if Nkind (RDef) = N_Derived_Type_Definition then
1722 RDef := Record_Extension_Part (RDef);
1723 end if;
1725 if Nkind (RDef) = N_Record_Definition
1726 and then Present (Component_List (RDef))
1727 then
1728 if Is_Unchecked_Union (R_Typ) then
1729 Insert_Actions (N,
1730 Make_Component_List_Assign (Component_List (RDef), True));
1731 else
1732 Insert_Actions
1733 (N, Make_Component_List_Assign (Component_List (RDef)));
1734 end if;
1736 Rewrite (N, Make_Null_Statement (Loc));
1737 end if;
1738 end;
1739 end Expand_Assign_Record;
1741 -------------------------------------
1742 -- Expand_Assign_With_Target_Names --
1743 -------------------------------------
1745 procedure Expand_Assign_With_Target_Names (N : Node_Id) is
1746 LHS : constant Node_Id := Name (N);
1747 LHS_Typ : constant Entity_Id := Etype (LHS);
1748 Loc : constant Source_Ptr := Sloc (N);
1749 RHS : constant Node_Id := Expression (N);
1751 Ent : Entity_Id;
1752 -- The entity of the left-hand side
1754 function Replace_Target (N : Node_Id) return Traverse_Result;
1755 -- Replace occurrences of the target name by the proper entity: either
1756 -- the entity of the LHS in simple cases, or the formal of the
1757 -- constructed procedure otherwise.
1759 --------------------
1760 -- Replace_Target --
1761 --------------------
1763 function Replace_Target (N : Node_Id) return Traverse_Result is
1764 begin
1765 if Nkind (N) = N_Target_Name then
1766 Rewrite (N, New_Occurrence_Of (Ent, Sloc (N)));
1768 -- The expression will be reanalyzed when the enclosing assignment
1769 -- is reanalyzed, so reset the entity, which may be a temporary
1770 -- created during analysis, e.g. a loop variable for an iterated
1771 -- component association. However, if entity is callable then
1772 -- resolution has established its proper identity (including in
1773 -- rewritten prefixed calls) so we must preserve it.
1775 elsif Is_Entity_Name (N) then
1776 if Present (Entity (N))
1777 and then not Is_Overloadable (Entity (N))
1778 then
1779 Set_Entity (N, Empty);
1780 end if;
1781 end if;
1783 Set_Analyzed (N, False);
1784 return OK;
1785 end Replace_Target;
1787 procedure Replace_Target_Name is new Traverse_Proc (Replace_Target);
1789 -- Local variables
1791 New_RHS : Node_Id;
1792 Proc_Id : Entity_Id;
1794 -- Start of processing for Expand_Assign_With_Target_Names
1796 begin
1797 New_RHS := New_Copy_Tree (RHS);
1799 -- The left-hand side is a direct name
1801 if Is_Entity_Name (LHS)
1802 and then not Is_Renaming_Of_Object (Entity (LHS))
1803 then
1804 Ent := Entity (LHS);
1805 Replace_Target_Name (New_RHS);
1807 -- Generate:
1808 -- LHS := ... LHS ...;
1810 Rewrite (N,
1811 Make_Assignment_Statement (Loc,
1812 Name => Relocate_Node (LHS),
1813 Expression => New_RHS));
1815 -- The left-hand side is not a direct name, but is side-effect free.
1816 -- Capture its value in a temporary to avoid multiple evaluations.
1818 elsif Side_Effect_Free (LHS) then
1819 Ent := Make_Temporary (Loc, 'T');
1820 Replace_Target_Name (New_RHS);
1822 -- Generate:
1823 -- T : LHS_Typ := LHS;
1825 Insert_Before_And_Analyze (N,
1826 Make_Object_Declaration (Loc,
1827 Defining_Identifier => Ent,
1828 Object_Definition => New_Occurrence_Of (LHS_Typ, Loc),
1829 Expression => New_Copy_Tree (LHS)));
1831 -- Generate:
1832 -- LHS := ... T ...;
1834 Rewrite (N,
1835 Make_Assignment_Statement (Loc,
1836 Name => Relocate_Node (LHS),
1837 Expression => New_RHS));
1839 -- Otherwise wrap the whole assignment statement in a procedure with an
1840 -- IN OUT parameter. The original assignment then becomes a call to the
1841 -- procedure with the left-hand side as an actual.
1843 else
1844 Ent := Make_Temporary (Loc, 'T');
1845 Replace_Target_Name (New_RHS);
1847 -- Generate:
1848 -- procedure P (T : in out LHS_Typ) is
1849 -- begin
1850 -- T := ... T ...;
1851 -- end P;
1853 Proc_Id := Make_Temporary (Loc, 'P');
1855 Insert_Before_And_Analyze (N,
1856 Make_Subprogram_Body (Loc,
1857 Specification =>
1858 Make_Procedure_Specification (Loc,
1859 Defining_Unit_Name => Proc_Id,
1860 Parameter_Specifications => New_List (
1861 Make_Parameter_Specification (Loc,
1862 Defining_Identifier => Ent,
1863 In_Present => True,
1864 Out_Present => True,
1865 Parameter_Type =>
1866 New_Occurrence_Of (LHS_Typ, Loc)))),
1868 Declarations => Empty_List,
1870 Handled_Statement_Sequence =>
1871 Make_Handled_Sequence_Of_Statements (Loc,
1872 Statements => New_List (
1873 Make_Assignment_Statement (Loc,
1874 Name => New_Occurrence_Of (Ent, Loc),
1875 Expression => New_RHS)))));
1877 -- Generate:
1878 -- P (LHS);
1880 Rewrite (N,
1881 Make_Procedure_Call_Statement (Loc,
1882 Name => New_Occurrence_Of (Proc_Id, Loc),
1883 Parameter_Associations => New_List (Relocate_Node (LHS))));
1884 end if;
1886 -- Analyze rewritten node, either as assignment or procedure call
1888 Analyze (N);
1889 end Expand_Assign_With_Target_Names;
1891 -----------------------------------
1892 -- Expand_N_Assignment_Statement --
1893 -----------------------------------
1895 -- This procedure implements various cases where an assignment statement
1896 -- cannot just be passed on to the back end in untransformed state.
1898 procedure Expand_N_Assignment_Statement (N : Node_Id) is
1899 Crep : constant Boolean := Change_Of_Representation (N);
1900 Lhs : constant Node_Id := Name (N);
1901 Loc : constant Source_Ptr := Sloc (N);
1902 Rhs : constant Node_Id := Expression (N);
1903 Typ : constant Entity_Id := Underlying_Type (Etype (Lhs));
1904 Exp : Node_Id;
1906 begin
1907 -- Special case to check right away, if the Componentwise_Assignment
1908 -- flag is set, this is a reanalysis from the expansion of the primitive
1909 -- assignment procedure for a tagged type, and all we need to do is to
1910 -- expand to assignment of components, because otherwise, we would get
1911 -- infinite recursion (since this looks like a tagged assignment which
1912 -- would normally try to *call* the primitive assignment procedure).
1914 if Componentwise_Assignment (N) then
1915 Expand_Assign_Record (N);
1916 return;
1917 end if;
1919 -- Defend against invalid subscripts on left side if we are in standard
1920 -- validity checking mode. No need to do this if we are checking all
1921 -- subscripts.
1923 -- Note that we do this right away, because there are some early return
1924 -- paths in this procedure, and this is required on all paths.
1926 if Validity_Checks_On
1927 and then Validity_Check_Default
1928 and then not Validity_Check_Subscripts
1929 then
1930 Check_Valid_Lvalue_Subscripts (Lhs);
1931 end if;
1933 -- Separate expansion if RHS contain target names. Note that assignment
1934 -- may already have been expanded if RHS is aggregate.
1936 if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then
1937 Expand_Assign_With_Target_Names (N);
1938 return;
1939 end if;
1941 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
1943 -- Rewrite an assignment to X'Priority into a run-time call
1945 -- For example: X'Priority := New_Prio_Expr;
1946 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
1948 -- Note that although X'Priority is notionally an object, it is quite
1949 -- deliberately not defined as an aliased object in the RM. This means
1950 -- that it works fine to rewrite it as a call, without having to worry
1951 -- about complications that would other arise from X'Priority'Access,
1952 -- which is illegal, because of the lack of aliasing.
1954 if Ada_Version >= Ada_2005 then
1955 declare
1956 Call : Node_Id;
1957 Conctyp : Entity_Id;
1958 Ent : Entity_Id;
1959 Subprg : Entity_Id;
1960 RT_Subprg_Name : Node_Id;
1962 begin
1963 -- Handle chains of renamings
1965 Ent := Name (N);
1966 while Nkind (Ent) in N_Has_Entity
1967 and then Present (Entity (Ent))
1968 and then Present (Renamed_Object (Entity (Ent)))
1969 loop
1970 Ent := Renamed_Object (Entity (Ent));
1971 end loop;
1973 -- The attribute Priority applied to protected objects has been
1974 -- previously expanded into a call to the Get_Ceiling run-time
1975 -- subprogram. In restricted profiles this is not available.
1977 if Is_Expanded_Priority_Attribute (Ent) then
1979 -- Look for the enclosing concurrent type
1981 Conctyp := Current_Scope;
1982 while not Is_Concurrent_Type (Conctyp) loop
1983 Conctyp := Scope (Conctyp);
1984 end loop;
1986 pragma Assert (Is_Protected_Type (Conctyp));
1988 -- Generate the first actual of the call
1990 Subprg := Current_Scope;
1991 while not Present (Protected_Body_Subprogram (Subprg)) loop
1992 Subprg := Scope (Subprg);
1993 end loop;
1995 -- Select the appropriate run-time call
1997 if Number_Entries (Conctyp) = 0 then
1998 RT_Subprg_Name :=
1999 New_Occurrence_Of (RTE (RE_Set_Ceiling), Loc);
2000 else
2001 RT_Subprg_Name :=
2002 New_Occurrence_Of (RTE (RO_PE_Set_Ceiling), Loc);
2003 end if;
2005 Call :=
2006 Make_Procedure_Call_Statement (Loc,
2007 Name => RT_Subprg_Name,
2008 Parameter_Associations => New_List (
2009 New_Copy_Tree (First (Parameter_Associations (Ent))),
2010 Relocate_Node (Expression (N))));
2012 Rewrite (N, Call);
2013 Analyze (N);
2015 return;
2016 end if;
2017 end;
2018 end if;
2020 -- Deal with assignment checks unless suppressed
2022 if not Suppress_Assignment_Checks (N) then
2024 -- First deal with generation of range check if required
2026 if Do_Range_Check (Rhs) then
2027 Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
2028 end if;
2030 -- Then generate predicate check if required
2032 Apply_Predicate_Check (Rhs, Typ);
2033 end if;
2035 -- Check for a special case where a high level transformation is
2036 -- required. If we have either of:
2038 -- P.field := rhs;
2039 -- P (sub) := rhs;
2041 -- where P is a reference to a bit packed array, then we have to unwind
2042 -- the assignment. The exact meaning of being a reference to a bit
2043 -- packed array is as follows:
2045 -- An indexed component whose prefix is a bit packed array is a
2046 -- reference to a bit packed array.
2048 -- An indexed component or selected component whose prefix is a
2049 -- reference to a bit packed array is itself a reference ot a
2050 -- bit packed array.
2052 -- The required transformation is
2054 -- Tnn : prefix_type := P;
2055 -- Tnn.field := rhs;
2056 -- P := Tnn;
2058 -- or
2060 -- Tnn : prefix_type := P;
2061 -- Tnn (subscr) := rhs;
2062 -- P := Tnn;
2064 -- Since P is going to be evaluated more than once, any subscripts
2065 -- in P must have their evaluation forced.
2067 if Nkind_In (Lhs, N_Indexed_Component, N_Selected_Component)
2068 and then Is_Ref_To_Bit_Packed_Array (Prefix (Lhs))
2069 then
2070 declare
2071 BPAR_Expr : constant Node_Id := Relocate_Node (Prefix (Lhs));
2072 BPAR_Typ : constant Entity_Id := Etype (BPAR_Expr);
2073 Tnn : constant Entity_Id :=
2074 Make_Temporary (Loc, 'T', BPAR_Expr);
2076 begin
2077 -- Insert the post assignment first, because we want to copy the
2078 -- BPAR_Expr tree before it gets analyzed in the context of the
2079 -- pre assignment. Note that we do not analyze the post assignment
2080 -- yet (we cannot till we have completed the analysis of the pre
2081 -- assignment). As usual, the analysis of this post assignment
2082 -- will happen on its own when we "run into" it after finishing
2083 -- the current assignment.
2085 Insert_After (N,
2086 Make_Assignment_Statement (Loc,
2087 Name => New_Copy_Tree (BPAR_Expr),
2088 Expression => New_Occurrence_Of (Tnn, Loc)));
2090 -- At this stage BPAR_Expr is a reference to a bit packed array
2091 -- where the reference was not expanded in the original tree,
2092 -- since it was on the left side of an assignment. But in the
2093 -- pre-assignment statement (the object definition), BPAR_Expr
2094 -- will end up on the right-hand side, and must be reexpanded. To
2095 -- achieve this, we reset the analyzed flag of all selected and
2096 -- indexed components down to the actual indexed component for
2097 -- the packed array.
2099 Exp := BPAR_Expr;
2100 loop
2101 Set_Analyzed (Exp, False);
2103 if Nkind_In (Exp, N_Indexed_Component,
2104 N_Selected_Component)
2105 then
2106 Exp := Prefix (Exp);
2107 else
2108 exit;
2109 end if;
2110 end loop;
2112 -- Now we can insert and analyze the pre-assignment
2114 -- If the right-hand side requires a transient scope, it has
2115 -- already been placed on the stack. However, the declaration is
2116 -- inserted in the tree outside of this scope, and must reflect
2117 -- the proper scope for its variable. This awkward bit is forced
2118 -- by the stricter scope discipline imposed by GCC 2.97.
2120 declare
2121 Uses_Transient_Scope : constant Boolean :=
2122 Scope_Is_Transient
2123 and then N = Node_To_Be_Wrapped;
2125 begin
2126 if Uses_Transient_Scope then
2127 Push_Scope (Scope (Current_Scope));
2128 end if;
2130 Insert_Before_And_Analyze (N,
2131 Make_Object_Declaration (Loc,
2132 Defining_Identifier => Tnn,
2133 Object_Definition => New_Occurrence_Of (BPAR_Typ, Loc),
2134 Expression => BPAR_Expr));
2136 if Uses_Transient_Scope then
2137 Pop_Scope;
2138 end if;
2139 end;
2141 -- Now fix up the original assignment and continue processing
2143 Rewrite (Prefix (Lhs),
2144 New_Occurrence_Of (Tnn, Loc));
2146 -- We do not need to reanalyze that assignment, and we do not need
2147 -- to worry about references to the temporary, but we do need to
2148 -- make sure that the temporary is not marked as a true constant
2149 -- since we now have a generated assignment to it.
2151 Set_Is_True_Constant (Tnn, False);
2152 end;
2153 end if;
2155 -- When we have the appropriate type of aggregate in the expression (it
2156 -- has been determined during analysis of the aggregate by setting the
2157 -- delay flag), let's perform in place assignment and thus avoid
2158 -- creating a temporary.
2160 if Is_Delayed_Aggregate (Rhs) then
2161 Convert_Aggr_In_Assignment (N);
2162 Rewrite (N, Make_Null_Statement (Loc));
2163 Analyze (N);
2165 return;
2166 end if;
2168 -- Apply discriminant check if required. If Lhs is an access type to a
2169 -- designated type with discriminants, we must always check. If the
2170 -- type has unknown discriminants, more elaborate processing below.
2172 if Has_Discriminants (Etype (Lhs))
2173 and then not Has_Unknown_Discriminants (Etype (Lhs))
2174 then
2175 -- Skip discriminant check if change of representation. Will be
2176 -- done when the change of representation is expanded out.
2178 if not Crep then
2179 Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs);
2180 end if;
2182 -- If the type is private without discriminants, and the full type
2183 -- has discriminants (necessarily with defaults) a check may still be
2184 -- necessary if the Lhs is aliased. The private discriminants must be
2185 -- visible to build the discriminant constraints.
2187 -- Only an explicit dereference that comes from source indicates
2188 -- aliasing. Access to formals of protected operations and entries
2189 -- create dereferences but are not semantic aliasings.
2191 elsif Is_Private_Type (Etype (Lhs))
2192 and then Has_Discriminants (Typ)
2193 and then Nkind (Lhs) = N_Explicit_Dereference
2194 and then Comes_From_Source (Lhs)
2195 then
2196 declare
2197 Lt : constant Entity_Id := Etype (Lhs);
2198 Ubt : Entity_Id := Base_Type (Typ);
2200 begin
2201 -- In the case of an expander-generated record subtype whose base
2202 -- type still appears private, Typ will have been set to that
2203 -- private type rather than the underlying record type (because
2204 -- Underlying type will have returned the record subtype), so it's
2205 -- necessary to apply Underlying_Type again to the base type to
2206 -- get the record type we need for the discriminant check. Such
2207 -- subtypes can be created for assignments in certain cases, such
2208 -- as within an instantiation passed this kind of private type.
2209 -- It would be good to avoid this special test, but making changes
2210 -- to prevent this odd form of record subtype seems difficult. ???
2212 if Is_Private_Type (Ubt) then
2213 Ubt := Underlying_Type (Ubt);
2214 end if;
2216 Set_Etype (Lhs, Ubt);
2217 Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs));
2218 Apply_Discriminant_Check (Rhs, Ubt, Lhs);
2219 Set_Etype (Lhs, Lt);
2220 end;
2222 -- If the Lhs has a private type with unknown discriminants, it may
2223 -- have a full view with discriminants, but those are nameable only
2224 -- in the underlying type, so convert the Rhs to it before potential
2225 -- checking. Convert Lhs as well, otherwise the actual subtype might
2226 -- not be constructible. If the discriminants have defaults the type
2227 -- is unconstrained and there is nothing to check.
2229 elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs)))
2230 and then Has_Discriminants (Typ)
2231 and then not Has_Defaulted_Discriminants (Typ)
2232 then
2233 Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
2234 Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
2235 Apply_Discriminant_Check (Rhs, Typ, Lhs);
2237 -- In the access type case, we need the same discriminant check, and
2238 -- also range checks if we have an access to constrained array.
2240 elsif Is_Access_Type (Etype (Lhs))
2241 and then Is_Constrained (Designated_Type (Etype (Lhs)))
2242 then
2243 if Has_Discriminants (Designated_Type (Etype (Lhs))) then
2245 -- Skip discriminant check if change of representation. Will be
2246 -- done when the change of representation is expanded out.
2248 if not Crep then
2249 Apply_Discriminant_Check (Rhs, Etype (Lhs));
2250 end if;
2252 elsif Is_Array_Type (Designated_Type (Etype (Lhs))) then
2253 Apply_Range_Check (Rhs, Etype (Lhs));
2255 if Is_Constrained (Etype (Lhs)) then
2256 Apply_Length_Check (Rhs, Etype (Lhs));
2257 end if;
2259 if Nkind (Rhs) = N_Allocator then
2260 declare
2261 Target_Typ : constant Entity_Id := Etype (Expression (Rhs));
2262 C_Es : Check_Result;
2264 begin
2265 C_Es :=
2266 Get_Range_Checks
2267 (Lhs,
2268 Target_Typ,
2269 Etype (Designated_Type (Etype (Lhs))));
2271 Insert_Range_Checks
2272 (C_Es,
2274 Target_Typ,
2275 Sloc (Lhs),
2276 Lhs);
2277 end;
2278 end if;
2279 end if;
2281 -- Apply range check for access type case
2283 elsif Is_Access_Type (Etype (Lhs))
2284 and then Nkind (Rhs) = N_Allocator
2285 and then Nkind (Expression (Rhs)) = N_Qualified_Expression
2286 then
2287 Analyze_And_Resolve (Expression (Rhs));
2288 Apply_Range_Check
2289 (Expression (Rhs), Designated_Type (Etype (Lhs)));
2290 end if;
2292 -- Ada 2005 (AI-231): Generate the run-time check
2294 if Is_Access_Type (Typ)
2295 and then Can_Never_Be_Null (Etype (Lhs))
2296 and then not Can_Never_Be_Null (Etype (Rhs))
2298 -- If an actual is an out parameter of a null-excluding access
2299 -- type, there is access check on entry, so we set the flag
2300 -- Suppress_Assignment_Checks on the generated statement to
2301 -- assign the actual to the parameter block, and we do not want
2302 -- to generate an additional check at this point.
2304 and then not Suppress_Assignment_Checks (N)
2305 then
2306 Apply_Constraint_Check (Rhs, Etype (Lhs));
2307 end if;
2309 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2310 -- stand-alone obj of an anonymous access type. Do not install the check
2311 -- when the Lhs denotes a container cursor and the Next function employs
2312 -- an access type, because this can never result in a dangling pointer.
2314 if Is_Access_Type (Typ)
2315 and then Is_Entity_Name (Lhs)
2316 and then Ekind (Entity (Lhs)) /= E_Loop_Parameter
2317 and then Present (Effective_Extra_Accessibility (Entity (Lhs)))
2318 then
2319 declare
2320 function Lhs_Entity return Entity_Id;
2321 -- Look through renames to find the underlying entity.
2322 -- For assignment to a rename, we don't care about the
2323 -- Enclosing_Dynamic_Scope of the rename declaration.
2325 ----------------
2326 -- Lhs_Entity --
2327 ----------------
2329 function Lhs_Entity return Entity_Id is
2330 Result : Entity_Id := Entity (Lhs);
2332 begin
2333 while Present (Renamed_Object (Result)) loop
2335 -- Renamed_Object must return an Entity_Name here
2336 -- because of preceding "Present (E_E_A (...))" test.
2338 Result := Entity (Renamed_Object (Result));
2339 end loop;
2341 return Result;
2342 end Lhs_Entity;
2344 -- Local Declarations
2346 Access_Check : constant Node_Id :=
2347 Make_Raise_Program_Error (Loc,
2348 Condition =>
2349 Make_Op_Gt (Loc,
2350 Left_Opnd =>
2351 Dynamic_Accessibility_Level (Rhs),
2352 Right_Opnd =>
2353 Make_Integer_Literal (Loc,
2354 Intval =>
2355 Scope_Depth
2356 (Enclosing_Dynamic_Scope
2357 (Lhs_Entity)))),
2358 Reason => PE_Accessibility_Check_Failed);
2360 Access_Level_Update : constant Node_Id :=
2361 Make_Assignment_Statement (Loc,
2362 Name =>
2363 New_Occurrence_Of
2364 (Effective_Extra_Accessibility
2365 (Entity (Lhs)), Loc),
2366 Expression =>
2367 Dynamic_Accessibility_Level (Rhs));
2369 begin
2370 if not Accessibility_Checks_Suppressed (Entity (Lhs)) then
2371 Insert_Action (N, Access_Check);
2372 end if;
2374 Insert_Action (N, Access_Level_Update);
2375 end;
2376 end if;
2378 -- Case of assignment to a bit packed array element. If there is a
2379 -- change of representation this must be expanded into components,
2380 -- otherwise this is a bit-field assignment.
2382 if Nkind (Lhs) = N_Indexed_Component
2383 and then Is_Bit_Packed_Array (Etype (Prefix (Lhs)))
2384 then
2385 -- Normal case, no change of representation
2387 if not Crep then
2388 Expand_Bit_Packed_Element_Set (N);
2389 return;
2391 -- Change of representation case
2393 else
2394 -- Generate the following, to force component-by-component
2395 -- assignments in an efficient way. Otherwise each component
2396 -- will require a temporary and two bit-field manipulations.
2398 -- T1 : Elmt_Type;
2399 -- T1 := RhS;
2400 -- Lhs := T1;
2402 declare
2403 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T');
2404 Stats : List_Id;
2406 begin
2407 Stats :=
2408 New_List (
2409 Make_Object_Declaration (Loc,
2410 Defining_Identifier => Tnn,
2411 Object_Definition =>
2412 New_Occurrence_Of (Etype (Lhs), Loc)),
2413 Make_Assignment_Statement (Loc,
2414 Name => New_Occurrence_Of (Tnn, Loc),
2415 Expression => Relocate_Node (Rhs)),
2416 Make_Assignment_Statement (Loc,
2417 Name => Relocate_Node (Lhs),
2418 Expression => New_Occurrence_Of (Tnn, Loc)));
2420 Insert_Actions (N, Stats);
2421 Rewrite (N, Make_Null_Statement (Loc));
2422 Analyze (N);
2423 end;
2424 end if;
2426 -- Build-in-place function call case. This is for assignment statements
2427 -- that come from aggregate component associations or from init procs.
2428 -- User-written assignment statements with b-i-p calls are handled
2429 -- elsewhere.
2431 elsif Is_Build_In_Place_Function_Call (Rhs) then
2432 pragma Assert (not Comes_From_Source (N));
2433 Make_Build_In_Place_Call_In_Assignment (N, Rhs);
2435 elsif Is_Tagged_Type (Typ)
2436 or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ))
2437 then
2438 Tagged_Case : declare
2439 L : List_Id := No_List;
2440 Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N);
2442 begin
2443 -- In the controlled case, we ensure that function calls are
2444 -- evaluated before finalizing the target. In all cases, it makes
2445 -- the expansion easier if the side effects are removed first.
2447 Remove_Side_Effects (Lhs);
2448 Remove_Side_Effects (Rhs);
2450 -- Avoid recursion in the mechanism
2452 Set_Analyzed (N);
2454 -- If dispatching assignment, we need to dispatch to _assign
2456 if Is_Class_Wide_Type (Typ)
2458 -- If the type is tagged, we may as well use the predefined
2459 -- primitive assignment. This avoids inlining a lot of code
2460 -- and in the class-wide case, the assignment is replaced
2461 -- by a dispatching call to _assign. It is suppressed in the
2462 -- case of assignments created by the expander that correspond
2463 -- to initializations, where we do want to copy the tag
2464 -- (Expand_Ctrl_Actions flag is set False in this case). It is
2465 -- also suppressed if restriction No_Dispatching_Calls is in
2466 -- force because in that case predefined primitives are not
2467 -- generated.
2469 or else (Is_Tagged_Type (Typ)
2470 and then Chars (Current_Scope) /= Name_uAssign
2471 and then Expand_Ctrl_Actions
2472 and then
2473 not Restriction_Active (No_Dispatching_Calls))
2474 then
2475 if Is_Limited_Type (Typ) then
2477 -- This can happen in an instance when the formal is an
2478 -- extension of a limited interface, and the actual is
2479 -- limited. This is an error according to AI05-0087, but
2480 -- is not caught at the point of instantiation in earlier
2481 -- versions. We also must verify that the limited type does
2482 -- not come from source as corner cases may exist where
2483 -- an assignment was not intended like the pathological case
2484 -- of a raise expression within a return statement.
2486 -- This is wrong, error messages cannot be issued during
2487 -- expansion, since they would be missed in -gnatc mode ???
2489 if Comes_From_Source (N) then
2490 Error_Msg_N
2491 ("assignment not available on limited type", N);
2492 end if;
2494 return;
2495 end if;
2497 -- Fetch the primitive op _assign and proper type to call it.
2498 -- Because of possible conflicts between private and full view,
2499 -- fetch the proper type directly from the operation profile.
2501 declare
2502 Op : constant Entity_Id :=
2503 Find_Prim_Op (Typ, Name_uAssign);
2504 F_Typ : Entity_Id := Etype (First_Formal (Op));
2506 begin
2507 -- If the assignment is dispatching, make sure to use the
2508 -- proper type.
2510 if Is_Class_Wide_Type (Typ) then
2511 F_Typ := Class_Wide_Type (F_Typ);
2512 end if;
2514 L := New_List;
2516 -- In case of assignment to a class-wide tagged type, before
2517 -- the assignment we generate run-time check to ensure that
2518 -- the tags of source and target match.
2520 if not Tag_Checks_Suppressed (Typ)
2521 and then Is_Class_Wide_Type (Typ)
2522 and then Is_Tagged_Type (Typ)
2523 and then Is_Tagged_Type (Underlying_Type (Etype (Rhs)))
2524 then
2525 declare
2526 Lhs_Tag : Node_Id;
2527 Rhs_Tag : Node_Id;
2529 begin
2530 if not Is_Interface (Typ) then
2531 Lhs_Tag :=
2532 Make_Selected_Component (Loc,
2533 Prefix => Duplicate_Subexpr (Lhs),
2534 Selector_Name =>
2535 Make_Identifier (Loc, Name_uTag));
2536 Rhs_Tag :=
2537 Make_Selected_Component (Loc,
2538 Prefix => Duplicate_Subexpr (Rhs),
2539 Selector_Name =>
2540 Make_Identifier (Loc, Name_uTag));
2541 else
2542 -- Displace the pointer to the base of the objects
2543 -- applying 'Address, which is later expanded into
2544 -- a call to RE_Base_Address.
2546 Lhs_Tag :=
2547 Make_Explicit_Dereference (Loc,
2548 Prefix =>
2549 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
2550 Make_Attribute_Reference (Loc,
2551 Prefix => Duplicate_Subexpr (Lhs),
2552 Attribute_Name => Name_Address)));
2553 Rhs_Tag :=
2554 Make_Explicit_Dereference (Loc,
2555 Prefix =>
2556 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
2557 Make_Attribute_Reference (Loc,
2558 Prefix => Duplicate_Subexpr (Rhs),
2559 Attribute_Name => Name_Address)));
2560 end if;
2562 Append_To (L,
2563 Make_Raise_Constraint_Error (Loc,
2564 Condition =>
2565 Make_Op_Ne (Loc,
2566 Left_Opnd => Lhs_Tag,
2567 Right_Opnd => Rhs_Tag),
2568 Reason => CE_Tag_Check_Failed));
2569 end;
2570 end if;
2572 declare
2573 Left_N : Node_Id := Duplicate_Subexpr (Lhs);
2574 Right_N : Node_Id := Duplicate_Subexpr (Rhs);
2576 begin
2577 -- In order to dispatch the call to _assign the type of
2578 -- the actuals must match. Add conversion (if required).
2580 if Etype (Lhs) /= F_Typ then
2581 Left_N := Unchecked_Convert_To (F_Typ, Left_N);
2582 end if;
2584 if Etype (Rhs) /= F_Typ then
2585 Right_N := Unchecked_Convert_To (F_Typ, Right_N);
2586 end if;
2588 Append_To (L,
2589 Make_Procedure_Call_Statement (Loc,
2590 Name => New_Occurrence_Of (Op, Loc),
2591 Parameter_Associations => New_List (
2592 Node1 => Left_N,
2593 Node2 => Right_N)));
2594 end;
2595 end;
2597 else
2598 L := Make_Tag_Ctrl_Assignment (N);
2600 -- We can't afford to have destructive Finalization Actions in
2601 -- the Self assignment case, so if the target and the source
2602 -- are not obviously different, code is generated to avoid the
2603 -- self assignment case:
2605 -- if lhs'address /= rhs'address then
2606 -- <code for controlled and/or tagged assignment>
2607 -- end if;
2609 -- Skip this if Restriction (No_Finalization) is active
2611 if not Statically_Different (Lhs, Rhs)
2612 and then Expand_Ctrl_Actions
2613 and then not Restriction_Active (No_Finalization)
2614 then
2615 L := New_List (
2616 Make_Implicit_If_Statement (N,
2617 Condition =>
2618 Make_Op_Ne (Loc,
2619 Left_Opnd =>
2620 Make_Attribute_Reference (Loc,
2621 Prefix => Duplicate_Subexpr (Lhs),
2622 Attribute_Name => Name_Address),
2624 Right_Opnd =>
2625 Make_Attribute_Reference (Loc,
2626 Prefix => Duplicate_Subexpr (Rhs),
2627 Attribute_Name => Name_Address)),
2629 Then_Statements => L));
2630 end if;
2632 -- We need to set up an exception handler for implementing
2633 -- 7.6.1(18). The remaining adjustments are tackled by the
2634 -- implementation of adjust for record_controllers (see
2635 -- s-finimp.adb).
2637 -- This is skipped if we have no finalization
2639 if Expand_Ctrl_Actions
2640 and then not Restriction_Active (No_Finalization)
2641 then
2642 L := New_List (
2643 Make_Block_Statement (Loc,
2644 Handled_Statement_Sequence =>
2645 Make_Handled_Sequence_Of_Statements (Loc,
2646 Statements => L,
2647 Exception_Handlers => New_List (
2648 Make_Handler_For_Ctrl_Operation (Loc)))));
2649 end if;
2650 end if;
2652 Rewrite (N,
2653 Make_Block_Statement (Loc,
2654 Handled_Statement_Sequence =>
2655 Make_Handled_Sequence_Of_Statements (Loc, Statements => L)));
2657 -- If no restrictions on aborts, protect the whole assignment
2658 -- for controlled objects as per 9.8(11).
2660 if Needs_Finalization (Typ)
2661 and then Expand_Ctrl_Actions
2662 and then Abort_Allowed
2663 then
2664 declare
2665 Blk : constant Entity_Id :=
2666 New_Internal_Entity
2667 (E_Block, Current_Scope, Sloc (N), 'B');
2668 AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
2670 begin
2671 Set_Is_Abort_Block (N);
2673 Set_Scope (Blk, Current_Scope);
2674 Set_Etype (Blk, Standard_Void_Type);
2675 Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
2677 Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
2678 Set_At_End_Proc (Handled_Statement_Sequence (N),
2679 New_Occurrence_Of (AUD, Loc));
2681 -- Present the Abort_Undefer_Direct function to the backend
2682 -- so that it can inline the call to the function.
2684 Add_Inlined_Body (AUD, N);
2686 Expand_At_End_Handler
2687 (Handled_Statement_Sequence (N), Blk);
2688 end;
2689 end if;
2691 -- N has been rewritten to a block statement for which it is
2692 -- known by construction that no checks are necessary: analyze
2693 -- it with all checks suppressed.
2695 Analyze (N, Suppress => All_Checks);
2696 return;
2697 end Tagged_Case;
2699 -- Array types
2701 elsif Is_Array_Type (Typ) then
2702 declare
2703 Actual_Rhs : Node_Id := Rhs;
2705 begin
2706 while Nkind_In (Actual_Rhs, N_Type_Conversion,
2707 N_Qualified_Expression)
2708 loop
2709 Actual_Rhs := Expression (Actual_Rhs);
2710 end loop;
2712 Expand_Assign_Array (N, Actual_Rhs);
2713 return;
2714 end;
2716 -- Record types
2718 elsif Is_Record_Type (Typ) then
2719 Expand_Assign_Record (N);
2720 return;
2722 -- Scalar types. This is where we perform the processing related to the
2723 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
2724 -- scalar values.
2726 elsif Is_Scalar_Type (Typ) then
2728 -- Case where right side is known valid
2730 if Expr_Known_Valid (Rhs) then
2732 -- Here the right side is valid, so it is fine. The case to deal
2733 -- with is when the left side is a local variable reference whose
2734 -- value is not currently known to be valid. If this is the case,
2735 -- and the assignment appears in an unconditional context, then
2736 -- we can mark the left side as now being valid if one of these
2737 -- conditions holds:
2739 -- The expression of the right side has Do_Range_Check set so
2740 -- that we know a range check will be performed. Note that it
2741 -- can be the case that a range check is omitted because we
2742 -- make the assumption that we can assume validity for operands
2743 -- appearing in the right side in determining whether a range
2744 -- check is required
2746 -- The subtype of the right side matches the subtype of the
2747 -- left side. In this case, even though we have not checked
2748 -- the range of the right side, we know it is in range of its
2749 -- subtype if the expression is valid.
2751 if Is_Local_Variable_Reference (Lhs)
2752 and then not Is_Known_Valid (Entity (Lhs))
2753 and then In_Unconditional_Context (N)
2754 then
2755 if Do_Range_Check (Rhs)
2756 or else Etype (Lhs) = Etype (Rhs)
2757 then
2758 Set_Is_Known_Valid (Entity (Lhs), True);
2759 end if;
2760 end if;
2762 -- Case where right side may be invalid in the sense of the RM
2763 -- reference above. The RM does not require that we check for the
2764 -- validity on an assignment, but it does require that the assignment
2765 -- of an invalid value not cause erroneous behavior.
2767 -- The general approach in GNAT is to use the Is_Known_Valid flag
2768 -- to avoid the need for validity checking on assignments. However
2769 -- in some cases, we have to do validity checking in order to make
2770 -- sure that the setting of this flag is correct.
2772 else
2773 -- Validate right side if we are validating copies
2775 if Validity_Checks_On
2776 and then Validity_Check_Copies
2777 then
2778 -- Skip this if left-hand side is an array or record component
2779 -- and elementary component validity checks are suppressed.
2781 if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component)
2782 and then not Validity_Check_Components
2783 then
2784 null;
2785 else
2786 Ensure_Valid (Rhs);
2787 end if;
2789 -- We can propagate this to the left side where appropriate
2791 if Is_Local_Variable_Reference (Lhs)
2792 and then not Is_Known_Valid (Entity (Lhs))
2793 and then In_Unconditional_Context (N)
2794 then
2795 Set_Is_Known_Valid (Entity (Lhs), True);
2796 end if;
2798 -- Otherwise check to see what should be done
2800 -- If left side is a local variable, then we just set its flag to
2801 -- indicate that its value may no longer be valid, since we are
2802 -- copying a potentially invalid value.
2804 elsif Is_Local_Variable_Reference (Lhs) then
2805 Set_Is_Known_Valid (Entity (Lhs), False);
2807 -- Check for case of a nonlocal variable on the left side which
2808 -- is currently known to be valid. In this case, we simply ensure
2809 -- that the right side is valid. We only play the game of copying
2810 -- validity status for local variables, since we are doing this
2811 -- statically, not by tracing the full flow graph.
2813 elsif Is_Entity_Name (Lhs)
2814 and then Is_Known_Valid (Entity (Lhs))
2815 then
2816 -- Note: If Validity_Checking mode is set to none, we ignore
2817 -- the Ensure_Valid call so don't worry about that case here.
2819 Ensure_Valid (Rhs);
2821 -- In all other cases, we can safely copy an invalid value without
2822 -- worrying about the status of the left side. Since it is not a
2823 -- variable reference it will not be considered
2824 -- as being known to be valid in any case.
2826 else
2827 null;
2828 end if;
2829 end if;
2830 end if;
2832 exception
2833 when RE_Not_Available =>
2834 return;
2835 end Expand_N_Assignment_Statement;
2837 ------------------------------
2838 -- Expand_N_Block_Statement --
2839 ------------------------------
2841 -- Encode entity names defined in block statement
2843 procedure Expand_N_Block_Statement (N : Node_Id) is
2844 begin
2845 Qualify_Entity_Names (N);
2846 end Expand_N_Block_Statement;
2848 -----------------------------
2849 -- Expand_N_Case_Statement --
2850 -----------------------------
2852 procedure Expand_N_Case_Statement (N : Node_Id) is
2853 Loc : constant Source_Ptr := Sloc (N);
2854 Expr : constant Node_Id := Expression (N);
2855 Alt : Node_Id;
2856 Len : Nat;
2857 Cond : Node_Id;
2858 Choice : Node_Id;
2859 Chlist : List_Id;
2861 begin
2862 -- Check for the situation where we know at compile time which branch
2863 -- will be taken.
2865 -- If the value is static but its subtype is predicated and the value
2866 -- does not obey the predicate, the value is marked non-static, and
2867 -- there can be no corresponding static alternative. In that case we
2868 -- replace the case statement with an exception, regardless of whether
2869 -- assertions are enabled or not, unless predicates are ignored.
2871 if Compile_Time_Known_Value (Expr)
2872 and then Has_Predicates (Etype (Expr))
2873 and then not Predicates_Ignored (Etype (Expr))
2874 and then not Is_OK_Static_Expression (Expr)
2875 then
2876 Rewrite (N,
2877 Make_Raise_Constraint_Error (Loc, Reason => CE_Invalid_Data));
2878 Analyze (N);
2879 return;
2881 elsif Compile_Time_Known_Value (Expr)
2882 and then (not Has_Predicates (Etype (Expr))
2883 or else Is_Static_Expression (Expr))
2884 then
2885 Alt := Find_Static_Alternative (N);
2887 -- Do not consider controlled objects found in a case statement which
2888 -- actually models a case expression because their early finalization
2889 -- will affect the result of the expression.
2891 if not From_Conditional_Expression (N) then
2892 Process_Statements_For_Controlled_Objects (Alt);
2893 end if;
2895 -- Move statements from this alternative after the case statement.
2896 -- They are already analyzed, so will be skipped by the analyzer.
2898 Insert_List_After (N, Statements (Alt));
2900 -- That leaves the case statement as a shell. So now we can kill all
2901 -- other alternatives in the case statement.
2903 Kill_Dead_Code (Expression (N));
2905 declare
2906 Dead_Alt : Node_Id;
2908 begin
2909 -- Loop through case alternatives, skipping pragmas, and skipping
2910 -- the one alternative that we select (and therefore retain).
2912 Dead_Alt := First (Alternatives (N));
2913 while Present (Dead_Alt) loop
2914 if Dead_Alt /= Alt
2915 and then Nkind (Dead_Alt) = N_Case_Statement_Alternative
2916 then
2917 Kill_Dead_Code (Statements (Dead_Alt), Warn_On_Deleted_Code);
2918 end if;
2920 Next (Dead_Alt);
2921 end loop;
2922 end;
2924 Rewrite (N, Make_Null_Statement (Loc));
2925 return;
2926 end if;
2928 -- Here if the choice is not determined at compile time
2930 declare
2931 Last_Alt : constant Node_Id := Last (Alternatives (N));
2933 Others_Present : Boolean;
2934 Others_Node : Node_Id;
2936 Then_Stms : List_Id;
2937 Else_Stms : List_Id;
2939 begin
2940 if Nkind (First (Discrete_Choices (Last_Alt))) = N_Others_Choice then
2941 Others_Present := True;
2942 Others_Node := Last_Alt;
2943 else
2944 Others_Present := False;
2945 end if;
2947 -- First step is to worry about possible invalid argument. The RM
2948 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
2949 -- outside the base range), then Constraint_Error must be raised.
2951 -- Case of validity check required (validity checks are on, the
2952 -- expression is not known to be valid, and the case statement
2953 -- comes from source -- no need to validity check internally
2954 -- generated case statements).
2956 if Validity_Check_Default
2957 and then not Predicates_Ignored (Etype (Expr))
2958 then
2959 Ensure_Valid (Expr);
2960 end if;
2962 -- If there is only a single alternative, just replace it with the
2963 -- sequence of statements since obviously that is what is going to
2964 -- be executed in all cases.
2966 Len := List_Length (Alternatives (N));
2968 if Len = 1 then
2970 -- We still need to evaluate the expression if it has any side
2971 -- effects.
2973 Remove_Side_Effects (Expression (N));
2974 Alt := First (Alternatives (N));
2976 -- Do not consider controlled objects found in a case statement
2977 -- which actually models a case expression because their early
2978 -- finalization will affect the result of the expression.
2980 if not From_Conditional_Expression (N) then
2981 Process_Statements_For_Controlled_Objects (Alt);
2982 end if;
2984 Insert_List_After (N, Statements (Alt));
2986 -- That leaves the case statement as a shell. The alternative that
2987 -- will be executed is reset to a null list. So now we can kill
2988 -- the entire case statement.
2990 Kill_Dead_Code (Expression (N));
2991 Rewrite (N, Make_Null_Statement (Loc));
2992 return;
2994 -- An optimization. If there are only two alternatives, and only
2995 -- a single choice, then rewrite the whole case statement as an
2996 -- if statement, since this can result in subsequent optimizations.
2997 -- This helps not only with case statements in the source of a
2998 -- simple form, but also with generated code (discriminant check
2999 -- functions in particular).
3001 -- Note: it is OK to do this before expanding out choices for any
3002 -- static predicates, since the if statement processing will handle
3003 -- the static predicate case fine.
3005 elsif Len = 2 then
3006 Chlist := Discrete_Choices (First (Alternatives (N)));
3008 if List_Length (Chlist) = 1 then
3009 Choice := First (Chlist);
3011 Then_Stms := Statements (First (Alternatives (N)));
3012 Else_Stms := Statements (Last (Alternatives (N)));
3014 -- For TRUE, generate "expression", not expression = true
3016 if Nkind (Choice) = N_Identifier
3017 and then Entity (Choice) = Standard_True
3018 then
3019 Cond := Expression (N);
3021 -- For FALSE, generate "expression" and switch then/else
3023 elsif Nkind (Choice) = N_Identifier
3024 and then Entity (Choice) = Standard_False
3025 then
3026 Cond := Expression (N);
3027 Else_Stms := Statements (First (Alternatives (N)));
3028 Then_Stms := Statements (Last (Alternatives (N)));
3030 -- For a range, generate "expression in range"
3032 elsif Nkind (Choice) = N_Range
3033 or else (Nkind (Choice) = N_Attribute_Reference
3034 and then Attribute_Name (Choice) = Name_Range)
3035 or else (Is_Entity_Name (Choice)
3036 and then Is_Type (Entity (Choice)))
3037 then
3038 Cond :=
3039 Make_In (Loc,
3040 Left_Opnd => Expression (N),
3041 Right_Opnd => Relocate_Node (Choice));
3043 -- A subtype indication is not a legal operator in a membership
3044 -- test, so retrieve its range.
3046 elsif Nkind (Choice) = N_Subtype_Indication then
3047 Cond :=
3048 Make_In (Loc,
3049 Left_Opnd => Expression (N),
3050 Right_Opnd =>
3051 Relocate_Node
3052 (Range_Expression (Constraint (Choice))));
3054 -- For any other subexpression "expression = value"
3056 else
3057 Cond :=
3058 Make_Op_Eq (Loc,
3059 Left_Opnd => Expression (N),
3060 Right_Opnd => Relocate_Node (Choice));
3061 end if;
3063 -- Now rewrite the case as an IF
3065 Rewrite (N,
3066 Make_If_Statement (Loc,
3067 Condition => Cond,
3068 Then_Statements => Then_Stms,
3069 Else_Statements => Else_Stms));
3070 Analyze (N);
3071 return;
3072 end if;
3073 end if;
3075 -- If the last alternative is not an Others choice, replace it with
3076 -- an N_Others_Choice. Note that we do not bother to call Analyze on
3077 -- the modified case statement, since it's only effect would be to
3078 -- compute the contents of the Others_Discrete_Choices which is not
3079 -- needed by the back end anyway.
3081 -- The reason for this is that the back end always needs some default
3082 -- for a switch, so if we have not supplied one in the processing
3083 -- above for validity checking, then we need to supply one here.
3085 if not Others_Present then
3086 Others_Node := Make_Others_Choice (Sloc (Last_Alt));
3088 -- If Predicates_Ignored is true the value does not satisfy the
3089 -- predicate, and there is no Others choice, Constraint_Error
3090 -- must be raised (4.5.7 (21/3)).
3092 if Predicates_Ignored (Etype (Expr)) then
3093 declare
3094 Except : constant Node_Id :=
3095 Make_Raise_Constraint_Error (Loc,
3096 Reason => CE_Invalid_Data);
3097 New_Alt : constant Node_Id :=
3098 Make_Case_Statement_Alternative (Loc,
3099 Discrete_Choices => New_List (
3100 Make_Others_Choice (Loc)),
3101 Statements => New_List (Except));
3103 begin
3104 Append (New_Alt, Alternatives (N));
3105 Analyze_And_Resolve (Except);
3106 end;
3108 else
3109 Set_Others_Discrete_Choices
3110 (Others_Node, Discrete_Choices (Last_Alt));
3111 Set_Discrete_Choices (Last_Alt, New_List (Others_Node));
3112 end if;
3114 end if;
3116 -- Deal with possible declarations of controlled objects, and also
3117 -- with rewriting choice sequences for static predicate references.
3119 Alt := First_Non_Pragma (Alternatives (N));
3120 while Present (Alt) loop
3122 -- Do not consider controlled objects found in a case statement
3123 -- which actually models a case expression because their early
3124 -- finalization will affect the result of the expression.
3126 if not From_Conditional_Expression (N) then
3127 Process_Statements_For_Controlled_Objects (Alt);
3128 end if;
3130 if Has_SP_Choice (Alt) then
3131 Expand_Static_Predicates_In_Choices (Alt);
3132 end if;
3134 Next_Non_Pragma (Alt);
3135 end loop;
3136 end;
3137 end Expand_N_Case_Statement;
3139 -----------------------------
3140 -- Expand_N_Exit_Statement --
3141 -----------------------------
3143 -- The only processing required is to deal with a possible C/Fortran
3144 -- boolean value used as the condition for the exit statement.
3146 procedure Expand_N_Exit_Statement (N : Node_Id) is
3147 begin
3148 Adjust_Condition (Condition (N));
3149 end Expand_N_Exit_Statement;
3151 ----------------------------------
3152 -- Expand_Formal_Container_Loop --
3153 ----------------------------------
3155 procedure Expand_Formal_Container_Loop (N : Node_Id) is
3156 Loc : constant Source_Ptr := Sloc (N);
3157 Isc : constant Node_Id := Iteration_Scheme (N);
3158 I_Spec : constant Node_Id := Iterator_Specification (Isc);
3159 Cursor : constant Entity_Id := Defining_Identifier (I_Spec);
3160 Container : constant Node_Id := Entity (Name (I_Spec));
3161 Stats : constant List_Id := Statements (N);
3163 Advance : Node_Id;
3164 Init_Decl : Node_Id;
3165 Init_Name : Entity_Id;
3166 New_Loop : Node_Id;
3168 begin
3169 -- The expansion of a formal container loop resembles the one for Ada
3170 -- containers. The only difference is that the primitives mention the
3171 -- domain of iteration explicitly, and function First applied to the
3172 -- container yields a cursor directly.
3174 -- Cursor : Cursor_type := First (Container);
3175 -- while Has_Element (Cursor, Container) loop
3176 -- <original loop statements>
3177 -- Cursor := Next (Container, Cursor);
3178 -- end loop;
3180 Build_Formal_Container_Iteration
3181 (N, Container, Cursor, Init_Decl, Advance, New_Loop);
3183 Append_To (Stats, Advance);
3185 -- Build a block to capture declaration of the cursor
3187 Rewrite (N,
3188 Make_Block_Statement (Loc,
3189 Declarations => New_List (Init_Decl),
3190 Handled_Statement_Sequence =>
3191 Make_Handled_Sequence_Of_Statements (Loc,
3192 Statements => New_List (New_Loop))));
3194 -- The loop parameter is declared by an object declaration, but within
3195 -- the loop we must prevent user assignments to it, so we analyze the
3196 -- declaration and reset the entity kind, before analyzing the rest of
3197 -- the loop.
3199 Analyze (Init_Decl);
3200 Init_Name := Defining_Identifier (Init_Decl);
3201 Set_Ekind (Init_Name, E_Loop_Parameter);
3203 -- The cursor was marked as a loop parameter to prevent user assignments
3204 -- to it, however this renders the advancement step illegal as it is not
3205 -- possible to change the value of a constant. Flag the advancement step
3206 -- as a legal form of assignment to remedy this side effect.
3208 Set_Assignment_OK (Name (Advance));
3209 Analyze (N);
3211 -- Because we have to analyze the initial declaration of the loop
3212 -- parameter multiple times its scope is incorrectly set at this point
3213 -- to the one surrounding the block statement - so set the scope
3214 -- manually to be the actual block statement, and indicate that it is
3215 -- not visible after the block has been analyzed.
3217 Set_Scope (Init_Name, Entity (Identifier (N)));
3218 Set_Is_Immediately_Visible (Init_Name, False);
3219 end Expand_Formal_Container_Loop;
3221 ------------------------------------------
3222 -- Expand_Formal_Container_Element_Loop --
3223 ------------------------------------------
3225 procedure Expand_Formal_Container_Element_Loop (N : Node_Id) is
3226 Loc : constant Source_Ptr := Sloc (N);
3227 Isc : constant Node_Id := Iteration_Scheme (N);
3228 I_Spec : constant Node_Id := Iterator_Specification (Isc);
3229 Element : constant Entity_Id := Defining_Identifier (I_Spec);
3230 Container : constant Node_Id := Entity (Name (I_Spec));
3231 Container_Typ : constant Entity_Id := Base_Type (Etype (Container));
3232 Stats : constant List_Id := Statements (N);
3234 Cursor : constant Entity_Id :=
3235 Make_Defining_Identifier (Loc,
3236 Chars => New_External_Name (Chars (Element), 'C'));
3237 Elmt_Decl : Node_Id;
3238 Elmt_Ref : Node_Id;
3240 Element_Op : constant Entity_Id :=
3241 Get_Iterable_Type_Primitive (Container_Typ, Name_Element);
3243 Advance : Node_Id;
3244 Init : Node_Id;
3245 New_Loop : Node_Id;
3247 begin
3248 -- For an element iterator, the Element aspect must be present,
3249 -- (this is checked during analysis) and the expansion takes the form:
3251 -- Cursor : Cursor_Type := First (Container);
3252 -- Elmt : Element_Type;
3253 -- while Has_Element (Cursor, Container) loop
3254 -- Elmt := Element (Container, Cursor);
3255 -- <original loop statements>
3256 -- Cursor := Next (Container, Cursor);
3257 -- end loop;
3259 -- However this expansion is not legal if the element is indefinite.
3260 -- In that case we create a block to hold a variable declaration
3261 -- initialized with a call to Element, and generate:
3263 -- Cursor : Cursor_Type := First (Container);
3264 -- while Has_Element (Cursor, Container) loop
3265 -- declare
3266 -- Elmt : Element_Type := Element (Container, Cursor);
3267 -- begin
3268 -- <original loop statements>
3269 -- Cursor := Next (Container, Cursor);
3270 -- end;
3271 -- end loop;
3273 Build_Formal_Container_Iteration
3274 (N, Container, Cursor, Init, Advance, New_Loop);
3275 Append_To (Stats, Advance);
3277 Set_Ekind (Cursor, E_Variable);
3278 Insert_Action (N, Init);
3280 -- The loop parameter is declared by an object declaration, but within
3281 -- the loop we must prevent user assignments to it; the following flag
3282 -- accomplishes that.
3284 Set_Is_Loop_Parameter (Element);
3286 -- Declaration for Element
3288 Elmt_Decl :=
3289 Make_Object_Declaration (Loc,
3290 Defining_Identifier => Element,
3291 Object_Definition => New_Occurrence_Of (Etype (Element_Op), Loc));
3293 if not Is_Constrained (Etype (Element_Op)) then
3294 Set_Expression (Elmt_Decl,
3295 Make_Function_Call (Loc,
3296 Name => New_Occurrence_Of (Element_Op, Loc),
3297 Parameter_Associations => New_List (
3298 Convert_To_Iterable_Type (Container, Loc),
3299 New_Occurrence_Of (Cursor, Loc))));
3301 Set_Statements (New_Loop,
3302 New_List
3303 (Make_Block_Statement (Loc,
3304 Declarations => New_List (Elmt_Decl),
3305 Handled_Statement_Sequence =>
3306 Make_Handled_Sequence_Of_Statements (Loc,
3307 Statements => Stats))));
3309 else
3310 Elmt_Ref :=
3311 Make_Assignment_Statement (Loc,
3312 Name => New_Occurrence_Of (Element, Loc),
3313 Expression =>
3314 Make_Function_Call (Loc,
3315 Name => New_Occurrence_Of (Element_Op, Loc),
3316 Parameter_Associations => New_List (
3317 Convert_To_Iterable_Type (Container, Loc),
3318 New_Occurrence_Of (Cursor, Loc))));
3320 Prepend (Elmt_Ref, Stats);
3322 -- The element is assignable in the expanded code
3324 Set_Assignment_OK (Name (Elmt_Ref));
3326 -- The loop is rewritten as a block, to hold the element declaration
3328 New_Loop :=
3329 Make_Block_Statement (Loc,
3330 Declarations => New_List (Elmt_Decl),
3331 Handled_Statement_Sequence =>
3332 Make_Handled_Sequence_Of_Statements (Loc,
3333 Statements => New_List (New_Loop)));
3334 end if;
3336 -- The element is only modified in expanded code, so it appears as
3337 -- unassigned to the warning machinery. We must suppress this spurious
3338 -- warning explicitly.
3340 Set_Warnings_Off (Element);
3342 Rewrite (N, New_Loop);
3343 Analyze (N);
3344 end Expand_Formal_Container_Element_Loop;
3346 -----------------------------
3347 -- Expand_N_Goto_Statement --
3348 -----------------------------
3350 -- Add poll before goto if polling active
3352 procedure Expand_N_Goto_Statement (N : Node_Id) is
3353 begin
3354 Generate_Poll_Call (N);
3355 end Expand_N_Goto_Statement;
3357 ---------------------------
3358 -- Expand_N_If_Statement --
3359 ---------------------------
3361 -- First we deal with the case of C and Fortran convention boolean values,
3362 -- with zero/non-zero semantics.
3364 -- Second, we deal with the obvious rewriting for the cases where the
3365 -- condition of the IF is known at compile time to be True or False.
3367 -- Third, we remove elsif parts which have non-empty Condition_Actions and
3368 -- rewrite as independent if statements. For example:
3370 -- if x then xs
3371 -- elsif y then ys
3372 -- ...
3373 -- end if;
3375 -- becomes
3377 -- if x then xs
3378 -- else
3379 -- <<condition actions of y>>
3380 -- if y then ys
3381 -- ...
3382 -- end if;
3383 -- end if;
3385 -- This rewriting is needed if at least one elsif part has a non-empty
3386 -- Condition_Actions list. We also do the same processing if there is a
3387 -- constant condition in an elsif part (in conjunction with the first
3388 -- processing step mentioned above, for the recursive call made to deal
3389 -- with the created inner if, this deals with properly optimizing the
3390 -- cases of constant elsif conditions).
3392 procedure Expand_N_If_Statement (N : Node_Id) is
3393 Loc : constant Source_Ptr := Sloc (N);
3394 Hed : Node_Id;
3395 E : Node_Id;
3396 New_If : Node_Id;
3398 Warn_If_Deleted : constant Boolean :=
3399 Warn_On_Deleted_Code and then Comes_From_Source (N);
3400 -- Indicates whether we want warnings when we delete branches of the
3401 -- if statement based on constant condition analysis. We never want
3402 -- these warnings for expander generated code.
3404 begin
3405 -- Do not consider controlled objects found in an if statement which
3406 -- actually models an if expression because their early finalization
3407 -- will affect the result of the expression.
3409 if not From_Conditional_Expression (N) then
3410 Process_Statements_For_Controlled_Objects (N);
3411 end if;
3413 Adjust_Condition (Condition (N));
3415 -- The following loop deals with constant conditions for the IF. We
3416 -- need a loop because as we eliminate False conditions, we grab the
3417 -- first elsif condition and use it as the primary condition.
3419 while Compile_Time_Known_Value (Condition (N)) loop
3421 -- If condition is True, we can simply rewrite the if statement now
3422 -- by replacing it by the series of then statements.
3424 if Is_True (Expr_Value (Condition (N))) then
3426 -- All the else parts can be killed
3428 Kill_Dead_Code (Elsif_Parts (N), Warn_If_Deleted);
3429 Kill_Dead_Code (Else_Statements (N), Warn_If_Deleted);
3431 Hed := Remove_Head (Then_Statements (N));
3432 Insert_List_After (N, Then_Statements (N));
3433 Rewrite (N, Hed);
3434 return;
3436 -- If condition is False, then we can delete the condition and
3437 -- the Then statements
3439 else
3440 -- We do not delete the condition if constant condition warnings
3441 -- are enabled, since otherwise we end up deleting the desired
3442 -- warning. Of course the backend will get rid of this True/False
3443 -- test anyway, so nothing is lost here.
3445 if not Constant_Condition_Warnings then
3446 Kill_Dead_Code (Condition (N));
3447 end if;
3449 Kill_Dead_Code (Then_Statements (N), Warn_If_Deleted);
3451 -- If there are no elsif statements, then we simply replace the
3452 -- entire if statement by the sequence of else statements.
3454 if No (Elsif_Parts (N)) then
3455 if No (Else_Statements (N))
3456 or else Is_Empty_List (Else_Statements (N))
3457 then
3458 Rewrite (N,
3459 Make_Null_Statement (Sloc (N)));
3460 else
3461 Hed := Remove_Head (Else_Statements (N));
3462 Insert_List_After (N, Else_Statements (N));
3463 Rewrite (N, Hed);
3464 end if;
3466 return;
3468 -- If there are elsif statements, the first of them becomes the
3469 -- if/then section of the rebuilt if statement This is the case
3470 -- where we loop to reprocess this copied condition.
3472 else
3473 Hed := Remove_Head (Elsif_Parts (N));
3474 Insert_Actions (N, Condition_Actions (Hed));
3475 Set_Condition (N, Condition (Hed));
3476 Set_Then_Statements (N, Then_Statements (Hed));
3478 -- Hed might have been captured as the condition determining
3479 -- the current value for an entity. Now it is detached from
3480 -- the tree, so a Current_Value pointer in the condition might
3481 -- need to be updated.
3483 Set_Current_Value_Condition (N);
3485 if Is_Empty_List (Elsif_Parts (N)) then
3486 Set_Elsif_Parts (N, No_List);
3487 end if;
3488 end if;
3489 end if;
3490 end loop;
3492 -- Loop through elsif parts, dealing with constant conditions and
3493 -- possible condition actions that are present.
3495 if Present (Elsif_Parts (N)) then
3496 E := First (Elsif_Parts (N));
3497 while Present (E) loop
3499 -- Do not consider controlled objects found in an if statement
3500 -- which actually models an if expression because their early
3501 -- finalization will affect the result of the expression.
3503 if not From_Conditional_Expression (N) then
3504 Process_Statements_For_Controlled_Objects (E);
3505 end if;
3507 Adjust_Condition (Condition (E));
3509 -- If there are condition actions, then rewrite the if statement
3510 -- as indicated above. We also do the same rewrite for a True or
3511 -- False condition. The further processing of this constant
3512 -- condition is then done by the recursive call to expand the
3513 -- newly created if statement
3515 if Present (Condition_Actions (E))
3516 or else Compile_Time_Known_Value (Condition (E))
3517 then
3518 New_If :=
3519 Make_If_Statement (Sloc (E),
3520 Condition => Condition (E),
3521 Then_Statements => Then_Statements (E),
3522 Elsif_Parts => No_List,
3523 Else_Statements => Else_Statements (N));
3525 -- Elsif parts for new if come from remaining elsif's of parent
3527 while Present (Next (E)) loop
3528 if No (Elsif_Parts (New_If)) then
3529 Set_Elsif_Parts (New_If, New_List);
3530 end if;
3532 Append (Remove_Next (E), Elsif_Parts (New_If));
3533 end loop;
3535 Set_Else_Statements (N, New_List (New_If));
3537 if Present (Condition_Actions (E)) then
3538 Insert_List_Before (New_If, Condition_Actions (E));
3539 end if;
3541 Remove (E);
3543 if Is_Empty_List (Elsif_Parts (N)) then
3544 Set_Elsif_Parts (N, No_List);
3545 end if;
3547 Analyze (New_If);
3549 -- Note this is not an implicit if statement, since it is part
3550 -- of an explicit if statement in the source (or of an implicit
3551 -- if statement that has already been tested). We set the flag
3552 -- after calling Analyze to avoid generating extra warnings
3553 -- specific to pure if statements, however (see
3554 -- Sem_Ch5.Analyze_If_Statement).
3556 Set_Comes_From_Source (New_If, Comes_From_Source (N));
3557 return;
3559 -- No special processing for that elsif part, move to next
3561 else
3562 Next (E);
3563 end if;
3564 end loop;
3565 end if;
3567 -- Some more optimizations applicable if we still have an IF statement
3569 if Nkind (N) /= N_If_Statement then
3570 return;
3571 end if;
3573 -- Another optimization, special cases that can be simplified
3575 -- if expression then
3576 -- return true;
3577 -- else
3578 -- return false;
3579 -- end if;
3581 -- can be changed to:
3583 -- return expression;
3585 -- and
3587 -- if expression then
3588 -- return false;
3589 -- else
3590 -- return true;
3591 -- end if;
3593 -- can be changed to:
3595 -- return not (expression);
3597 -- Only do these optimizations if we are at least at -O1 level and
3598 -- do not do them if control flow optimizations are suppressed.
3600 if Optimization_Level > 0
3601 and then not Opt.Suppress_Control_Flow_Optimizations
3602 then
3603 if Nkind (N) = N_If_Statement
3604 and then No (Elsif_Parts (N))
3605 and then Present (Else_Statements (N))
3606 and then List_Length (Then_Statements (N)) = 1
3607 and then List_Length (Else_Statements (N)) = 1
3608 then
3609 declare
3610 Then_Stm : constant Node_Id := First (Then_Statements (N));
3611 Else_Stm : constant Node_Id := First (Else_Statements (N));
3613 begin
3614 if Nkind (Then_Stm) = N_Simple_Return_Statement
3615 and then
3616 Nkind (Else_Stm) = N_Simple_Return_Statement
3617 then
3618 declare
3619 Then_Expr : constant Node_Id := Expression (Then_Stm);
3620 Else_Expr : constant Node_Id := Expression (Else_Stm);
3622 begin
3623 if Nkind (Then_Expr) = N_Identifier
3624 and then
3625 Nkind (Else_Expr) = N_Identifier
3626 then
3627 if Entity (Then_Expr) = Standard_True
3628 and then Entity (Else_Expr) = Standard_False
3629 then
3630 Rewrite (N,
3631 Make_Simple_Return_Statement (Loc,
3632 Expression => Relocate_Node (Condition (N))));
3633 Analyze (N);
3634 return;
3636 elsif Entity (Then_Expr) = Standard_False
3637 and then Entity (Else_Expr) = Standard_True
3638 then
3639 Rewrite (N,
3640 Make_Simple_Return_Statement (Loc,
3641 Expression =>
3642 Make_Op_Not (Loc,
3643 Right_Opnd =>
3644 Relocate_Node (Condition (N)))));
3645 Analyze (N);
3646 return;
3647 end if;
3648 end if;
3649 end;
3650 end if;
3651 end;
3652 end if;
3653 end if;
3654 end Expand_N_If_Statement;
3656 --------------------------
3657 -- Expand_Iterator_Loop --
3658 --------------------------
3660 procedure Expand_Iterator_Loop (N : Node_Id) is
3661 Isc : constant Node_Id := Iteration_Scheme (N);
3662 I_Spec : constant Node_Id := Iterator_Specification (Isc);
3664 Container : constant Node_Id := Name (I_Spec);
3665 Container_Typ : constant Entity_Id := Base_Type (Etype (Container));
3667 begin
3668 -- Processing for arrays
3670 if Is_Array_Type (Container_Typ) then
3671 pragma Assert (Of_Present (I_Spec));
3672 Expand_Iterator_Loop_Over_Array (N);
3674 elsif Has_Aspect (Container_Typ, Aspect_Iterable) then
3675 if Of_Present (I_Spec) then
3676 Expand_Formal_Container_Element_Loop (N);
3677 else
3678 Expand_Formal_Container_Loop (N);
3679 end if;
3681 -- Processing for containers
3683 else
3684 Expand_Iterator_Loop_Over_Container
3685 (N, Isc, I_Spec, Container, Container_Typ);
3686 end if;
3687 end Expand_Iterator_Loop;
3689 -------------------------------------
3690 -- Expand_Iterator_Loop_Over_Array --
3691 -------------------------------------
3693 procedure Expand_Iterator_Loop_Over_Array (N : Node_Id) is
3694 Isc : constant Node_Id := Iteration_Scheme (N);
3695 I_Spec : constant Node_Id := Iterator_Specification (Isc);
3696 Array_Node : constant Node_Id := Name (I_Spec);
3697 Array_Typ : constant Entity_Id := Base_Type (Etype (Array_Node));
3698 Array_Dim : constant Pos := Number_Dimensions (Array_Typ);
3699 Id : constant Entity_Id := Defining_Identifier (I_Spec);
3700 Loc : constant Source_Ptr := Sloc (Isc);
3701 Stats : constant List_Id := Statements (N);
3702 Core_Loop : Node_Id;
3703 Dim1 : Int;
3704 Ind_Comp : Node_Id;
3705 Iterator : Entity_Id;
3707 -- Start of processing for Expand_Iterator_Loop_Over_Array
3709 begin
3710 -- for Element of Array loop
3712 -- It requires an internally generated cursor to iterate over the array
3714 pragma Assert (Of_Present (I_Spec));
3716 Iterator := Make_Temporary (Loc, 'C');
3718 -- Generate:
3719 -- Element : Component_Type renames Array (Iterator);
3720 -- Iterator is the index value, or a list of index values
3721 -- in the case of a multidimensional array.
3723 Ind_Comp :=
3724 Make_Indexed_Component (Loc,
3725 Prefix => New_Copy_Tree (Array_Node),
3726 Expressions => New_List (New_Occurrence_Of (Iterator, Loc)));
3728 -- Propagate the original node to the copy since the analysis of the
3729 -- following object renaming declaration relies on the original node.
3731 Set_Original_Node (Prefix (Ind_Comp), Original_Node (Array_Node));
3733 Prepend_To (Stats,
3734 Make_Object_Renaming_Declaration (Loc,
3735 Defining_Identifier => Id,
3736 Subtype_Mark =>
3737 New_Occurrence_Of (Component_Type (Array_Typ), Loc),
3738 Name => Ind_Comp));
3740 -- Mark the loop variable as needing debug info, so that expansion
3741 -- of the renaming will result in Materialize_Entity getting set via
3742 -- Debug_Renaming_Declaration. (This setting is needed here because
3743 -- the setting in Freeze_Entity comes after the expansion, which is
3744 -- too late. ???)
3746 Set_Debug_Info_Needed (Id);
3748 -- Generate:
3750 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
3751 -- Element : Component_Type renames Array (Iterator);
3752 -- <original loop statements>
3753 -- end loop;
3755 -- If this is an iteration over a multidimensional array, the
3756 -- innermost loop is over the last dimension in Ada, and over
3757 -- the first dimension in Fortran.
3759 if Convention (Array_Typ) = Convention_Fortran then
3760 Dim1 := 1;
3761 else
3762 Dim1 := Array_Dim;
3763 end if;
3765 Core_Loop :=
3766 Make_Loop_Statement (Sloc (N),
3767 Iteration_Scheme =>
3768 Make_Iteration_Scheme (Loc,
3769 Loop_Parameter_Specification =>
3770 Make_Loop_Parameter_Specification (Loc,
3771 Defining_Identifier => Iterator,
3772 Discrete_Subtype_Definition =>
3773 Make_Attribute_Reference (Loc,
3774 Prefix => New_Copy_Tree (Array_Node),
3775 Attribute_Name => Name_Range,
3776 Expressions => New_List (
3777 Make_Integer_Literal (Loc, Dim1))),
3778 Reverse_Present => Reverse_Present (I_Spec))),
3779 Statements => Stats,
3780 End_Label => Empty);
3782 -- Processing for multidimensional array. The body of each loop is
3783 -- a loop over a previous dimension, going in decreasing order in Ada
3784 -- and in increasing order in Fortran.
3786 if Array_Dim > 1 then
3787 for Dim in 1 .. Array_Dim - 1 loop
3788 if Convention (Array_Typ) = Convention_Fortran then
3789 Dim1 := Dim + 1;
3790 else
3791 Dim1 := Array_Dim - Dim;
3792 end if;
3794 Iterator := Make_Temporary (Loc, 'C');
3796 -- Generate the dimension loops starting from the innermost one
3798 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
3799 -- <core loop>
3800 -- end loop;
3802 Core_Loop :=
3803 Make_Loop_Statement (Sloc (N),
3804 Iteration_Scheme =>
3805 Make_Iteration_Scheme (Loc,
3806 Loop_Parameter_Specification =>
3807 Make_Loop_Parameter_Specification (Loc,
3808 Defining_Identifier => Iterator,
3809 Discrete_Subtype_Definition =>
3810 Make_Attribute_Reference (Loc,
3811 Prefix => New_Copy_Tree (Array_Node),
3812 Attribute_Name => Name_Range,
3813 Expressions => New_List (
3814 Make_Integer_Literal (Loc, Dim1))),
3815 Reverse_Present => Reverse_Present (I_Spec))),
3816 Statements => New_List (Core_Loop),
3817 End_Label => Empty);
3819 -- Update the previously created object renaming declaration with
3820 -- the new iterator, by adding the index of the next loop to the
3821 -- indexed component, in the order that corresponds to the
3822 -- convention.
3824 if Convention (Array_Typ) = Convention_Fortran then
3825 Append_To (Expressions (Ind_Comp),
3826 New_Occurrence_Of (Iterator, Loc));
3827 else
3828 Prepend_To (Expressions (Ind_Comp),
3829 New_Occurrence_Of (Iterator, Loc));
3830 end if;
3831 end loop;
3832 end if;
3834 -- Inherit the loop identifier from the original loop. This ensures that
3835 -- the scope stack is consistent after the rewriting.
3837 if Present (Identifier (N)) then
3838 Set_Identifier (Core_Loop, Relocate_Node (Identifier (N)));
3839 end if;
3841 Rewrite (N, Core_Loop);
3842 Analyze (N);
3843 end Expand_Iterator_Loop_Over_Array;
3845 -----------------------------------------
3846 -- Expand_Iterator_Loop_Over_Container --
3847 -----------------------------------------
3849 -- For a 'for ... in' loop, such as:
3851 -- for Cursor in Iterator_Function (...) loop
3852 -- ...
3853 -- end loop;
3855 -- we generate:
3857 -- Iter : Iterator_Type := Iterator_Function (...);
3858 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
3859 -- while Has_Element (Cursor) loop
3860 -- ...
3862 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3863 -- end loop;
3865 -- For a 'for ... of' loop, such as:
3867 -- for X of Container loop
3868 -- ...
3869 -- end loop;
3871 -- the RM implies the generation of:
3873 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
3874 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
3875 -- while Has_Element (Cursor) loop
3876 -- declare
3877 -- X : Element_Type renames Element (Cursor).Element.all;
3878 -- -- or Constant_Element
3879 -- begin
3880 -- ...
3881 -- end;
3882 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3883 -- end loop;
3885 -- In the general case, we do what the RM says. However, the operations
3886 -- Element and Iter.Next are slow, which is bad inside a loop, because they
3887 -- involve dispatching via interfaces, secondary stack manipulation,
3888 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
3889 -- predefined containers, we use an equivalent but optimized expansion.
3891 -- In the optimized case, we make use of these:
3893 -- procedure Next (Position : in out Cursor); -- instead of Iter.Next
3895 -- function Pseudo_Reference
3896 -- (Container : aliased Vector'Class) return Reference_Control_Type;
3898 -- type Element_Access is access all Element_Type;
3900 -- function Get_Element_Access
3901 -- (Position : Cursor) return not null Element_Access;
3903 -- Next is declared in the visible part of the container packages.
3904 -- The other three are added in the private part. (We're not supposed to
3905 -- pollute the namespace for clients. The compiler has no trouble breaking
3906 -- privacy to call things in the private part of an instance.)
3908 -- Source:
3910 -- for X of My_Vector loop
3911 -- X.Count := X.Count + 1;
3912 -- ...
3913 -- end loop;
3915 -- The compiler will generate:
3917 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector);
3918 -- -- Reversible_Iterator is an interface. Iterate is the
3919 -- -- Default_Iterator aspect of Vector. This increments Lock,
3920 -- -- disallowing tampering with cursors. Unfortunately, it does not
3921 -- -- increment Busy. The result of Iterate is Limited_Controlled;
3922 -- -- finalization will decrement Lock. This is a build-in-place
3923 -- -- dispatching call to Iterate.
3925 -- Cur : Cursor := First (Iter); -- or Last
3926 -- -- Dispatching call via interface.
3928 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
3929 -- -- Pseudo_Reference increments Busy, to detect tampering with
3930 -- -- elements, as required by RM. Also redundantly increment
3931 -- -- Lock. Finalization of Control will decrement both Busy and
3932 -- -- Lock. Pseudo_Reference returns a record containing a pointer to
3933 -- -- My_Vector, used by Finalize.
3934 -- --
3935 -- -- Control is not used below, except to finalize it -- it's purely
3936 -- -- an RAII thing. This is needed because we are eliminating the
3937 -- -- call to Reference within the loop.
3939 -- while Has_Element (Cur) loop
3940 -- declare
3941 -- X : My_Element renames Get_Element_Access (Cur).all;
3942 -- -- Get_Element_Access returns a pointer to the element
3943 -- -- designated by Cur. No dispatching here, and no horsing
3944 -- -- around with access discriminants. This is instead of the
3945 -- -- existing
3946 -- --
3947 -- -- X : My_Element renames Reference (Cur).Element.all;
3948 -- --
3949 -- -- which creates a controlled object.
3950 -- begin
3951 -- -- Any attempt to tamper with My_Vector here in the loop
3952 -- -- will correctly raise Program_Error, because of the
3953 -- -- Control.
3955 -- X.Count := X.Count + 1;
3956 -- ...
3958 -- Next (Cur); -- or Prev
3959 -- -- This is instead of "Cur := Next (Iter, Cur);"
3960 -- end;
3961 -- -- No finalization here
3962 -- end loop;
3963 -- Finalize Iter and Control here, decrementing Lock twice and Busy
3964 -- once.
3966 -- This optimization makes "for ... of" loops over 30 times faster in cases
3967 -- measured.
3969 procedure Expand_Iterator_Loop_Over_Container
3970 (N : Node_Id;
3971 Isc : Node_Id;
3972 I_Spec : Node_Id;
3973 Container : Node_Id;
3974 Container_Typ : Entity_Id)
3976 Id : constant Entity_Id := Defining_Identifier (I_Spec);
3977 Elem_Typ : constant Entity_Id := Etype (Id);
3978 Id_Kind : constant Entity_Kind := Ekind (Id);
3979 Loc : constant Source_Ptr := Sloc (N);
3980 Stats : constant List_Id := Statements (N);
3982 Cursor : Entity_Id;
3983 Decl : Node_Id;
3984 Iter_Type : Entity_Id;
3985 Iterator : Entity_Id;
3986 Name_Init : Name_Id;
3987 Name_Step : Name_Id;
3988 New_Loop : Node_Id;
3990 Fast_Element_Access_Op : Entity_Id := Empty;
3991 Fast_Step_Op : Entity_Id := Empty;
3992 -- Only for optimized version of "for ... of"
3994 Iter_Pack : Entity_Id;
3995 -- The package in which the iterator interface is instantiated. This is
3996 -- typically an instance within the container package.
3998 Pack : Entity_Id;
3999 -- The package in which the container type is declared
4001 begin
4002 -- Determine the advancement and initialization steps for the cursor.
4003 -- Analysis of the expanded loop will verify that the container has a
4004 -- reverse iterator.
4006 if Reverse_Present (I_Spec) then
4007 Name_Init := Name_Last;
4008 Name_Step := Name_Previous;
4009 else
4010 Name_Init := Name_First;
4011 Name_Step := Name_Next;
4012 end if;
4014 -- The type of the iterator is the return type of the Iterate function
4015 -- used. For the "of" form this is the default iterator for the type,
4016 -- otherwise it is the type of the explicit function used in the
4017 -- iterator specification. The most common case will be an Iterate
4018 -- function in the container package.
4020 -- The Iterator type is declared in an instance within the container
4021 -- package itself, for example:
4023 -- package Vector_Iterator_Interfaces is new
4024 -- Ada.Iterator_Interfaces (Cursor, Has_Element);
4026 -- If the container type is a derived type, the cursor type is found in
4027 -- the package of the ultimate ancestor type.
4029 if Is_Derived_Type (Container_Typ) then
4030 Pack := Scope (Root_Type (Container_Typ));
4031 else
4032 Pack := Scope (Container_Typ);
4033 end if;
4035 if Of_Present (I_Spec) then
4036 Handle_Of : declare
4037 Container_Arg : Node_Id;
4039 function Get_Default_Iterator
4040 (T : Entity_Id) return Entity_Id;
4041 -- Return the default iterator for a specific type. If the type is
4042 -- derived, we return the inherited or overridden one if
4043 -- appropriate.
4045 --------------------------
4046 -- Get_Default_Iterator --
4047 --------------------------
4049 function Get_Default_Iterator
4050 (T : Entity_Id) return Entity_Id
4052 Iter : constant Entity_Id :=
4053 Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator));
4054 Prim : Elmt_Id;
4055 Op : Entity_Id;
4057 begin
4058 Container_Arg := New_Copy_Tree (Container);
4060 -- A previous version of GNAT allowed indexing aspects to be
4061 -- redefined on derived container types, while the default
4062 -- iterator was inherited from the parent type. This
4063 -- nonstandard extension is preserved for use by the
4064 -- modeling project under debug flag -gnatd.X.
4066 if Debug_Flag_Dot_XX then
4067 if Base_Type (Etype (Container)) /=
4068 Base_Type (Etype (First_Formal (Iter)))
4069 then
4070 Container_Arg :=
4071 Make_Type_Conversion (Loc,
4072 Subtype_Mark =>
4073 New_Occurrence_Of
4074 (Etype (First_Formal (Iter)), Loc),
4075 Expression => Container_Arg);
4076 end if;
4078 return Iter;
4080 elsif Is_Derived_Type (T) then
4082 -- The default iterator must be a primitive operation of the
4083 -- type, at the same dispatch slot position. The DT position
4084 -- may not be established if type is not frozen yet.
4086 Prim := First_Elmt (Primitive_Operations (T));
4087 while Present (Prim) loop
4088 Op := Node (Prim);
4090 if Alias (Op) = Iter
4091 or else
4092 (Chars (Op) = Chars (Iter)
4093 and then Present (DTC_Entity (Op))
4094 and then DT_Position (Op) = DT_Position (Iter))
4095 then
4096 return Op;
4097 end if;
4099 Next_Elmt (Prim);
4100 end loop;
4102 -- If we didn't find it, then our parent type is not
4103 -- iterable, so we return the Default_Iterator aspect of
4104 -- this type.
4106 return Iter;
4108 -- Otherwise not a derived type
4110 else
4111 return Iter;
4112 end if;
4113 end Get_Default_Iterator;
4115 -- Local variables
4117 Default_Iter : Entity_Id;
4118 Ent : Entity_Id;
4120 Reference_Control_Type : Entity_Id := Empty;
4121 Pseudo_Reference : Entity_Id := Empty;
4123 -- Start of processing for Handle_Of
4125 begin
4126 if Is_Class_Wide_Type (Container_Typ) then
4127 Default_Iter :=
4128 Get_Default_Iterator (Etype (Base_Type (Container_Typ)));
4129 else
4130 Default_Iter := Get_Default_Iterator (Etype (Container));
4131 end if;
4133 Cursor := Make_Temporary (Loc, 'C');
4135 -- For a container element iterator, the iterator type is obtained
4136 -- from the corresponding aspect, whose return type is descended
4137 -- from the corresponding interface type in some instance of
4138 -- Ada.Iterator_Interfaces. The actuals of that instantiation
4139 -- are Cursor and Has_Element.
4141 Iter_Type := Etype (Default_Iter);
4143 -- The iterator type, which is a class-wide type, may itself be
4144 -- derived locally, so the desired instantiation is the scope of
4145 -- the root type of the iterator type.
4147 Iter_Pack := Scope (Root_Type (Etype (Iter_Type)));
4149 -- Find declarations needed for "for ... of" optimization
4151 Ent := First_Entity (Pack);
4152 while Present (Ent) loop
4153 if Chars (Ent) = Name_Get_Element_Access then
4154 Fast_Element_Access_Op := Ent;
4156 elsif Chars (Ent) = Name_Step
4157 and then Ekind (Ent) = E_Procedure
4158 then
4159 Fast_Step_Op := Ent;
4161 elsif Chars (Ent) = Name_Reference_Control_Type then
4162 Reference_Control_Type := Ent;
4164 elsif Chars (Ent) = Name_Pseudo_Reference then
4165 Pseudo_Reference := Ent;
4166 end if;
4168 Next_Entity (Ent);
4169 end loop;
4171 if Present (Reference_Control_Type)
4172 and then Present (Pseudo_Reference)
4173 then
4174 Insert_Action (N,
4175 Make_Object_Declaration (Loc,
4176 Defining_Identifier => Make_Temporary (Loc, 'D'),
4177 Object_Definition =>
4178 New_Occurrence_Of (Reference_Control_Type, Loc),
4179 Expression =>
4180 Make_Function_Call (Loc,
4181 Name =>
4182 New_Occurrence_Of (Pseudo_Reference, Loc),
4183 Parameter_Associations =>
4184 New_List (New_Copy_Tree (Container_Arg)))));
4185 end if;
4187 -- Rewrite domain of iteration as a call to the default iterator
4188 -- for the container type. The formal may be an access parameter
4189 -- in which case we must build a reference to the container.
4191 declare
4192 Arg : Node_Id;
4193 begin
4194 if Is_Access_Type (Etype (First_Entity (Default_Iter))) then
4195 Arg :=
4196 Make_Attribute_Reference (Loc,
4197 Prefix => Container_Arg,
4198 Attribute_Name => Name_Unrestricted_Access);
4199 else
4200 Arg := Container_Arg;
4201 end if;
4203 Rewrite (Name (I_Spec),
4204 Make_Function_Call (Loc,
4205 Name =>
4206 New_Occurrence_Of (Default_Iter, Loc),
4207 Parameter_Associations => New_List (Arg)));
4208 end;
4210 Analyze_And_Resolve (Name (I_Spec));
4212 -- Find cursor type in proper iterator package, which is an
4213 -- instantiation of Iterator_Interfaces.
4215 Ent := First_Entity (Iter_Pack);
4216 while Present (Ent) loop
4217 if Chars (Ent) = Name_Cursor then
4218 Set_Etype (Cursor, Etype (Ent));
4219 exit;
4220 end if;
4222 Next_Entity (Ent);
4223 end loop;
4225 if Present (Fast_Element_Access_Op) then
4226 Decl :=
4227 Make_Object_Renaming_Declaration (Loc,
4228 Defining_Identifier => Id,
4229 Subtype_Mark =>
4230 New_Occurrence_Of (Elem_Typ, Loc),
4231 Name =>
4232 Make_Explicit_Dereference (Loc,
4233 Prefix =>
4234 Make_Function_Call (Loc,
4235 Name =>
4236 New_Occurrence_Of (Fast_Element_Access_Op, Loc),
4237 Parameter_Associations =>
4238 New_List (New_Occurrence_Of (Cursor, Loc)))));
4240 else
4241 Decl :=
4242 Make_Object_Renaming_Declaration (Loc,
4243 Defining_Identifier => Id,
4244 Subtype_Mark =>
4245 New_Occurrence_Of (Elem_Typ, Loc),
4246 Name =>
4247 Make_Indexed_Component (Loc,
4248 Prefix => Relocate_Node (Container_Arg),
4249 Expressions =>
4250 New_List (New_Occurrence_Of (Cursor, Loc))));
4251 end if;
4253 -- The defining identifier in the iterator is user-visible and
4254 -- must be visible in the debugger.
4256 Set_Debug_Info_Needed (Id);
4258 -- If the container does not have a variable indexing aspect,
4259 -- the element is a constant in the loop. The container itself
4260 -- may be constant, in which case the element is a constant as
4261 -- well. The container has been rewritten as a call to Iterate,
4262 -- so examine original node.
4264 if No (Find_Value_Of_Aspect
4265 (Container_Typ, Aspect_Variable_Indexing))
4266 or else not Is_Variable (Original_Node (Container))
4267 then
4268 Set_Ekind (Id, E_Constant);
4269 end if;
4271 Prepend_To (Stats, Decl);
4272 end Handle_Of;
4274 -- X in Iterate (S) : type of iterator is type of explicitly given
4275 -- Iterate function, and the loop variable is the cursor. It will be
4276 -- assigned in the loop and must be a variable.
4278 else
4279 Iter_Type := Etype (Name (I_Spec));
4281 -- The iterator type, which is a class-wide type, may itself be
4282 -- derived locally, so the desired instantiation is the scope of
4283 -- the root type of the iterator type, as in the "of" case.
4285 Iter_Pack := Scope (Root_Type (Etype (Iter_Type)));
4286 Cursor := Id;
4287 end if;
4289 Iterator := Make_Temporary (Loc, 'I');
4291 -- For both iterator forms, add a call to the step operation to advance
4292 -- the cursor. Generate:
4294 -- Cursor := Iterator.Next (Cursor);
4296 -- or else
4298 -- Cursor := Next (Cursor);
4300 if Present (Fast_Element_Access_Op) and then Present (Fast_Step_Op) then
4301 declare
4302 Curs_Name : constant Node_Id := New_Occurrence_Of (Cursor, Loc);
4303 Step_Call : Node_Id;
4305 begin
4306 Step_Call :=
4307 Make_Procedure_Call_Statement (Loc,
4308 Name =>
4309 New_Occurrence_Of (Fast_Step_Op, Loc),
4310 Parameter_Associations => New_List (Curs_Name));
4312 Append_To (Stats, Step_Call);
4313 Set_Assignment_OK (Curs_Name);
4314 end;
4316 else
4317 declare
4318 Rhs : Node_Id;
4320 begin
4321 Rhs :=
4322 Make_Function_Call (Loc,
4323 Name =>
4324 Make_Selected_Component (Loc,
4325 Prefix => New_Occurrence_Of (Iterator, Loc),
4326 Selector_Name => Make_Identifier (Loc, Name_Step)),
4327 Parameter_Associations => New_List (
4328 New_Occurrence_Of (Cursor, Loc)));
4330 Append_To (Stats,
4331 Make_Assignment_Statement (Loc,
4332 Name => New_Occurrence_Of (Cursor, Loc),
4333 Expression => Rhs));
4334 Set_Assignment_OK (Name (Last (Stats)));
4335 end;
4336 end if;
4338 -- Generate:
4339 -- while Has_Element (Cursor) loop
4340 -- <Stats>
4341 -- end loop;
4343 -- Has_Element is the second actual in the iterator package
4345 New_Loop :=
4346 Make_Loop_Statement (Loc,
4347 Iteration_Scheme =>
4348 Make_Iteration_Scheme (Loc,
4349 Condition =>
4350 Make_Function_Call (Loc,
4351 Name =>
4352 New_Occurrence_Of
4353 (Next_Entity (First_Entity (Iter_Pack)), Loc),
4354 Parameter_Associations => New_List (
4355 New_Occurrence_Of (Cursor, Loc)))),
4357 Statements => Stats,
4358 End_Label => Empty);
4360 -- If present, preserve identifier of loop, which can be used in an exit
4361 -- statement in the body.
4363 if Present (Identifier (N)) then
4364 Set_Identifier (New_Loop, Relocate_Node (Identifier (N)));
4365 end if;
4367 -- Create the declarations for Iterator and cursor and insert them
4368 -- before the source loop. Given that the domain of iteration is already
4369 -- an entity, the iterator is just a renaming of that entity. Possible
4370 -- optimization ???
4372 Insert_Action (N,
4373 Make_Object_Renaming_Declaration (Loc,
4374 Defining_Identifier => Iterator,
4375 Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc),
4376 Name => Relocate_Node (Name (I_Spec))));
4378 -- Create declaration for cursor
4380 declare
4381 Cursor_Decl : constant Node_Id :=
4382 Make_Object_Declaration (Loc,
4383 Defining_Identifier => Cursor,
4384 Object_Definition =>
4385 New_Occurrence_Of (Etype (Cursor), Loc),
4386 Expression =>
4387 Make_Selected_Component (Loc,
4388 Prefix =>
4389 New_Occurrence_Of (Iterator, Loc),
4390 Selector_Name =>
4391 Make_Identifier (Loc, Name_Init)));
4393 begin
4394 -- The cursor is only modified in expanded code, so it appears
4395 -- as unassigned to the warning machinery. We must suppress this
4396 -- spurious warning explicitly. The cursor's kind is that of the
4397 -- original loop parameter (it is a constant if the domain of
4398 -- iteration is constant).
4400 Set_Warnings_Off (Cursor);
4401 Set_Assignment_OK (Cursor_Decl);
4403 Insert_Action (N, Cursor_Decl);
4404 Set_Ekind (Cursor, Id_Kind);
4405 end;
4407 -- If the range of iteration is given by a function call that returns
4408 -- a container, the finalization actions have been saved in the
4409 -- Condition_Actions of the iterator. Insert them now at the head of
4410 -- the loop.
4412 if Present (Condition_Actions (Isc)) then
4413 Insert_List_Before (N, Condition_Actions (Isc));
4414 end if;
4416 Rewrite (N, New_Loop);
4417 Analyze (N);
4418 end Expand_Iterator_Loop_Over_Container;
4420 -----------------------------
4421 -- Expand_N_Loop_Statement --
4422 -----------------------------
4424 -- 1. Remove null loop entirely
4425 -- 2. Deal with while condition for C/Fortran boolean
4426 -- 3. Deal with loops with a non-standard enumeration type range
4427 -- 4. Deal with while loops where Condition_Actions is set
4428 -- 5. Deal with loops over predicated subtypes
4429 -- 6. Deal with loops with iterators over arrays and containers
4430 -- 7. Insert polling call if required
4432 procedure Expand_N_Loop_Statement (N : Node_Id) is
4433 Loc : constant Source_Ptr := Sloc (N);
4434 Scheme : constant Node_Id := Iteration_Scheme (N);
4435 Stmt : Node_Id;
4437 begin
4438 -- Delete null loop
4440 if Is_Null_Loop (N) then
4441 Rewrite (N, Make_Null_Statement (Loc));
4442 return;
4443 end if;
4445 -- Deal with condition for C/Fortran Boolean
4447 if Present (Scheme) then
4448 Adjust_Condition (Condition (Scheme));
4449 end if;
4451 -- Generate polling call
4453 if Is_Non_Empty_List (Statements (N)) then
4454 Generate_Poll_Call (First (Statements (N)));
4455 end if;
4457 -- Nothing more to do for plain loop with no iteration scheme
4459 if No (Scheme) then
4460 null;
4462 -- Case of for loop (Loop_Parameter_Specification present)
4464 -- Note: we do not have to worry about validity checking of the for loop
4465 -- range bounds here, since they were frozen with constant declarations
4466 -- and it is during that process that the validity checking is done.
4468 elsif Present (Loop_Parameter_Specification (Scheme)) then
4469 declare
4470 LPS : constant Node_Id :=
4471 Loop_Parameter_Specification (Scheme);
4472 Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
4473 Ltype : constant Entity_Id := Etype (Loop_Id);
4474 Btype : constant Entity_Id := Base_Type (Ltype);
4475 Expr : Node_Id;
4476 Decls : List_Id;
4477 New_Id : Entity_Id;
4479 begin
4480 -- Deal with loop over predicates
4482 if Is_Discrete_Type (Ltype)
4483 and then Present (Predicate_Function (Ltype))
4484 then
4485 Expand_Predicated_Loop (N);
4487 -- Handle the case where we have a for loop with the range type
4488 -- being an enumeration type with non-standard representation.
4489 -- In this case we expand:
4491 -- for x in [reverse] a .. b loop
4492 -- ...
4493 -- end loop;
4495 -- to
4497 -- for xP in [reverse] integer
4498 -- range etype'Pos (a) .. etype'Pos (b)
4499 -- loop
4500 -- declare
4501 -- x : constant etype := Pos_To_Rep (xP);
4502 -- begin
4503 -- ...
4504 -- end;
4505 -- end loop;
4507 elsif Is_Enumeration_Type (Btype)
4508 and then Present (Enum_Pos_To_Rep (Btype))
4509 then
4510 New_Id :=
4511 Make_Defining_Identifier (Loc,
4512 Chars => New_External_Name (Chars (Loop_Id), 'P'));
4514 -- If the type has a contiguous representation, successive
4515 -- values can be generated as offsets from the first literal.
4517 if Has_Contiguous_Rep (Btype) then
4518 Expr :=
4519 Unchecked_Convert_To (Btype,
4520 Make_Op_Add (Loc,
4521 Left_Opnd =>
4522 Make_Integer_Literal (Loc,
4523 Enumeration_Rep (First_Literal (Btype))),
4524 Right_Opnd => New_Occurrence_Of (New_Id, Loc)));
4525 else
4526 -- Use the constructed array Enum_Pos_To_Rep
4528 Expr :=
4529 Make_Indexed_Component (Loc,
4530 Prefix =>
4531 New_Occurrence_Of (Enum_Pos_To_Rep (Btype), Loc),
4532 Expressions =>
4533 New_List (New_Occurrence_Of (New_Id, Loc)));
4534 end if;
4536 -- Build declaration for loop identifier
4538 Decls :=
4539 New_List (
4540 Make_Object_Declaration (Loc,
4541 Defining_Identifier => Loop_Id,
4542 Constant_Present => True,
4543 Object_Definition => New_Occurrence_Of (Ltype, Loc),
4544 Expression => Expr));
4546 Rewrite (N,
4547 Make_Loop_Statement (Loc,
4548 Identifier => Identifier (N),
4550 Iteration_Scheme =>
4551 Make_Iteration_Scheme (Loc,
4552 Loop_Parameter_Specification =>
4553 Make_Loop_Parameter_Specification (Loc,
4554 Defining_Identifier => New_Id,
4555 Reverse_Present => Reverse_Present (LPS),
4557 Discrete_Subtype_Definition =>
4558 Make_Subtype_Indication (Loc,
4560 Subtype_Mark =>
4561 New_Occurrence_Of (Standard_Natural, Loc),
4563 Constraint =>
4564 Make_Range_Constraint (Loc,
4565 Range_Expression =>
4566 Make_Range (Loc,
4568 Low_Bound =>
4569 Make_Attribute_Reference (Loc,
4570 Prefix =>
4571 New_Occurrence_Of (Btype, Loc),
4573 Attribute_Name => Name_Pos,
4575 Expressions => New_List (
4576 Relocate_Node
4577 (Type_Low_Bound (Ltype)))),
4579 High_Bound =>
4580 Make_Attribute_Reference (Loc,
4581 Prefix =>
4582 New_Occurrence_Of (Btype, Loc),
4584 Attribute_Name => Name_Pos,
4586 Expressions => New_List (
4587 Relocate_Node
4588 (Type_High_Bound
4589 (Ltype))))))))),
4591 Statements => New_List (
4592 Make_Block_Statement (Loc,
4593 Declarations => Decls,
4594 Handled_Statement_Sequence =>
4595 Make_Handled_Sequence_Of_Statements (Loc,
4596 Statements => Statements (N)))),
4598 End_Label => End_Label (N)));
4600 -- The loop parameter's entity must be removed from the loop
4601 -- scope's entity list and rendered invisible, since it will
4602 -- now be located in the new block scope. Any other entities
4603 -- already associated with the loop scope, such as the loop
4604 -- parameter's subtype, will remain there.
4606 -- In an element loop, the loop will contain a declaration for
4607 -- a cursor variable; otherwise the loop id is the first entity
4608 -- in the scope constructed for the loop.
4610 if Comes_From_Source (Loop_Id) then
4611 pragma Assert (First_Entity (Scope (Loop_Id)) = Loop_Id);
4612 null;
4613 end if;
4615 Set_First_Entity (Scope (Loop_Id), Next_Entity (Loop_Id));
4616 Remove_Homonym (Loop_Id);
4618 if Last_Entity (Scope (Loop_Id)) = Loop_Id then
4619 Set_Last_Entity (Scope (Loop_Id), Empty);
4620 end if;
4622 Analyze (N);
4624 -- Nothing to do with other cases of for loops
4626 else
4627 null;
4628 end if;
4629 end;
4631 -- Second case, if we have a while loop with Condition_Actions set, then
4632 -- we change it into a plain loop:
4634 -- while C loop
4635 -- ...
4636 -- end loop;
4638 -- changed to:
4640 -- loop
4641 -- <<condition actions>>
4642 -- exit when not C;
4643 -- ...
4644 -- end loop
4646 elsif Present (Scheme)
4647 and then Present (Condition_Actions (Scheme))
4648 and then Present (Condition (Scheme))
4649 then
4650 declare
4651 ES : Node_Id;
4653 begin
4654 ES :=
4655 Make_Exit_Statement (Sloc (Condition (Scheme)),
4656 Condition =>
4657 Make_Op_Not (Sloc (Condition (Scheme)),
4658 Right_Opnd => Condition (Scheme)));
4660 Prepend (ES, Statements (N));
4661 Insert_List_Before (ES, Condition_Actions (Scheme));
4663 -- This is not an implicit loop, since it is generated in response
4664 -- to the loop statement being processed. If this is itself
4665 -- implicit, the restriction has already been checked. If not,
4666 -- it is an explicit loop.
4668 Rewrite (N,
4669 Make_Loop_Statement (Sloc (N),
4670 Identifier => Identifier (N),
4671 Statements => Statements (N),
4672 End_Label => End_Label (N)));
4674 Analyze (N);
4675 end;
4677 -- Here to deal with iterator case
4679 elsif Present (Scheme)
4680 and then Present (Iterator_Specification (Scheme))
4681 then
4682 Expand_Iterator_Loop (N);
4684 -- An iterator loop may generate renaming declarations for elements
4685 -- that require debug information. This is the case in particular
4686 -- with element iterators, where debug information must be generated
4687 -- for the temporary that holds the element value. These temporaries
4688 -- are created within a transient block whose local declarations are
4689 -- transferred to the loop, which now has nontrivial local objects.
4691 if Nkind (N) = N_Loop_Statement
4692 and then Present (Identifier (N))
4693 then
4694 Qualify_Entity_Names (N);
4695 end if;
4696 end if;
4698 -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
4699 -- is transformed into a conditional block where the original loop is
4700 -- the sole statement. Inspect the statements of the nested loop for
4701 -- controlled objects.
4703 Stmt := N;
4705 if Subject_To_Loop_Entry_Attributes (Stmt) then
4706 Stmt := Find_Loop_In_Conditional_Block (Stmt);
4707 end if;
4709 Process_Statements_For_Controlled_Objects (Stmt);
4710 end Expand_N_Loop_Statement;
4712 ----------------------------
4713 -- Expand_Predicated_Loop --
4714 ----------------------------
4716 -- Note: the expander can handle generation of loops over predicated
4717 -- subtypes for both the dynamic and static cases. Depending on what
4718 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
4719 -- mode, the semantic analyzer may disallow one or both forms.
4721 procedure Expand_Predicated_Loop (N : Node_Id) is
4722 Loc : constant Source_Ptr := Sloc (N);
4723 Isc : constant Node_Id := Iteration_Scheme (N);
4724 LPS : constant Node_Id := Loop_Parameter_Specification (Isc);
4725 Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
4726 Ltype : constant Entity_Id := Etype (Loop_Id);
4727 Stat : constant List_Id := Static_Discrete_Predicate (Ltype);
4728 Stmts : constant List_Id := Statements (N);
4730 begin
4731 -- Case of iteration over non-static predicate, should not be possible
4732 -- since this is not allowed by the semantics and should have been
4733 -- caught during analysis of the loop statement.
4735 if No (Stat) then
4736 raise Program_Error;
4738 -- If the predicate list is empty, that corresponds to a predicate of
4739 -- False, in which case the loop won't run at all, and we rewrite the
4740 -- entire loop as a null statement.
4742 elsif Is_Empty_List (Stat) then
4743 Rewrite (N, Make_Null_Statement (Loc));
4744 Analyze (N);
4746 -- For expansion over a static predicate we generate the following
4748 -- declare
4749 -- J : Ltype := min-val;
4750 -- begin
4751 -- loop
4752 -- body
4753 -- case J is
4754 -- when endpoint => J := startpoint;
4755 -- when endpoint => J := startpoint;
4756 -- ...
4757 -- when max-val => exit;
4758 -- when others => J := Lval'Succ (J);
4759 -- end case;
4760 -- end loop;
4761 -- end;
4763 -- with min-val replaced by max-val and Succ replaced by Pred if the
4764 -- loop parameter specification carries a Reverse indicator.
4766 -- To make this a little clearer, let's take a specific example:
4768 -- type Int is range 1 .. 10;
4769 -- subtype StaticP is Int with
4770 -- predicate => StaticP in 3 | 10 | 5 .. 7;
4771 -- ...
4772 -- for L in StaticP loop
4773 -- Put_Line ("static:" & J'Img);
4774 -- end loop;
4776 -- In this case, the loop is transformed into
4778 -- begin
4779 -- J : L := 3;
4780 -- loop
4781 -- body
4782 -- case J is
4783 -- when 3 => J := 5;
4784 -- when 7 => J := 10;
4785 -- when 10 => exit;
4786 -- when others => J := L'Succ (J);
4787 -- end case;
4788 -- end loop;
4789 -- end;
4791 -- In addition, if the loop specification is given by a subtype
4792 -- indication that constrains a predicated type, the bounds of
4793 -- iteration are given by those of the subtype indication.
4795 else
4796 Static_Predicate : declare
4797 S : Node_Id;
4798 D : Node_Id;
4799 P : Node_Id;
4800 Alts : List_Id;
4801 Cstm : Node_Id;
4803 -- If the domain is an itype, note the bounds of its range.
4805 L_Hi : Node_Id := Empty;
4806 L_Lo : Node_Id := Empty;
4808 function Lo_Val (N : Node_Id) return Node_Id;
4809 -- Given static expression or static range, returns an identifier
4810 -- whose value is the low bound of the expression value or range.
4812 function Hi_Val (N : Node_Id) return Node_Id;
4813 -- Given static expression or static range, returns an identifier
4814 -- whose value is the high bound of the expression value or range.
4816 ------------
4817 -- Hi_Val --
4818 ------------
4820 function Hi_Val (N : Node_Id) return Node_Id is
4821 begin
4822 if Is_OK_Static_Expression (N) then
4823 return New_Copy (N);
4824 else
4825 pragma Assert (Nkind (N) = N_Range);
4826 return New_Copy (High_Bound (N));
4827 end if;
4828 end Hi_Val;
4830 ------------
4831 -- Lo_Val --
4832 ------------
4834 function Lo_Val (N : Node_Id) return Node_Id is
4835 begin
4836 if Is_OK_Static_Expression (N) then
4837 return New_Copy (N);
4838 else
4839 pragma Assert (Nkind (N) = N_Range);
4840 return New_Copy (Low_Bound (N));
4841 end if;
4842 end Lo_Val;
4844 -- Start of processing for Static_Predicate
4846 begin
4847 -- Convert loop identifier to normal variable and reanalyze it so
4848 -- that this conversion works. We have to use the same defining
4849 -- identifier, since there may be references in the loop body.
4851 Set_Analyzed (Loop_Id, False);
4852 Set_Ekind (Loop_Id, E_Variable);
4854 -- In most loops the loop variable is assigned in various
4855 -- alternatives in the body. However, in the rare case when
4856 -- the range specifies a single element, the loop variable
4857 -- may trigger a spurious warning that is could be constant.
4858 -- This warning might as well be suppressed.
4860 Set_Warnings_Off (Loop_Id);
4862 if Is_Itype (Ltype) then
4863 L_Hi := High_Bound (Scalar_Range (Ltype));
4864 L_Lo := Low_Bound (Scalar_Range (Ltype));
4865 end if;
4867 -- Loop to create branches of case statement
4869 Alts := New_List;
4871 if Reverse_Present (LPS) then
4873 -- Initial value is largest value in predicate.
4875 if Is_Itype (Ltype) then
4876 D :=
4877 Make_Object_Declaration (Loc,
4878 Defining_Identifier => Loop_Id,
4879 Object_Definition => New_Occurrence_Of (Ltype, Loc),
4880 Expression => L_Hi);
4882 else
4883 D :=
4884 Make_Object_Declaration (Loc,
4885 Defining_Identifier => Loop_Id,
4886 Object_Definition => New_Occurrence_Of (Ltype, Loc),
4887 Expression => Hi_Val (Last (Stat)));
4888 end if;
4890 P := Last (Stat);
4891 while Present (P) loop
4892 if No (Prev (P)) then
4893 S := Make_Exit_Statement (Loc);
4894 else
4895 S :=
4896 Make_Assignment_Statement (Loc,
4897 Name => New_Occurrence_Of (Loop_Id, Loc),
4898 Expression => Hi_Val (Prev (P)));
4899 Set_Suppress_Assignment_Checks (S);
4900 end if;
4902 Append_To (Alts,
4903 Make_Case_Statement_Alternative (Loc,
4904 Statements => New_List (S),
4905 Discrete_Choices => New_List (Lo_Val (P))));
4907 Prev (P);
4908 end loop;
4910 if Is_Itype (Ltype)
4911 and then Is_OK_Static_Expression (L_Lo)
4912 and then
4913 Expr_Value (L_Lo) /= Expr_Value (Lo_Val (First (Stat)))
4914 then
4915 Append_To (Alts,
4916 Make_Case_Statement_Alternative (Loc,
4917 Statements => New_List (Make_Exit_Statement (Loc)),
4918 Discrete_Choices => New_List (L_Lo)));
4919 end if;
4921 else
4922 -- Initial value is smallest value in predicate
4924 if Is_Itype (Ltype) then
4925 D :=
4926 Make_Object_Declaration (Loc,
4927 Defining_Identifier => Loop_Id,
4928 Object_Definition => New_Occurrence_Of (Ltype, Loc),
4929 Expression => L_Lo);
4930 else
4931 D :=
4932 Make_Object_Declaration (Loc,
4933 Defining_Identifier => Loop_Id,
4934 Object_Definition => New_Occurrence_Of (Ltype, Loc),
4935 Expression => Lo_Val (First (Stat)));
4936 end if;
4938 P := First (Stat);
4939 while Present (P) loop
4940 if No (Next (P)) then
4941 S := Make_Exit_Statement (Loc);
4942 else
4943 S :=
4944 Make_Assignment_Statement (Loc,
4945 Name => New_Occurrence_Of (Loop_Id, Loc),
4946 Expression => Lo_Val (Next (P)));
4947 Set_Suppress_Assignment_Checks (S);
4948 end if;
4950 Append_To (Alts,
4951 Make_Case_Statement_Alternative (Loc,
4952 Statements => New_List (S),
4953 Discrete_Choices => New_List (Hi_Val (P))));
4955 Next (P);
4956 end loop;
4958 if Is_Itype (Ltype)
4959 and then Is_OK_Static_Expression (L_Hi)
4960 and then
4961 Expr_Value (L_Hi) /= Expr_Value (Lo_Val (Last (Stat)))
4962 then
4963 Append_To (Alts,
4964 Make_Case_Statement_Alternative (Loc,
4965 Statements => New_List (Make_Exit_Statement (Loc)),
4966 Discrete_Choices => New_List (L_Hi)));
4967 end if;
4968 end if;
4970 -- Add others choice
4972 declare
4973 Name_Next : Name_Id;
4975 begin
4976 if Reverse_Present (LPS) then
4977 Name_Next := Name_Pred;
4978 else
4979 Name_Next := Name_Succ;
4980 end if;
4982 S :=
4983 Make_Assignment_Statement (Loc,
4984 Name => New_Occurrence_Of (Loop_Id, Loc),
4985 Expression =>
4986 Make_Attribute_Reference (Loc,
4987 Prefix => New_Occurrence_Of (Ltype, Loc),
4988 Attribute_Name => Name_Next,
4989 Expressions => New_List (
4990 New_Occurrence_Of (Loop_Id, Loc))));
4991 Set_Suppress_Assignment_Checks (S);
4992 end;
4994 Append_To (Alts,
4995 Make_Case_Statement_Alternative (Loc,
4996 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4997 Statements => New_List (S)));
4999 -- Construct case statement and append to body statements
5001 Cstm :=
5002 Make_Case_Statement (Loc,
5003 Expression => New_Occurrence_Of (Loop_Id, Loc),
5004 Alternatives => Alts);
5005 Append_To (Stmts, Cstm);
5007 -- Rewrite the loop
5009 Set_Suppress_Assignment_Checks (D);
5011 Rewrite (N,
5012 Make_Block_Statement (Loc,
5013 Declarations => New_List (D),
5014 Handled_Statement_Sequence =>
5015 Make_Handled_Sequence_Of_Statements (Loc,
5016 Statements => New_List (
5017 Make_Loop_Statement (Loc,
5018 Statements => Stmts,
5019 End_Label => Empty)))));
5021 Analyze (N);
5022 end Static_Predicate;
5023 end if;
5024 end Expand_Predicated_Loop;
5026 ------------------------------
5027 -- Make_Tag_Ctrl_Assignment --
5028 ------------------------------
5030 function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is
5031 Asn : constant Node_Id := Relocate_Node (N);
5032 L : constant Node_Id := Name (N);
5033 Loc : constant Source_Ptr := Sloc (N);
5034 Res : constant List_Id := New_List;
5035 T : constant Entity_Id := Underlying_Type (Etype (L));
5037 Comp_Asn : constant Boolean := Is_Fully_Repped_Tagged_Type (T);
5038 Ctrl_Act : constant Boolean := Needs_Finalization (T)
5039 and then not No_Ctrl_Actions (N);
5040 Save_Tag : constant Boolean := Is_Tagged_Type (T)
5041 and then not Comp_Asn
5042 and then not No_Ctrl_Actions (N)
5043 and then Tagged_Type_Expansion;
5044 Adj_Call : Node_Id;
5045 Fin_Call : Node_Id;
5046 Tag_Id : Entity_Id;
5048 begin
5049 -- Finalize the target of the assignment when controlled
5051 -- We have two exceptions here:
5053 -- 1. If we are in an init proc since it is an initialization more
5054 -- than an assignment.
5056 -- 2. If the left-hand side is a temporary that was not initialized
5057 -- (or the parent part of a temporary since it is the case in
5058 -- extension aggregates). Such a temporary does not come from
5059 -- source. We must examine the original node for the prefix, because
5060 -- it may be a component of an entry formal, in which case it has
5061 -- been rewritten and does not appear to come from source either.
5063 -- Case of init proc
5065 if not Ctrl_Act then
5066 null;
5068 -- The left-hand side is an uninitialized temporary object
5070 elsif Nkind (L) = N_Type_Conversion
5071 and then Is_Entity_Name (Expression (L))
5072 and then Nkind (Parent (Entity (Expression (L)))) =
5073 N_Object_Declaration
5074 and then No_Initialization (Parent (Entity (Expression (L))))
5075 then
5076 null;
5078 else
5079 Fin_Call :=
5080 Make_Final_Call
5081 (Obj_Ref => Duplicate_Subexpr_No_Checks (L),
5082 Typ => Etype (L));
5084 if Present (Fin_Call) then
5085 Append_To (Res, Fin_Call);
5086 end if;
5087 end if;
5089 -- Save the Tag in a local variable Tag_Id
5091 if Save_Tag then
5092 Tag_Id := Make_Temporary (Loc, 'A');
5094 Append_To (Res,
5095 Make_Object_Declaration (Loc,
5096 Defining_Identifier => Tag_Id,
5097 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
5098 Expression =>
5099 Make_Selected_Component (Loc,
5100 Prefix => Duplicate_Subexpr_No_Checks (L),
5101 Selector_Name =>
5102 New_Occurrence_Of (First_Tag_Component (T), Loc))));
5104 -- Otherwise Tag_Id is not used
5106 else
5107 Tag_Id := Empty;
5108 end if;
5110 -- If the tagged type has a full rep clause, expand the assignment into
5111 -- component-wise assignments. Mark the node as unanalyzed in order to
5112 -- generate the proper code and propagate this scenario by setting a
5113 -- flag to avoid infinite recursion.
5115 if Comp_Asn then
5116 Set_Analyzed (Asn, False);
5117 Set_Componentwise_Assignment (Asn, True);
5118 end if;
5120 Append_To (Res, Asn);
5122 -- Restore the tag
5124 if Save_Tag then
5125 Append_To (Res,
5126 Make_Assignment_Statement (Loc,
5127 Name =>
5128 Make_Selected_Component (Loc,
5129 Prefix => Duplicate_Subexpr_No_Checks (L),
5130 Selector_Name =>
5131 New_Occurrence_Of (First_Tag_Component (T), Loc)),
5132 Expression => New_Occurrence_Of (Tag_Id, Loc)));
5133 end if;
5135 -- Adjust the target after the assignment when controlled (not in the
5136 -- init proc since it is an initialization more than an assignment).
5138 if Ctrl_Act then
5139 Adj_Call :=
5140 Make_Adjust_Call
5141 (Obj_Ref => Duplicate_Subexpr_Move_Checks (L),
5142 Typ => Etype (L));
5144 if Present (Adj_Call) then
5145 Append_To (Res, Adj_Call);
5146 end if;
5147 end if;
5149 return Res;
5151 exception
5153 -- Could use comment here ???
5155 when RE_Not_Available =>
5156 return Empty_List;
5157 end Make_Tag_Ctrl_Assignment;
5159 end Exp_Ch5;