1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Accessibility
; use Accessibility
;
27 with Aspects
; use Aspects
;
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Debug
; use Debug
;
31 with Einfo
; use Einfo
;
32 with Einfo
.Entities
; use Einfo
.Entities
;
33 with Einfo
.Utils
; use Einfo
.Utils
;
34 with Elists
; use Elists
;
35 with Exp_Aggr
; use Exp_Aggr
;
36 with Exp_Ch6
; use Exp_Ch6
;
37 with Exp_Ch7
; use Exp_Ch7
;
38 with Exp_Ch11
; use Exp_Ch11
;
39 with Exp_Dbug
; use Exp_Dbug
;
40 with Exp_Pakd
; use Exp_Pakd
;
41 with Exp_Tss
; use Exp_Tss
;
42 with Exp_Util
; use Exp_Util
;
43 with Inline
; use Inline
;
44 with Namet
; use Namet
;
45 with Nlists
; use Nlists
;
46 with Nmake
; use Nmake
;
48 with Restrict
; use Restrict
;
49 with Rident
; use Rident
;
50 with Rtsfind
; use Rtsfind
;
51 with Sinfo
; use Sinfo
;
52 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
53 with Sinfo
.Utils
; use Sinfo
.Utils
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Ch3
; use Sem_Ch3
;
57 with Sem_Ch8
; use Sem_Ch8
;
58 with Sem_Ch13
; use Sem_Ch13
;
59 with Sem_Eval
; use Sem_Eval
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Util
; use Sem_Util
;
62 use Sem_Util
.Storage_Model_Support
;
63 with Snames
; use Snames
;
64 with Stand
; use Stand
;
65 with Stringt
; use Stringt
;
66 with Tbuild
; use Tbuild
;
67 with Ttypes
; use Ttypes
;
68 with Uintp
; use Uintp
;
69 with Validsw
; use Validsw
;
70 with Warnsw
; use Warnsw
;
72 package body Exp_Ch5
is
74 procedure Build_Formal_Container_Iteration
76 Container
: Entity_Id
;
79 Advance
: out Node_Id
;
80 New_Loop
: out Node_Id
);
81 -- Utility to create declarations and loop statement for both forms
82 -- of formal container iterators.
84 function Convert_To_Iterable_Type
85 (Container
: Entity_Id
;
86 Loc
: Source_Ptr
) return Node_Id
;
87 -- Returns New_Occurrence_Of (Container), possibly converted to an ancestor
88 -- type, if the type of Container inherited the Iterable aspect from that
91 function Change_Of_Representation
(N
: Node_Id
) return Boolean;
92 -- Determine if the right-hand side of assignment N is a type conversion
93 -- which requires a change of representation. Called only for the array
96 procedure Expand_Assign_Array
(N
: Node_Id
; Rhs
: Node_Id
);
97 -- N is an assignment which assigns an array value. This routine process
98 -- the various special cases and checks required for such assignments,
99 -- including change of representation. Rhs is normally simply the right-
100 -- hand side of the assignment, except that if the right-hand side is a
101 -- type conversion or a qualified expression, then the RHS is the actual
102 -- expression inside any such type conversions or qualifications.
104 function Expand_Assign_Array_Loop
111 Rev
: Boolean) return Node_Id
;
112 -- N is an assignment statement which assigns an array value. This routine
113 -- expands the assignment into a loop (or nested loops for the case of a
114 -- multi-dimensional array) to do the assignment component by component.
115 -- Larray and Rarray are the entities of the actual arrays on the left-hand
116 -- and right-hand sides. L_Type and R_Type are the types of these arrays
117 -- (which may not be the same, due to either sliding, or to a change of
118 -- representation case). Ndim is the number of dimensions and the parameter
119 -- Rev indicates if the loops run normally (Rev = False), or reversed
120 -- (Rev = True). The value returned is the constructed loop statement.
121 -- Auxiliary declarations are inserted before node N using the standard
122 -- Insert_Actions mechanism.
124 function Expand_Assign_Array_Bitfield
130 Rev
: Boolean) return Node_Id
;
131 -- Alternative to Expand_Assign_Array_Loop for packed bitfields. Generates
132 -- a call to System.Bitfields.Copy_Bitfield, which is more efficient than
133 -- copying component-by-component.
135 function Expand_Assign_Array_Bitfield_Fast
138 Rarray
: Entity_Id
) return Node_Id
;
139 -- Alternative to Expand_Assign_Array_Bitfield. Generates a call to
140 -- System.Bitfields.Fast_Copy_Bitfield, which is more efficient than
141 -- Copy_Bitfield, but only works in restricted situations.
143 function Expand_Assign_Array_Loop_Or_Bitfield
150 Rev
: Boolean) return Node_Id
;
151 -- Calls either Expand_Assign_Array_Loop, Expand_Assign_Array_Bitfield, or
152 -- Expand_Assign_Array_Bitfield_Fast as appropriate.
154 procedure Expand_Assign_Record
(N
: Node_Id
);
155 -- N is an assignment of an untagged record value. This routine handles
156 -- the case where the assignment must be made component by component,
157 -- either because the target is not byte aligned, or there is a change
158 -- of representation, or when we have a tagged type with a representation
159 -- clause (this last case is required because holes in the tagged type
160 -- might be filled with components from child types).
162 procedure Expand_Assign_With_Target_Names
(N
: Node_Id
);
163 -- (AI12-0125): N is an assignment statement whose RHS contains occurrences
164 -- of @ that designate the value of the LHS of the assignment. If the LHS
165 -- is side-effect-free the target names can be replaced with a copy of the
166 -- LHS; otherwise the semantics of the assignment is described in terms of
167 -- a procedure with an in-out parameter, and expanded as such.
169 procedure Expand_Formal_Container_Loop
(N
: Node_Id
);
170 -- Use the primitives specified in an Iterable aspect to expand a loop
171 -- over a so-called formal container, primarily for SPARK usage.
173 procedure Expand_Formal_Container_Element_Loop
(N
: Node_Id
);
174 -- Same, for an iterator of the form " For E of C". In this case the
175 -- iterator provides the name of the element, and the cursor is generated
178 procedure Expand_Iterator_Loop
(N
: Node_Id
);
179 -- Expand loop over arrays and containers that uses the form "for X of C"
180 -- with an optional subtype mark, or "for Y in C".
182 procedure Expand_Iterator_Loop_Over_Container
186 Container_Typ
: Entity_Id
);
187 -- Expand loop over containers that uses the form "for X of C" with an
188 -- optional subtype mark, or "for Y in C". I_Spec is the iterator
189 -- specification and Container is either the Container (for OF) or the
190 -- iterator (for IN).
192 procedure Expand_Predicated_Loop
(N
: Node_Id
);
193 -- Expand for loop over predicated subtype
195 function Make_Tag_Ctrl_Assignment
(N
: Node_Id
) return List_Id
;
196 -- Generate the necessary code for controlled and tagged assignment, that
197 -- is to say, finalization of the target before, adjustment of the target
198 -- after and save and restore of the tag and finalization pointers which
199 -- are not 'part of the value' and must not be changed upon assignment. N
200 -- is the original Assignment node.
202 --------------------------------------
203 -- Build_Formal_Container_Iteration --
204 --------------------------------------
206 procedure Build_Formal_Container_Iteration
208 Container
: Entity_Id
;
211 Advance
: out Node_Id
;
212 New_Loop
: out Node_Id
)
214 Loc
: constant Source_Ptr
:= Sloc
(N
);
215 Stats
: constant List_Id
:= Statements
(N
);
216 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
218 Has_Element_Op
: constant Entity_Id
:=
219 Get_Iterable_Type_Primitive
(Typ
, Name_Has_Element
);
221 First_Op
: Entity_Id
;
225 -- Use the proper set of primitives depending on the direction of
226 -- iteration. The legality of a reverse iteration has been checked
229 if Reverse_Present
(Iterator_Specification
(Iteration_Scheme
(N
))) then
230 First_Op
:= Get_Iterable_Type_Primitive
(Typ
, Name_Last
);
231 Next_Op
:= Get_Iterable_Type_Primitive
(Typ
, Name_Previous
);
234 First_Op
:= Get_Iterable_Type_Primitive
(Typ
, Name_First
);
235 Next_Op
:= Get_Iterable_Type_Primitive
(Typ
, Name_Next
);
238 -- Declaration for Cursor
241 Make_Object_Declaration
(Loc
,
242 Defining_Identifier
=> Cursor
,
243 Object_Definition
=> New_Occurrence_Of
(Etype
(First_Op
), Loc
),
245 Make_Function_Call
(Loc
,
246 Name
=> New_Occurrence_Of
(First_Op
, Loc
),
247 Parameter_Associations
=> New_List
(
248 Convert_To_Iterable_Type
(Container
, Loc
))));
250 -- Statement that advances (in the right direction) cursor in loop
253 Make_Assignment_Statement
(Loc
,
254 Name
=> New_Occurrence_Of
(Cursor
, Loc
),
256 Make_Function_Call
(Loc
,
257 Name
=> New_Occurrence_Of
(Next_Op
, Loc
),
258 Parameter_Associations
=> New_List
(
259 Convert_To_Iterable_Type
(Container
, Loc
),
260 New_Occurrence_Of
(Cursor
, Loc
))));
262 -- Iterator is rewritten as a while_loop
265 Make_Loop_Statement
(Loc
,
267 Make_Iteration_Scheme
(Loc
,
269 Make_Function_Call
(Loc
,
270 Name
=> New_Occurrence_Of
(Has_Element_Op
, Loc
),
271 Parameter_Associations
=> New_List
(
272 Convert_To_Iterable_Type
(Container
, Loc
),
273 New_Occurrence_Of
(Cursor
, Loc
)))),
277 -- If the contruct has a specified loop name, preserve it in the new
278 -- loop, for possible use in exit statements.
280 if Present
(Identifier
(N
))
281 and then Comes_From_Source
(Identifier
(N
))
283 Set_Identifier
(New_Loop
, Identifier
(N
));
285 end Build_Formal_Container_Iteration
;
287 ------------------------------
288 -- Change_Of_Representation --
289 ------------------------------
291 function Change_Of_Representation
(N
: Node_Id
) return Boolean is
292 Rhs
: constant Node_Id
:= Expression
(N
);
295 Nkind
(Rhs
) = N_Type_Conversion
296 and then not Has_Compatible_Representation
297 (Target_Typ
=> Etype
(Rhs
),
298 Operand_Typ
=> Etype
(Expression
(Rhs
)));
299 end Change_Of_Representation
;
301 ------------------------------
302 -- Convert_To_Iterable_Type --
303 ------------------------------
305 function Convert_To_Iterable_Type
306 (Container
: Entity_Id
;
307 Loc
: Source_Ptr
) return Node_Id
309 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
310 Aspect
: constant Node_Id
:= Find_Aspect
(Typ
, Aspect_Iterable
);
314 Result
:= New_Occurrence_Of
(Container
, Loc
);
316 if Entity
(Aspect
) /= Typ
then
318 Make_Type_Conversion
(Loc
,
319 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Aspect
), Loc
),
320 Expression
=> Result
);
324 end Convert_To_Iterable_Type
;
326 -------------------------
327 -- Expand_Assign_Array --
328 -------------------------
330 -- There are two issues here. First, do we let Gigi do a block move, or
331 -- do we expand out into a loop? Second, we need to set the two flags
332 -- Forwards_OK and Backwards_OK which show whether the block move (or
333 -- corresponding loops) can be legitimately done in a forwards (low to
334 -- high) or backwards (high to low) manner.
336 procedure Expand_Assign_Array
(N
: Node_Id
; Rhs
: Node_Id
) is
337 Loc
: constant Source_Ptr
:= Sloc
(N
);
339 Lhs
: constant Node_Id
:= Name
(N
);
341 Act_Lhs
: constant Node_Id
:= Get_Referenced_Object
(Lhs
);
342 Act_Rhs
: Node_Id
:= Get_Referenced_Object
(Rhs
);
344 L_Type
: constant Entity_Id
:=
345 Underlying_Type
(Get_Actual_Subtype
(Act_Lhs
));
346 R_Type
: Entity_Id
:=
347 Underlying_Type
(Get_Actual_Subtype
(Act_Rhs
));
349 L_Slice
: constant Boolean := Nkind
(Act_Lhs
) = N_Slice
;
350 R_Slice
: constant Boolean := Nkind
(Act_Rhs
) = N_Slice
;
352 Crep
: constant Boolean := Change_Of_Representation
(N
);
356 or else Is_Bit_Packed_Array
(L_Type
) = Is_Bit_Packed_Array
(R_Type
));
361 Ndim
: constant Pos
:= Number_Dimensions
(L_Type
);
363 Loop_Required
: Boolean := False;
364 -- This switch is set to True if the array move must be done using
365 -- an explicit front end generated loop.
367 procedure Apply_Dereference
(Arg
: Node_Id
);
368 -- If the argument is an access to an array, and the assignment is
369 -- converted into a procedure call, apply explicit dereference.
371 function Has_Address_Clause
(Exp
: Node_Id
) return Boolean;
372 -- Test if Exp is a reference to an array whose declaration has
373 -- an address clause, or it is a slice of such an array.
375 function Is_Formal_Array
(Exp
: Node_Id
) return Boolean;
376 -- Test if Exp is a reference to an array which is either a formal
377 -- parameter or a slice of a formal parameter. These are the cases
378 -- where hidden aliasing can occur.
380 function Is_Non_Local_Array
(Exp
: Node_Id
) return Boolean;
381 -- Determine if Exp is a reference to an array variable which is other
382 -- than an object defined in the current scope, or a component or a
383 -- slice of such an object. Such objects can be aliased to parameters
384 -- (unlike local array references).
386 -----------------------
387 -- Apply_Dereference --
388 -----------------------
390 procedure Apply_Dereference
(Arg
: Node_Id
) is
391 Typ
: constant Entity_Id
:= Etype
(Arg
);
393 if Is_Access_Type
(Typ
) then
394 Rewrite
(Arg
, Make_Explicit_Dereference
(Loc
,
395 Prefix
=> Relocate_Node
(Arg
)));
396 Analyze_And_Resolve
(Arg
, Designated_Type
(Typ
));
398 end Apply_Dereference
;
400 ------------------------
401 -- Has_Address_Clause --
402 ------------------------
404 function Has_Address_Clause
(Exp
: Node_Id
) return Boolean is
407 (Is_Entity_Name
(Exp
) and then
408 Present
(Address_Clause
(Entity
(Exp
))))
410 (Nkind
(Exp
) = N_Slice
and then Has_Address_Clause
(Prefix
(Exp
)));
411 end Has_Address_Clause
;
413 ---------------------
414 -- Is_Formal_Array --
415 ---------------------
417 function Is_Formal_Array
(Exp
: Node_Id
) return Boolean is
420 (Is_Entity_Name
(Exp
) and then Is_Formal
(Entity
(Exp
)))
422 (Nkind
(Exp
) = N_Slice
and then Is_Formal_Array
(Prefix
(Exp
)));
425 ------------------------
426 -- Is_Non_Local_Array --
427 ------------------------
429 function Is_Non_Local_Array
(Exp
: Node_Id
) return Boolean is
432 when N_Indexed_Component
433 | N_Selected_Component
436 return Is_Non_Local_Array
(Prefix
(Exp
));
440 not (Is_Entity_Name
(Exp
)
441 and then Scope
(Entity
(Exp
)) = Current_Scope
);
443 end Is_Non_Local_Array
;
445 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
447 Lhs_Formal
: constant Boolean := Is_Formal_Array
(Act_Lhs
);
448 Rhs_Formal
: constant Boolean := Is_Formal_Array
(Act_Rhs
);
450 Lhs_Non_Local_Var
: constant Boolean := Is_Non_Local_Array
(Act_Lhs
);
451 Rhs_Non_Local_Var
: constant Boolean := Is_Non_Local_Array
(Act_Rhs
);
453 -- Start of processing for Expand_Assign_Array
456 -- Deal with length check. Note that the length check is done with
457 -- respect to the right-hand side as given, not a possible underlying
458 -- renamed object, since this would generate incorrect extra checks.
460 Apply_Length_Check_On_Assignment
(Rhs
, L_Type
, Lhs
);
462 -- We start by assuming that the move can be done in either direction,
463 -- i.e. that the two sides are completely disjoint.
465 Set_Forwards_OK
(N
, True);
466 Set_Backwards_OK
(N
, True);
468 -- Normally it is only the slice case that can lead to overlap, and
469 -- explicit checks for slices are made below. But there is one case
470 -- where the slice can be implicit and invisible to us: when we have a
471 -- one dimensional array, and either both operands are parameters, or
472 -- one is a parameter (which can be a slice passed by reference) and the
473 -- other is a non-local variable. In this case the parameter could be a
474 -- slice that overlaps with the other operand.
476 -- However, if the array subtype is a constrained first subtype in the
477 -- parameter case, then we don't have to worry about overlap, since
478 -- slice assignments aren't possible (other than for a slice denoting
481 -- Note: No overlap is possible if there is a change of representation,
482 -- so we can exclude this case.
487 ((Lhs_Formal
and Rhs_Formal
)
489 (Lhs_Formal
and Rhs_Non_Local_Var
)
491 (Rhs_Formal
and Lhs_Non_Local_Var
))
493 (not Is_Constrained
(Etype
(Lhs
))
494 or else not Is_First_Subtype
(Etype
(Lhs
)))
496 Set_Forwards_OK
(N
, False);
497 Set_Backwards_OK
(N
, False);
499 -- Note: the bit-packed case is not worrisome here, since if we have
500 -- a slice passed as a parameter, it is always aligned on a byte
501 -- boundary, and if there are no explicit slices, the assignment
502 -- can be performed directly.
505 -- If either operand has an address clause clear Backwards_OK and
506 -- Forwards_OK, since we cannot tell if the operands overlap. We
507 -- exclude this treatment when Rhs is an aggregate, since we know
508 -- that overlap can't occur.
510 if (Has_Address_Clause
(Lhs
) and then Nkind
(Rhs
) /= N_Aggregate
)
511 or else Has_Address_Clause
(Rhs
)
513 Set_Forwards_OK
(N
, False);
514 Set_Backwards_OK
(N
, False);
517 -- We certainly must use a loop for change of representation and also
518 -- we use the operand of the conversion on the right-hand side as the
519 -- effective right-hand side (the component types must match in this
523 Act_Rhs
:= Get_Referenced_Object
(Rhs
);
524 R_Type
:= Get_Actual_Subtype
(Act_Rhs
);
525 Loop_Required
:= True;
527 -- We require a loop if either side is possibly bit aligned
529 elsif Possible_Bit_Aligned_Component
(Lhs
)
531 Possible_Bit_Aligned_Component
(Rhs
)
533 Loop_Required
:= True;
535 -- Arrays with controlled components are expanded into a loop to force
536 -- calls to Adjust at the component level.
538 elsif Has_Controlled_Component
(L_Type
) then
539 Loop_Required
:= True;
541 -- If object is full access, we cannot tolerate a loop
543 elsif Is_Full_Access_Object
(Act_Lhs
)
545 Is_Full_Access_Object
(Act_Rhs
)
549 -- Loop is required if we have atomic components since we have to
550 -- be sure to do any accesses on an element by element basis.
552 elsif Has_Atomic_Components
(L_Type
)
553 or else Has_Atomic_Components
(R_Type
)
554 or else Is_Full_Access
(Component_Type
(L_Type
))
555 or else Is_Full_Access
(Component_Type
(R_Type
))
557 Loop_Required
:= True;
559 -- Case where no slice is involved
561 elsif not L_Slice
and not R_Slice
then
563 -- The following code deals with the case of unconstrained bit packed
564 -- arrays. The problem is that the template for such arrays contains
565 -- the bounds of the actual source level array, but the copy of an
566 -- entire array requires the bounds of the underlying array. It would
567 -- be nice if the back end could take care of this, but right now it
568 -- does not know how, so if we have such a type, then we expand out
569 -- into a loop, which is inefficient but works correctly. If we don't
570 -- do this, we get the wrong length computed for the array to be
571 -- moved. The two cases we need to worry about are:
573 -- Explicit dereference of an unconstrained packed array type as in
574 -- the following example:
577 -- type BITS is array(INTEGER range <>) of BOOLEAN;
578 -- pragma PACK(BITS);
579 -- type A is access BITS;
582 -- P1 := new BITS (1 .. 65_535);
583 -- P2 := new BITS (1 .. 65_535);
587 -- A formal parameter reference with an unconstrained bit array type
588 -- is the other case we need to worry about (here we assume the same
589 -- BITS type declared above):
591 -- procedure Write_All (File : out BITS; Contents : BITS);
593 -- File.Storage := Contents;
596 -- We expand to a loop in either of these two cases
598 -- Question for future thought. Another potentially more efficient
599 -- approach would be to create the actual subtype, and then do an
600 -- unchecked conversion to this actual subtype ???
602 Check_Unconstrained_Bit_Packed_Array
: declare
604 function Is_UBPA_Reference
(Opnd
: Node_Id
) return Boolean;
605 -- Function to perform required test for the first case, above
606 -- (dereference of an unconstrained bit packed array).
608 -----------------------
609 -- Is_UBPA_Reference --
610 -----------------------
612 function Is_UBPA_Reference
(Opnd
: Node_Id
) return Boolean is
613 Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Opnd
));
615 Des_Type
: Entity_Id
;
618 if Present
(Packed_Array_Impl_Type
(Typ
))
619 and then Is_Array_Type
(Packed_Array_Impl_Type
(Typ
))
620 and then not Is_Constrained
(Packed_Array_Impl_Type
(Typ
))
624 elsif Nkind
(Opnd
) = N_Explicit_Dereference
then
625 P_Type
:= Underlying_Type
(Etype
(Prefix
(Opnd
)));
627 if not Is_Access_Type
(P_Type
) then
631 Des_Type
:= Designated_Type
(P_Type
);
633 Is_Bit_Packed_Array
(Des_Type
)
634 and then not Is_Constrained
(Des_Type
);
640 end Is_UBPA_Reference
;
642 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
645 if Is_UBPA_Reference
(Lhs
)
647 Is_UBPA_Reference
(Rhs
)
649 Loop_Required
:= True;
651 -- Here if we do not have the case of a reference to a bit packed
652 -- unconstrained array case. In this case gigi can most certainly
653 -- handle the assignment if a forwards move is allowed.
655 -- (could it handle the backwards case also???)
657 elsif Forwards_OK
(N
) then
660 end Check_Unconstrained_Bit_Packed_Array
;
662 -- The back end can always handle the assignment if the right side is a
663 -- string literal (note that overlap is definitely impossible in this
664 -- case). If the type is packed, a string literal is always converted
665 -- into an aggregate, except in the case of a null slice, for which no
666 -- aggregate can be written. In that case, rewrite the assignment as a
667 -- null statement, a length check has already been emitted to verify
668 -- that the range of the left-hand side is empty.
670 -- Note that this code is not executed if we have an assignment of a
671 -- string literal to a non-bit aligned component of a record, a case
672 -- which cannot be handled by the backend.
674 elsif Nkind
(Rhs
) = N_String_Literal
then
675 if String_Length
(Strval
(Rhs
)) = 0
676 and then Is_Bit_Packed_Array
(L_Type
)
678 Rewrite
(N
, Make_Null_Statement
(Loc
));
684 -- If either operand is bit packed, then we need a loop, since we can't
685 -- be sure that the slice is byte aligned.
687 elsif Is_Bit_Packed_Array
(L_Type
)
688 or else Is_Bit_Packed_Array
(R_Type
)
690 Loop_Required
:= True;
692 -- If we are not bit-packed, and we have only one slice, then no overlap
693 -- is possible except in the parameter case, so we can let the back end
696 elsif not (L_Slice
and R_Slice
) then
697 if Forwards_OK
(N
) then
702 -- If the right-hand side is a string literal, introduce a temporary for
703 -- it, for use in the generated loop that will follow.
705 if Nkind
(Rhs
) = N_String_Literal
then
707 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Rhs
);
712 Make_Object_Declaration
(Loc
,
713 Defining_Identifier
=> Temp
,
714 Object_Definition
=> New_Occurrence_Of
(L_Type
, Loc
),
715 Expression
=> Relocate_Node
(Rhs
));
717 Insert_Action
(N
, Decl
);
718 Rewrite
(Rhs
, New_Occurrence_Of
(Temp
, Loc
));
719 R_Type
:= Etype
(Temp
);
723 -- Come here to complete the analysis
725 -- Loop_Required: Set to True if we know that a loop is required
726 -- regardless of overlap considerations.
728 -- Forwards_OK: Set to False if we already know that a forwards
729 -- move is not safe, else set to True.
731 -- Backwards_OK: Set to False if we already know that a backwards
732 -- move is not safe, else set to True
734 -- Our task at this stage is to complete the overlap analysis, which can
735 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
736 -- then generating the final code, either by deciding that it is OK
737 -- after all to let Gigi handle it, or by generating appropriate code
741 L_Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(L_Type
));
742 R_Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(R_Type
));
744 Left_Lo
: constant Node_Id
:= Type_Low_Bound
(L_Index_Typ
);
745 Left_Hi
: constant Node_Id
:= Type_High_Bound
(L_Index_Typ
);
746 Right_Lo
: constant Node_Id
:= Type_Low_Bound
(R_Index_Typ
);
747 Right_Hi
: constant Node_Id
:= Type_High_Bound
(R_Index_Typ
);
749 Act_L_Array
: Node_Id
;
750 Act_R_Array
: Node_Id
;
756 Cresult
: Compare_Result
;
759 -- Get the expressions for the arrays. If we are dealing with a
760 -- private type, then convert to the underlying type. We can do
761 -- direct assignments to an array that is a private type, but we
762 -- cannot assign to elements of the array without this extra
763 -- unchecked conversion.
765 -- Note: We propagate Parent to the conversion nodes to generate
766 -- a well-formed subtree.
768 if Nkind
(Act_Lhs
) = N_Slice
then
769 Larray
:= Prefix
(Act_Lhs
);
773 if Is_Private_Type
(Etype
(Larray
)) then
775 Par
: constant Node_Id
:= Parent
(Larray
);
779 (Underlying_Type
(Etype
(Larray
)), Larray
);
780 Set_Parent
(Larray
, Par
);
785 if Nkind
(Act_Rhs
) = N_Slice
then
786 Rarray
:= Prefix
(Act_Rhs
);
790 if Is_Private_Type
(Etype
(Rarray
)) then
792 Par
: constant Node_Id
:= Parent
(Rarray
);
796 (Underlying_Type
(Etype
(Rarray
)), Rarray
);
797 Set_Parent
(Rarray
, Par
);
802 -- If both sides are slices, we must figure out whether it is safe
803 -- to do the move in one direction or the other. It is always safe
804 -- if there is a change of representation since obviously two arrays
805 -- with different representations cannot possibly overlap.
807 if not Crep
and L_Slice
and R_Slice
then
808 Act_L_Array
:= Get_Referenced_Object
(Prefix
(Act_Lhs
));
809 Act_R_Array
:= Get_Referenced_Object
(Prefix
(Act_Rhs
));
811 -- If both left- and right-hand arrays are entity names, and refer
812 -- to different entities, then we know that the move is safe (the
813 -- two storage areas are completely disjoint).
815 if Is_Entity_Name
(Act_L_Array
)
816 and then Is_Entity_Name
(Act_R_Array
)
817 and then Entity
(Act_L_Array
) /= Entity
(Act_R_Array
)
821 -- Otherwise, we assume the worst, which is that the two arrays
822 -- are the same array. There is no need to check if we know that
823 -- is the case, because if we don't know it, we still have to
826 -- Generally if the same array is involved, then we have an
827 -- overlapping case. We will have to really assume the worst (i.e.
828 -- set neither of the OK flags) unless we can determine the lower
829 -- or upper bounds at compile time and compare them.
834 (Left_Lo
, Right_Lo
, Assume_Valid
=> True);
836 if Cresult
= Unknown
then
839 (Left_Hi
, Right_Hi
, Assume_Valid
=> True);
844 Set_Backwards_OK
(N
, False);
847 Set_Forwards_OK
(N
, False);
850 Set_Backwards_OK
(N
, False);
851 Set_Forwards_OK
(N
, False);
856 -- If after that analysis Loop_Required is False, meaning that we
857 -- have not discovered some non-overlap reason for requiring a loop,
858 -- then the outcome depends on the capabilities of the back end.
860 if not Loop_Required
then
861 -- Assume the back end can deal with all cases of overlap by
862 -- falling back to memmove if it cannot use a more efficient
868 -- At this stage we have to generate an explicit loop, and we have
869 -- the following cases:
871 -- Forwards_OK = True
873 -- Rnn : right_index := right_index'First;
874 -- for Lnn in left-index loop
875 -- left (Lnn) := right (Rnn);
876 -- Rnn := right_index'Succ (Rnn);
879 -- Note: the above code MUST be analyzed with checks off, because
880 -- otherwise the Succ could overflow. But in any case this is more
883 -- Forwards_OK = False, Backwards_OK = True
885 -- Rnn : right_index := right_index'Last;
886 -- for Lnn in reverse left-index loop
887 -- left (Lnn) := right (Rnn);
888 -- Rnn := right_index'Pred (Rnn);
891 -- Note: the above code MUST be analyzed with checks off, because
892 -- otherwise the Pred could overflow. But in any case this is more
895 -- Forwards_OK = Backwards_OK = False
897 -- This only happens if we have the same array on each side. It is
898 -- possible to create situations using overlays that violate this,
899 -- but we simply do not promise to get this "right" in this case.
901 -- There are two possible subcases. If the No_Implicit_Conditionals
902 -- restriction is set, then we generate the following code:
905 -- T : constant <operand-type> := rhs;
910 -- If implicit conditionals are permitted, then we generate:
912 -- if Left_Lo <= Right_Lo then
913 -- <code for Forwards_OK = True above>
915 -- <code for Backwards_OK = True above>
918 -- In order to detect possible aliasing, we examine the renamed
919 -- expression when the source or target is a renaming. However,
920 -- the renaming may be intended to capture an address that may be
921 -- affected by subsequent code, and therefore we must recover
922 -- the actual entity for the expansion that follows, not the
923 -- object it renames. In particular, if source or target designate
924 -- a portion of a dynamically allocated object, the pointer to it
925 -- may be reassigned but the renaming preserves the proper location.
927 if Is_Entity_Name
(Rhs
)
929 Nkind
(Parent
(Entity
(Rhs
))) = N_Object_Renaming_Declaration
930 and then Nkind
(Act_Rhs
) = N_Slice
935 if Is_Entity_Name
(Lhs
)
937 Nkind
(Parent
(Entity
(Lhs
))) = N_Object_Renaming_Declaration
938 and then Nkind
(Act_Lhs
) = N_Slice
943 -- Cases where either Forwards_OK or Backwards_OK is true
945 if Forwards_OK
(N
) or else Backwards_OK
(N
) then
946 if Needs_Finalization
(Component_Type
(L_Type
))
947 and then Base_Type
(L_Type
) = Base_Type
(R_Type
)
949 and then not No_Ctrl_Actions
(N
)
950 and then not No_Finalize_Actions
(N
)
953 Proc
: constant Entity_Id
:=
954 TSS
(Base_Type
(L_Type
), TSS_Slice_Assign
);
958 Apply_Dereference
(Larray
);
959 Apply_Dereference
(Rarray
);
960 Actuals
:= New_List
(
961 Duplicate_Subexpr
(Larray
, Name_Req
=> True),
962 Duplicate_Subexpr
(Rarray
, Name_Req
=> True),
963 Duplicate_Subexpr
(Left_Lo
, Name_Req
=> True),
964 Duplicate_Subexpr
(Left_Hi
, Name_Req
=> True),
965 Duplicate_Subexpr
(Right_Lo
, Name_Req
=> True),
966 Duplicate_Subexpr
(Right_Hi
, Name_Req
=> True));
970 Boolean_Literals
(not Forwards_OK
(N
)), Loc
));
973 Make_Procedure_Call_Statement
(Loc
,
974 Name
=> New_Occurrence_Of
(Proc
, Loc
),
975 Parameter_Associations
=> Actuals
));
980 Expand_Assign_Array_Loop_Or_Bitfield
981 (N
, Larray
, Rarray
, L_Type
, R_Type
, Ndim
,
982 Rev
=> not Forwards_OK
(N
)));
985 -- Case of both are false with No_Implicit_Conditionals
987 elsif Restriction_Active
(No_Implicit_Conditionals
) then
989 T
: constant Entity_Id
:=
990 Make_Defining_Identifier
(Loc
, Chars
=> Name_T
);
994 Make_Block_Statement
(Loc
,
995 Declarations
=> New_List
(
996 Make_Object_Declaration
(Loc
,
997 Defining_Identifier
=> T
,
998 Constant_Present
=> True,
1000 New_Occurrence_Of
(Etype
(Rhs
), Loc
),
1001 Expression
=> Relocate_Node
(Rhs
))),
1003 Handled_Statement_Sequence
=>
1004 Make_Handled_Sequence_Of_Statements
(Loc
,
1005 Statements
=> New_List
(
1006 Make_Assignment_Statement
(Loc
,
1007 Name
=> Relocate_Node
(Lhs
),
1008 Expression
=> New_Occurrence_Of
(T
, Loc
))))));
1011 -- Case of both are false with implicit conditionals allowed
1014 -- Before we generate this code, we must ensure that the left and
1015 -- right side array types are defined. They may be itypes, and we
1016 -- cannot let them be defined inside the if, since the first use
1017 -- in the then may not be executed.
1019 Ensure_Defined
(L_Type
, N
);
1020 Ensure_Defined
(R_Type
, N
);
1022 -- We normally compare addresses to find out which way round to
1023 -- do the loop, since this is reliable, and handles the cases of
1024 -- parameters, conversions etc. But we can't do that in the bit
1025 -- packed case, because addresses don't work there.
1027 if not Is_Bit_Packed_Array
(L_Type
) then
1031 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
1032 Make_Attribute_Reference
(Loc
,
1034 Make_Indexed_Component
(Loc
,
1036 Duplicate_Subexpr_Move_Checks
(Larray
, True),
1037 Expressions
=> New_List
(
1038 Make_Attribute_Reference
(Loc
,
1042 Attribute_Name
=> Name_First
))),
1043 Attribute_Name
=> Name_Address
)),
1046 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
1047 Make_Attribute_Reference
(Loc
,
1049 Make_Indexed_Component
(Loc
,
1051 Duplicate_Subexpr_Move_Checks
(Rarray
, True),
1052 Expressions
=> New_List
(
1053 Make_Attribute_Reference
(Loc
,
1057 Attribute_Name
=> Name_First
))),
1058 Attribute_Name
=> Name_Address
)));
1060 -- For the bit packed and VM cases we use the bounds. That's OK,
1061 -- because we don't have to worry about parameters, since they
1062 -- cannot cause overlap. Perhaps we should worry about weird slice
1068 Cleft_Lo
:= New_Copy_Tree
(Left_Lo
);
1069 Cright_Lo
:= New_Copy_Tree
(Right_Lo
);
1071 -- If the types do not match we add an implicit conversion
1072 -- here to ensure proper match
1074 if Etype
(Left_Lo
) /= Etype
(Right_Lo
) then
1076 Unchecked_Convert_To
(Etype
(Left_Lo
), Cright_Lo
);
1079 -- Reset the Analyzed flag, because the bounds of the index
1080 -- type itself may be universal, and must be reanalyzed to
1081 -- acquire the proper type for the back end.
1083 Set_Analyzed
(Cleft_Lo
, False);
1084 Set_Analyzed
(Cright_Lo
, False);
1088 Left_Opnd
=> Cleft_Lo
,
1089 Right_Opnd
=> Cright_Lo
);
1092 if Needs_Finalization
(Component_Type
(L_Type
))
1093 and then Base_Type
(L_Type
) = Base_Type
(R_Type
)
1095 and then not No_Ctrl_Actions
(N
)
1096 and then not No_Finalize_Actions
(N
)
1098 -- Call TSS procedure for array assignment, passing the
1099 -- explicit bounds of right- and left-hand sides.
1102 Proc
: constant Entity_Id
:=
1103 TSS
(Base_Type
(L_Type
), TSS_Slice_Assign
);
1107 Apply_Dereference
(Larray
);
1108 Apply_Dereference
(Rarray
);
1109 Actuals
:= New_List
(
1110 Duplicate_Subexpr
(Larray
, Name_Req
=> True),
1111 Duplicate_Subexpr
(Rarray
, Name_Req
=> True),
1112 Duplicate_Subexpr
(Left_Lo
, Name_Req
=> True),
1113 Duplicate_Subexpr
(Left_Hi
, Name_Req
=> True),
1114 Duplicate_Subexpr
(Right_Lo
, Name_Req
=> True),
1115 Duplicate_Subexpr
(Right_Hi
, Name_Req
=> True));
1119 Right_Opnd
=> Condition
));
1122 Make_Procedure_Call_Statement
(Loc
,
1123 Name
=> New_Occurrence_Of
(Proc
, Loc
),
1124 Parameter_Associations
=> Actuals
));
1129 Make_Implicit_If_Statement
(N
,
1130 Condition
=> Condition
,
1132 Then_Statements
=> New_List
(
1133 Expand_Assign_Array_Loop_Or_Bitfield
1134 (N
, Larray
, Rarray
, L_Type
, R_Type
, Ndim
,
1137 Else_Statements
=> New_List
(
1138 Expand_Assign_Array_Loop_Or_Bitfield
1139 (N
, Larray
, Rarray
, L_Type
, R_Type
, Ndim
,
1144 Analyze
(N
, Suppress
=> All_Checks
);
1148 when RE_Not_Available
=>
1150 end Expand_Assign_Array
;
1152 ------------------------------
1153 -- Expand_Assign_Array_Loop --
1154 ------------------------------
1156 -- The following is an example of the loop generated for the case of a
1157 -- two-dimensional array:
1160 -- R2b : Tm1X1 := 1;
1162 -- for L1b in 1 .. 100 loop
1164 -- R4b : Tm1X2 := 1;
1166 -- for L3b in 1 .. 100 loop
1167 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
1168 -- R4b := Tm1X2'succ(R4b);
1171 -- R2b := Tm1X1'succ(R2b);
1175 -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand
1176 -- side. The declarations of R2b and R4b are inserted before the original
1177 -- assignment statement.
1179 function Expand_Assign_Array_Loop
1186 Rev
: Boolean) return Node_Id
1188 Loc
: constant Source_Ptr
:= Sloc
(N
);
1190 Lnn
: array (1 .. Ndim
) of Entity_Id
;
1191 Rnn
: array (1 .. Ndim
) of Entity_Id
;
1192 -- Entities used as subscripts on left and right sides
1194 L_Index_Type
: array (1 .. Ndim
) of Entity_Id
;
1195 R_Index_Type
: array (1 .. Ndim
) of Entity_Id
;
1196 -- Left and right index types
1203 function Build_Step
(J
: Nat
) return Node_Id
;
1204 -- The increment step for the index of the right-hand side is written
1205 -- as an attribute reference (Succ or Pred). This function returns
1206 -- the corresponding node, which is placed at the end of the loop body.
1212 function Build_Step
(J
: Nat
) return Node_Id
is
1224 Make_Assignment_Statement
(Loc
,
1225 Name
=> New_Occurrence_Of
(Rnn
(J
), Loc
),
1227 Make_Attribute_Reference
(Loc
,
1229 New_Occurrence_Of
(R_Index_Type
(J
), Loc
),
1230 Attribute_Name
=> S_Or_P
,
1231 Expressions
=> New_List
(
1232 New_Occurrence_Of
(Rnn
(J
), Loc
))));
1234 -- Note that on the last iteration of the loop, the index is increased
1235 -- (or decreased) past the corresponding bound. This is consistent with
1236 -- the C semantics of the back-end, where such an off-by-one value on a
1237 -- dead index variable is OK. However, in CodePeer mode this leads to
1238 -- spurious warnings, and thus we place a guard around the attribute
1239 -- reference. For obvious reasons we only do this for CodePeer.
1241 if CodePeer_Mode
then
1243 Make_If_Statement
(Loc
,
1246 Left_Opnd
=> New_Occurrence_Of
(Lnn
(J
), Loc
),
1248 Make_Attribute_Reference
(Loc
,
1249 Prefix
=> New_Occurrence_Of
(L_Index_Type
(J
), Loc
),
1250 Attribute_Name
=> Lim
)),
1251 Then_Statements
=> New_List
(Step
));
1257 -- Start of processing for Expand_Assign_Array_Loop
1261 F_Or_L
:= Name_Last
;
1262 S_Or_P
:= Name_Pred
;
1264 F_Or_L
:= Name_First
;
1265 S_Or_P
:= Name_Succ
;
1268 -- Setup index types and subscript entities
1275 L_Index
:= First_Index
(L_Type
);
1276 R_Index
:= First_Index
(R_Type
);
1278 for J
in 1 .. Ndim
loop
1279 Lnn
(J
) := Make_Temporary
(Loc
, 'L');
1280 Rnn
(J
) := Make_Temporary
(Loc
, 'R');
1282 L_Index_Type
(J
) := Etype
(L_Index
);
1283 R_Index_Type
(J
) := Etype
(R_Index
);
1285 Next_Index
(L_Index
);
1286 Next_Index
(R_Index
);
1290 -- Now construct the assignment statement
1293 ExprL
: constant List_Id
:= New_List
;
1294 ExprR
: constant List_Id
:= New_List
;
1297 for J
in 1 .. Ndim
loop
1298 Append_To
(ExprL
, New_Occurrence_Of
(Lnn
(J
), Loc
));
1299 Append_To
(ExprR
, New_Occurrence_Of
(Rnn
(J
), Loc
));
1303 Make_Assignment_Statement
(Loc
,
1305 Make_Indexed_Component
(Loc
,
1306 Prefix
=> Duplicate_Subexpr
(Larray
, Name_Req
=> True),
1307 Expressions
=> ExprL
),
1309 Make_Indexed_Component
(Loc
,
1310 Prefix
=> Duplicate_Subexpr
(Rarray
, Name_Req
=> True),
1311 Expressions
=> ExprR
));
1313 -- We set assignment OK, since there are some cases, e.g. in object
1314 -- declarations, where we are actually assigning into a constant.
1315 -- If there really is an illegality, it was caught long before now,
1316 -- and was flagged when the original assignment was analyzed.
1318 Set_Assignment_OK
(Name
(Assign
));
1320 -- Propagate the No_{Ctrl,Finalize}_Actions flags to assignments
1322 Set_No_Ctrl_Actions
(Assign
, No_Ctrl_Actions
(N
));
1323 Set_No_Finalize_Actions
(Assign
, No_Finalize_Actions
(N
));
1326 -- Now construct the loop from the inside out, with the last subscript
1327 -- varying most rapidly. Note that Assign is first the raw assignment
1328 -- statement, and then subsequently the loop that wraps it up.
1330 for J
in reverse 1 .. Ndim
loop
1332 Make_Block_Statement
(Loc
,
1333 Declarations
=> New_List
(
1334 Make_Object_Declaration
(Loc
,
1335 Defining_Identifier
=> Rnn
(J
),
1336 Object_Definition
=>
1337 New_Occurrence_Of
(R_Index_Type
(J
), Loc
),
1339 Make_Attribute_Reference
(Loc
,
1340 Prefix
=> New_Occurrence_Of
(R_Index_Type
(J
), Loc
),
1341 Attribute_Name
=> F_Or_L
))),
1343 Handled_Statement_Sequence
=>
1344 Make_Handled_Sequence_Of_Statements
(Loc
,
1345 Statements
=> New_List
(
1346 Make_Implicit_Loop_Statement
(N
,
1348 Make_Iteration_Scheme
(Loc
,
1349 Loop_Parameter_Specification
=>
1350 Make_Loop_Parameter_Specification
(Loc
,
1351 Defining_Identifier
=> Lnn
(J
),
1352 Reverse_Present
=> Rev
,
1353 Discrete_Subtype_Definition
=>
1354 New_Occurrence_Of
(L_Index_Type
(J
), Loc
))),
1356 Statements
=> New_List
(Assign
, Build_Step
(J
))))));
1360 end Expand_Assign_Array_Loop
;
1362 ----------------------------------
1363 -- Expand_Assign_Array_Bitfield --
1364 ----------------------------------
1366 function Expand_Assign_Array_Bitfield
1372 Rev
: Boolean) return Node_Id
1374 pragma Assert
(not Rev
);
1375 -- Reverse copying is not yet supported by Copy_Bitfield.
1377 pragma Assert
(not Change_Of_Representation
(N
));
1378 -- This won't work, for example, to copy a packed array to an unpacked
1381 Loc
: constant Source_Ptr
:= Sloc
(N
);
1383 L_Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(L_Type
));
1384 R_Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(R_Type
));
1385 Left_Lo
: constant Node_Id
:= Type_Low_Bound
(L_Index_Typ
);
1386 Right_Lo
: constant Node_Id
:= Type_Low_Bound
(R_Index_Typ
);
1388 L_Addr
: constant Node_Id
:=
1389 Make_Attribute_Reference
(Loc
,
1391 Make_Indexed_Component
(Loc
,
1393 Duplicate_Subexpr
(Larray
, True),
1394 Expressions
=> New_List
(New_Copy_Tree
(Left_Lo
))),
1395 Attribute_Name
=> Name_Address
);
1397 L_Bit
: constant Node_Id
:=
1398 Make_Attribute_Reference
(Loc
,
1400 Make_Indexed_Component
(Loc
,
1402 Duplicate_Subexpr
(Larray
, True),
1403 Expressions
=> New_List
(New_Copy_Tree
(Left_Lo
))),
1404 Attribute_Name
=> Name_Bit
);
1406 R_Addr
: constant Node_Id
:=
1407 Make_Attribute_Reference
(Loc
,
1409 Make_Indexed_Component
(Loc
,
1411 Duplicate_Subexpr
(Rarray
, True),
1412 Expressions
=> New_List
(New_Copy_Tree
(Right_Lo
))),
1413 Attribute_Name
=> Name_Address
);
1415 R_Bit
: constant Node_Id
:=
1416 Make_Attribute_Reference
(Loc
,
1418 Make_Indexed_Component
(Loc
,
1420 Duplicate_Subexpr
(Rarray
, True),
1421 Expressions
=> New_List
(New_Copy_Tree
(Right_Lo
))),
1422 Attribute_Name
=> Name_Bit
);
1424 -- Compute the Size of the bitfield
1426 -- Note that the length check has already been done, so we can use the
1427 -- size of either L or R; they are equal. We can't use 'Size here,
1428 -- because sometimes bit fields get copied into a temp, and the 'Size
1429 -- ends up being the size of the temp (e.g. an 8-bit temp containing
1430 -- a 4-bit bit field).
1432 Size
: constant Node_Id
:=
1433 Make_Op_Multiply
(Loc
,
1434 Make_Attribute_Reference
(Loc
,
1436 Duplicate_Subexpr
(Name
(N
), True),
1437 Attribute_Name
=> Name_Length
),
1438 Make_Attribute_Reference
(Loc
,
1440 Duplicate_Subexpr
(Name
(N
), True),
1441 Attribute_Name
=> Name_Component_Size
));
1444 return Make_Procedure_Call_Statement
(Loc
,
1445 Name
=> New_Occurrence_Of
(RTE
(RE_Copy_Bitfield
), Loc
),
1446 Parameter_Associations
=> New_List
(
1447 R_Addr
, R_Bit
, L_Addr
, L_Bit
, Size
));
1448 end Expand_Assign_Array_Bitfield
;
1450 ---------------------------------------
1451 -- Expand_Assign_Array_Bitfield_Fast --
1452 ---------------------------------------
1454 function Expand_Assign_Array_Bitfield_Fast
1457 Rarray
: Entity_Id
) return Node_Id
1459 pragma Assert
(not Change_Of_Representation
(N
));
1460 -- This won't work, for example, to copy a packed array to an unpacked
1463 -- For L (A .. B) := R (C .. D), we generate:
1465 -- L := Fast_Copy_Bitfield (R, <offset of R(C)>, L, <offset of L(A)>,
1466 -- L (A .. B)'Length * L'Component_Size);
1468 -- with L and R suitably uncheckedly converted to/from Val_2.
1469 -- The offsets are from the start of L and R.
1471 Loc
: constant Source_Ptr
:= Sloc
(N
);
1473 L_Typ
: constant Entity_Id
:= Etype
(Larray
);
1474 R_Typ
: constant Entity_Id
:= Etype
(Rarray
);
1475 -- The original type of the arrays
1477 L_Val
: constant Node_Id
:=
1478 Unchecked_Convert_To
(RTE
(RE_Val_2
), Larray
);
1479 R_Val
: constant Node_Id
:=
1480 Unchecked_Convert_To
(RTE
(RE_Val_2
), Rarray
);
1481 -- Converted values of left- and right-hand sides
1483 L_Small
: constant Boolean :=
1484 Known_Static_RM_Size
(L_Typ
)
1485 and then RM_Size
(L_Typ
) < Standard_Long_Long_Integer_Size
;
1486 R_Small
: constant Boolean :=
1487 Known_Static_RM_Size
(R_Typ
)
1488 and then RM_Size
(R_Typ
) < Standard_Long_Long_Integer_Size
;
1489 -- Whether the above unchecked conversions need to be padded with zeros
1491 C_Size
: constant Uint
:= Component_Size
(L_Typ
);
1492 pragma Assert
(C_Size
>= 1);
1493 pragma Assert
(C_Size
= Component_Size
(R_Typ
));
1495 Larray_Bounds
: constant Range_Values
:=
1496 Get_Index_Bounds
(First_Index
(L_Typ
));
1497 L_Bounds
: constant Range_Values
:=
1498 (if Nkind
(Name
(N
)) = N_Slice
1499 then Get_Index_Bounds
(Discrete_Range
(Name
(N
)))
1500 else Larray_Bounds
);
1501 -- If the left-hand side is A (First..Last), Larray_Bounds is A'Range,
1502 -- and L_Bounds is First..Last. If it's not a slice, we treat it like
1503 -- a slice starting at A'First.
1505 L_Bit
: constant Node_Id
:=
1506 Make_Integer_Literal
1507 (Loc
, (L_Bounds
.First
- Larray_Bounds
.First
) * C_Size
);
1509 Rarray_Bounds
: constant Range_Values
:=
1510 Get_Index_Bounds
(First_Index
(R_Typ
));
1511 R_Bounds
: constant Range_Values
:=
1512 (if Nkind
(Expression
(N
)) = N_Slice
1513 then Get_Index_Bounds
(Discrete_Range
(Expression
(N
)))
1514 else Rarray_Bounds
);
1516 R_Bit
: constant Node_Id
:=
1517 Make_Integer_Literal
1518 (Loc
, (R_Bounds
.First
- Rarray_Bounds
.First
) * C_Size
);
1520 Size
: constant Node_Id
:=
1521 Make_Op_Multiply
(Loc
,
1522 Make_Attribute_Reference
(Loc
,
1524 Duplicate_Subexpr
(Name
(N
), True),
1525 Attribute_Name
=> Name_Length
),
1526 Make_Attribute_Reference
(Loc
,
1528 Duplicate_Subexpr
(Larray
, True),
1529 Attribute_Name
=> Name_Component_Size
));
1531 L_Arg
, R_Arg
, Call
: Node_Id
;
1534 -- The semantics of unchecked conversion between bit-packed arrays that
1535 -- are implemented as modular types and modular types is precisely that
1536 -- of unchecked conversion between modular types. Therefore, if it needs
1537 -- to be padded with zeros, the padding must be moved to the correct end
1538 -- for memory order because System.Bitfield_Utils works in memory order.
1541 and then (Bytes_Big_Endian
xor Reverse_Storage_Order
(L_Typ
))
1543 L_Arg
:= Make_Op_Shift_Left
(Loc
,
1545 Right_Opnd
=> Make_Integer_Literal
(Loc
,
1546 Standard_Long_Long_Integer_Size
- RM_Size
(L_Typ
)));
1552 and then (Bytes_Big_Endian
xor Reverse_Storage_Order
(R_Typ
))
1554 R_Arg
:= Make_Op_Shift_Left
(Loc
,
1556 Right_Opnd
=> Make_Integer_Literal
(Loc
,
1557 Standard_Long_Long_Integer_Size
- RM_Size
(R_Typ
)));
1562 Call
:= Make_Function_Call
(Loc
,
1563 Name
=> New_Occurrence_Of
(RTE
(RE_Fast_Copy_Bitfield
), Loc
),
1564 Parameter_Associations
=> New_List
(
1565 R_Arg
, R_Bit
, L_Arg
, L_Bit
, Size
));
1567 -- Conversely, the final unchecked conversion must take significant bits
1570 and then (Bytes_Big_Endian
xor Reverse_Storage_Order
(L_Typ
))
1572 Call
:= Make_Op_Shift_Right
(Loc
,
1574 Right_Opnd
=> Make_Integer_Literal
(Loc
,
1575 Standard_Long_Long_Integer_Size
- RM_Size
(L_Typ
)));
1578 return Make_Assignment_Statement
(Loc
,
1579 Name
=> Duplicate_Subexpr
(Larray
, True),
1580 Expression
=> Unchecked_Convert_To
(L_Typ
, Call
));
1581 end Expand_Assign_Array_Bitfield_Fast
;
1583 ------------------------------------------
1584 -- Expand_Assign_Array_Loop_Or_Bitfield --
1585 ------------------------------------------
1587 function Expand_Assign_Array_Loop_Or_Bitfield
1594 Rev
: Boolean) return Node_Id
1597 function Volatile_Or_Independent
1598 (Exp
: Node_Id
; Typ
: Entity_Id
) return Boolean;
1599 -- Exp is an expression of type Typ, or if there is no expression
1600 -- involved, Exp is Empty. True if there are any volatile or independent
1601 -- objects that should disable the optimization. We check the object
1602 -- itself, all subcomponents, and if Exp is a slice of a component or
1603 -- slice, we check the prefix and its type.
1605 -- We disable the optimization when there are relevant volatile or
1606 -- independent objects, because Copy_Bitfield can read and write bits
1607 -- that are not part of the objects being copied.
1609 -----------------------------
1610 -- Volatile_Or_Independent --
1611 -----------------------------
1613 function Volatile_Or_Independent
1614 (Exp
: Node_Id
; Typ
: Entity_Id
) return Boolean
1617 -- Initially, Exp is the left- or right-hand side. In recursive
1618 -- calls, Exp is Empty if we're just checking a component type, and
1619 -- Exp is the prefix if we're checking the prefix of a slice.
1622 and then (Is_Volatile_Object_Ref
(Exp
)
1623 or else Is_Independent_Object
(Exp
))
1628 if Has_Volatile_Components
(Typ
)
1629 or else Has_Independent_Components
(Typ
)
1634 if Is_Array_Type
(Typ
) then
1635 if Volatile_Or_Independent
(Empty
, Component_Type
(Typ
)) then
1639 elsif Is_Record_Type
(Typ
) then
1641 Comp
: Entity_Id
:= First_Component
(Typ
);
1643 while Present
(Comp
) loop
1644 if Volatile_Or_Independent
(Empty
, Comp
) then
1648 Next_Component
(Comp
);
1653 if Nkind
(Exp
) = N_Slice
1654 and then Nkind
(Prefix
(Exp
)) in
1655 N_Selected_Component | N_Indexed_Component | N_Slice
1657 if Volatile_Or_Independent
(Prefix
(Exp
), Etype
(Prefix
(Exp
)))
1664 end Volatile_Or_Independent
;
1666 function Slice_Of_Packed_Component
(L
: Node_Id
) return Boolean is
1667 (Nkind
(L
) = N_Slice
1668 and then Nkind
(Prefix
(L
)) = N_Indexed_Component
1669 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Prefix
(L
)))));
1670 -- L is the left-hand side Name. Returns True if L is a slice of a
1671 -- component of a bit-packed array. The optimization is disabled in
1672 -- that case, because Expand_Assign_Array_Bitfield_Fast cannot
1673 -- currently handle that case correctly.
1675 L
: constant Node_Id
:= Name
(N
);
1676 R
: constant Node_Id
:= Expression
(N
);
1677 -- Left- and right-hand sides of the assignment statement
1679 Slices
: constant Boolean :=
1680 Nkind
(L
) = N_Slice
or else Nkind
(R
) = N_Slice
;
1682 -- Start of processing for Expand_Assign_Array_Loop_Or_Bitfield
1685 -- Determine whether Copy_Bitfield or Fast_Copy_Bitfield is appropriate
1686 -- (will work, and will be more efficient than component-by-component
1687 -- copy). Copy_Bitfield doesn't work for reversed storage orders. It is
1688 -- efficient for slices of bit-packed arrays.
1690 if Is_Bit_Packed_Array
(L_Type
)
1691 and then Is_Bit_Packed_Array
(R_Type
)
1692 and then not Reverse_Storage_Order
(L_Type
)
1693 and then not Reverse_Storage_Order
(R_Type
)
1695 and then not Slice_Of_Packed_Component
(L
)
1696 and then not Volatile_Or_Independent
(L
, L_Type
)
1697 and then not Volatile_Or_Independent
(R
, R_Type
)
1699 -- Here if Copy_Bitfield can work (except for the Rev test below).
1700 -- Determine whether to call Fast_Copy_Bitfield instead. If we
1701 -- are assigning slices, and all the relevant bounds are known at
1702 -- compile time, and the maximum object size is no greater than
1703 -- System.Bitfields.Val_Bits (i.e. Long_Long_Integer'Size / 2), and
1704 -- we don't have enumeration representation clauses, we can use
1705 -- Fast_Copy_Bitfield. The max size test is to ensure that the slices
1706 -- cannot overlap boundaries not supported by Fast_Copy_Bitfield.
1708 pragma Assert
(Known_Component_Size
(Base_Type
(L_Type
)));
1709 pragma Assert
(Known_Component_Size
(Base_Type
(R_Type
)));
1711 -- Note that L_Type and R_Type do not necessarily have the same base
1712 -- type, because of array type conversions. Hence the need to check
1713 -- various properties of both.
1715 if Compile_Time_Known_Bounds
(Base_Type
(L_Type
))
1716 and then Compile_Time_Known_Bounds
(Base_Type
(R_Type
))
1719 Left_Base_Index
: constant Entity_Id
:=
1720 First_Index
(Base_Type
(L_Type
));
1721 Left_Base_Range
: constant Range_Values
:=
1722 Get_Index_Bounds
(Left_Base_Index
);
1724 Right_Base_Index
: constant Entity_Id
:=
1725 First_Index
(Base_Type
(R_Type
));
1726 Right_Base_Range
: constant Range_Values
:=
1727 Get_Index_Bounds
(Right_Base_Index
);
1729 Known_Left_Slice_Low
: constant Boolean :=
1730 (if Nkind
(L
) = N_Slice
1731 then Compile_Time_Known_Value
1732 (Get_Index_Bounds
(Discrete_Range
(L
)).First
));
1733 Known_Right_Slice_Low
: constant Boolean :=
1734 (if Nkind
(R
) = N_Slice
1735 then Compile_Time_Known_Value
1736 (Get_Index_Bounds
(Discrete_Range
(R
)).Last
));
1738 Val_Bits
: constant Pos
:= Standard_Long_Long_Integer_Size
/ 2;
1741 if Left_Base_Range
.Last
- Left_Base_Range
.First
< Val_Bits
1742 and then Right_Base_Range
.Last
- Right_Base_Range
.First
<
1744 and then Known_Esize
(L_Type
)
1745 and then Known_Esize
(R_Type
)
1746 and then Known_Left_Slice_Low
1747 and then Known_Right_Slice_Low
1748 and then Compile_Time_Known_Value
1749 (Get_Index_Bounds
(First_Index
(Etype
(Larray
))).First
)
1750 and then Compile_Time_Known_Value
1751 (Get_Index_Bounds
(First_Index
(Etype
(Rarray
))).First
)
1753 not (Is_Enumeration_Type
(Etype
(Left_Base_Index
))
1754 and then Has_Enumeration_Rep_Clause
1755 (Etype
(Left_Base_Index
)))
1756 and then RTE_Available
(RE_Fast_Copy_Bitfield
)
1758 pragma Assert
(Known_Esize
(L_Type
));
1759 pragma Assert
(Known_Esize
(R_Type
));
1761 return Expand_Assign_Array_Bitfield_Fast
(N
, Larray
, Rarray
);
1766 -- Fast_Copy_Bitfield can work if Rev is True, because the data is
1767 -- passed and returned by copy. Copy_Bitfield cannot.
1769 if not Rev
and then RTE_Available
(RE_Copy_Bitfield
) then
1770 return Expand_Assign_Array_Bitfield
1771 (N
, Larray
, Rarray
, L_Type
, R_Type
, Rev
);
1775 -- Here if we did not return above, with Fast_Copy_Bitfield or
1778 return Expand_Assign_Array_Loop
1779 (N
, Larray
, Rarray
, L_Type
, R_Type
, Ndim
, Rev
);
1780 end Expand_Assign_Array_Loop_Or_Bitfield
;
1782 --------------------------
1783 -- Expand_Assign_Record --
1784 --------------------------
1786 procedure Expand_Assign_Record
(N
: Node_Id
) is
1787 Lhs
: constant Node_Id
:= Name
(N
);
1788 Rhs
: Node_Id
:= Expression
(N
);
1789 L_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Lhs
));
1792 -- If change of representation, then extract the real right-hand side
1793 -- from the type conversion, and proceed with component-wise assignment,
1794 -- since the two types are not the same as far as the back end is
1797 if Change_Of_Representation
(N
) then
1798 Rhs
:= Expression
(Rhs
);
1800 -- If this may be a case of a large bit aligned component, then proceed
1801 -- with component-wise assignment, to avoid possible clobbering of other
1802 -- components sharing bits in the first or last byte of the component to
1805 elsif Possible_Bit_Aligned_Component
(Lhs
)
1807 Possible_Bit_Aligned_Component
(Rhs
)
1811 -- If we have a tagged type that has a complete record representation
1812 -- clause, we must do we must do component-wise assignments, since child
1813 -- types may have used gaps for their components, and we might be
1814 -- dealing with a view conversion.
1816 elsif Is_Fully_Repped_Tagged_Type
(L_Typ
) then
1819 -- If neither condition met, then nothing special to do, the back end
1820 -- can handle assignment of the entire component as a single entity.
1826 -- At this stage we know that we must do a component wise assignment
1829 Loc
: constant Source_Ptr
:= Sloc
(N
);
1830 R_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Rhs
));
1831 Decl
: constant Node_Id
:= Declaration_Node
(R_Typ
);
1835 function Find_Component
1837 Comp
: Entity_Id
) return Entity_Id
;
1838 -- Find the component with the given name in the underlying record
1839 -- declaration for Typ. We need to use the actual entity because the
1840 -- type may be private and resolution by identifier alone would fail.
1842 function Make_Component_List_Assign
1844 U_U
: Boolean := False) return List_Id
;
1845 -- Returns a sequence of statements to assign the components that
1846 -- are referenced in the given component list. The flag U_U is
1847 -- used to force the usage of the inferred value of the variant
1848 -- part expression as the switch for the generated case statement.
1850 function Make_Field_Assign
1852 U_U
: Boolean := False) return Node_Id
;
1853 -- Given C, the entity for a discriminant or component, build an
1854 -- assignment for the corresponding field values. The flag U_U
1855 -- signals the presence of an Unchecked_Union and forces the usage
1856 -- of the inferred discriminant value of C as the right-hand side
1857 -- of the assignment.
1859 function Make_Field_Assigns
(CI
: List_Id
) return List_Id
;
1860 -- Given CI, a component items list, construct series of statements
1861 -- for fieldwise assignment of the corresponding components.
1863 --------------------
1864 -- Find_Component --
1865 --------------------
1867 function Find_Component
1869 Comp
: Entity_Id
) return Entity_Id
1871 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
1875 C
:= First_Entity
(Utyp
);
1876 while Present
(C
) loop
1877 if Chars
(C
) = Chars
(Comp
) then
1880 -- The component may be a renamed discriminant, in
1881 -- which case check against the name of the original
1882 -- discriminant of the parent type.
1884 elsif Is_Derived_Type
(Scope
(Comp
))
1885 and then Ekind
(Comp
) = E_Discriminant
1886 and then Present
(Corresponding_Discriminant
(Comp
))
1888 Chars
(C
) = Chars
(Corresponding_Discriminant
(Comp
))
1896 raise Program_Error
;
1899 --------------------------------
1900 -- Make_Component_List_Assign --
1901 --------------------------------
1903 function Make_Component_List_Assign
1905 U_U
: Boolean := False) return List_Id
1907 CI
: constant List_Id
:= Component_Items
(CL
);
1908 VP
: constant Node_Id
:= Variant_Part
(CL
);
1918 Result
:= Make_Field_Assigns
(CI
);
1920 if Present
(VP
) then
1921 V
:= First_Non_Pragma
(Variants
(VP
));
1923 while Present
(V
) loop
1925 DC
:= First
(Discrete_Choices
(V
));
1926 while Present
(DC
) loop
1927 Append_To
(DCH
, New_Copy_Tree
(DC
));
1932 Make_Case_Statement_Alternative
(Loc
,
1933 Discrete_Choices
=> DCH
,
1935 Make_Component_List_Assign
(Component_List
(V
))));
1936 Next_Non_Pragma
(V
);
1939 -- Try to find a constrained type or a derived type to extract
1940 -- discriminant values from, so that the case statement built
1941 -- below can be folded by Expand_N_Case_Statement.
1943 if U_U
or else Is_Constrained
(Etype
(Rhs
)) then
1945 New_Copy
(Get_Discriminant_Value
(
1948 Discriminant_Constraint
(Etype
(Rhs
))));
1950 elsif Is_Constrained
(Etype
(Expression
(N
))) then
1952 New_Copy
(Get_Discriminant_Value
(
1954 Etype
(Expression
(N
)),
1955 Discriminant_Constraint
(Etype
(Expression
(N
)))));
1957 elsif Is_Derived_Type
(Etype
(Rhs
))
1958 and then Present
(Stored_Constraint
(Etype
(Rhs
)))
1961 New_Copy
(Get_Discriminant_Value
(
1962 Corresponding_Record_Component
(Entity
(Name
(VP
))),
1963 Etype
(Etype
(Rhs
)),
1964 Stored_Constraint
(Etype
(Rhs
))));
1970 if No
(Expr
) or else not Compile_Time_Known_Value
(Expr
) then
1972 Make_Selected_Component
(Loc
,
1973 Prefix
=> Duplicate_Subexpr
(Rhs
),
1975 Make_Identifier
(Loc
, Chars
(Name
(VP
))));
1979 Make_Case_Statement
(Loc
,
1981 Alternatives
=> Alts
));
1985 end Make_Component_List_Assign
;
1987 -----------------------
1988 -- Make_Field_Assign --
1989 -----------------------
1991 function Make_Field_Assign
1993 U_U
: Boolean := False) return Node_Id
2000 -- The discriminant entity to be used in the retrieval below must
2001 -- be one in the corresponding type, given that the assignment may
2002 -- be between derived and parent types.
2004 if Is_Derived_Type
(Etype
(Rhs
)) then
2005 Disc
:= Find_Component
(R_Typ
, C
);
2010 -- In the case of an Unchecked_Union, use the discriminant
2011 -- constraint value as on the right-hand side of the assignment.
2015 New_Copy
(Get_Discriminant_Value
(C
,
2017 Discriminant_Constraint
(Etype
(Rhs
))));
2020 Make_Selected_Component
(Loc
,
2021 Prefix
=> Duplicate_Subexpr
(Rhs
),
2022 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
2025 -- Generate the assignment statement. When the left-hand side
2026 -- is an object with an address clause present, force generated
2027 -- temporaries to be renamings so as to correctly assign to any
2028 -- overlaid objects.
2031 Make_Assignment_Statement
(Loc
,
2033 Make_Selected_Component
(Loc
,
2039 Is_Entity_Name
(Lhs
)
2040 and then Present
(Address_Clause
(Entity
(Lhs
)))),
2042 New_Occurrence_Of
(Find_Component
(L_Typ
, C
), Loc
)),
2043 Expression
=> Expr
);
2045 -- Set Assignment_OK, so discriminants can be assigned
2047 Set_Assignment_OK
(Name
(A
), True);
2049 if Componentwise_Assignment
(N
)
2050 and then Nkind
(Name
(A
)) = N_Selected_Component
2051 and then Chars
(Selector_Name
(Name
(A
))) = Name_uParent
2053 Set_Componentwise_Assignment
(A
);
2057 end Make_Field_Assign
;
2059 ------------------------
2060 -- Make_Field_Assigns --
2061 ------------------------
2063 function Make_Field_Assigns
(CI
: List_Id
) return List_Id
is
2071 while Present
(Item
) loop
2073 -- Look for components, but exclude _tag field assignment if
2074 -- the special Componentwise_Assignment flag is set.
2076 if Nkind
(Item
) = N_Component_Declaration
2077 and then not (Is_Tag
(Defining_Identifier
(Item
))
2078 and then Componentwise_Assignment
(N
))
2081 (Result
, Make_Field_Assign
(Defining_Identifier
(Item
)));
2088 end Make_Field_Assigns
;
2090 -- Start of processing for Expand_Assign_Record
2093 -- Note that we need to use the base types for this processing in
2094 -- order to retrieve the Type_Definition. In the constrained case,
2095 -- we filter out the non relevant fields in
2096 -- Make_Component_List_Assign.
2098 -- First copy the discriminants. This is done unconditionally. It
2099 -- is required in the unconstrained left side case, and also in the
2100 -- case where this assignment was constructed during the expansion
2101 -- of a type conversion (since initialization of discriminants is
2102 -- suppressed in this case). It is unnecessary but harmless in
2105 -- Special case: no copy if the target has no discriminants
2107 if Has_Discriminants
(L_Typ
)
2108 and then Is_Unchecked_Union
(Base_Type
(L_Typ
))
2112 elsif Has_Discriminants
(L_Typ
) then
2113 F
:= First_Discriminant
(R_Typ
);
2114 while Present
(F
) loop
2116 -- If we are expanding the initialization of a derived record
2117 -- that constrains or renames discriminants of the parent, we
2118 -- must use the corresponding discriminant in the parent.
2125 and then Present
(Corresponding_Discriminant
(F
))
2127 CF
:= Corresponding_Discriminant
(F
);
2132 if Is_Unchecked_Union
(R_Typ
) then
2134 -- Within an initialization procedure this is the
2135 -- assignment to an unchecked union component, in which
2136 -- case there is no discriminant to initialize.
2138 if Inside_Init_Proc
then
2142 -- The assignment is part of a conversion from a
2143 -- derived unchecked union type with an inferable
2144 -- discriminant, to a parent type.
2146 Insert_Action
(N
, Make_Field_Assign
(CF
, True));
2150 Insert_Action
(N
, Make_Field_Assign
(CF
));
2153 Next_Discriminant
(F
);
2157 -- If the derived type has a stored constraint, assign the value
2158 -- of the corresponding discriminants explicitly, skipping those
2159 -- that are renamed discriminants. We cannot just retrieve them
2160 -- from the Rhs by selected component because they are invisible
2161 -- in the type of the right-hand side.
2163 if Present
(Stored_Constraint
(R_Typ
)) then
2166 Discr_Val
: Elmt_Id
;
2169 Discr_Val
:= First_Elmt
(Stored_Constraint
(R_Typ
));
2170 F
:= First_Entity
(R_Typ
);
2171 while Present
(F
) loop
2172 if Ekind
(F
) = E_Discriminant
2173 and then Is_Completely_Hidden
(F
)
2174 and then Present
(Corresponding_Record_Component
(F
))
2176 (not Is_Entity_Name
(Node
(Discr_Val
))
2177 or else Ekind
(Entity
(Node
(Discr_Val
))) /=
2181 Make_Assignment_Statement
(Loc
,
2183 Make_Selected_Component
(Loc
,
2184 Prefix
=> Duplicate_Subexpr
(Lhs
),
2187 (Corresponding_Record_Component
(F
), Loc
)),
2188 Expression
=> New_Copy
(Node
(Discr_Val
)));
2190 Set_Assignment_OK
(Name
(Assign
));
2191 Insert_Action
(N
, Assign
);
2192 Next_Elmt
(Discr_Val
);
2201 -- We know the underlying type is a record, but its current view
2202 -- may be private. We must retrieve the usable record declaration.
2204 if Nkind
(Decl
) in N_Private_Type_Declaration
2205 | N_Private_Extension_Declaration
2206 and then Present
(Full_View
(R_Typ
))
2208 RDef
:= Type_Definition
(Declaration_Node
(Full_View
(R_Typ
)));
2210 RDef
:= Type_Definition
(Decl
);
2213 if Nkind
(RDef
) = N_Derived_Type_Definition
then
2214 RDef
:= Record_Extension_Part
(RDef
);
2217 if Nkind
(RDef
) = N_Record_Definition
2218 and then Present
(Component_List
(RDef
))
2220 if Is_Unchecked_Union
(R_Typ
) then
2222 Make_Component_List_Assign
(Component_List
(RDef
), True));
2225 Make_Component_List_Assign
(Component_List
(RDef
)));
2228 Rewrite
(N
, Make_Null_Statement
(Loc
));
2231 end Expand_Assign_Record
;
2233 -------------------------------------
2234 -- Expand_Assign_With_Target_Names --
2235 -------------------------------------
2237 procedure Expand_Assign_With_Target_Names
(N
: Node_Id
) is
2238 LHS
: constant Node_Id
:= Name
(N
);
2239 LHS_Typ
: constant Entity_Id
:= Etype
(LHS
);
2240 Loc
: constant Source_Ptr
:= Sloc
(N
);
2241 RHS
: constant Node_Id
:= Expression
(N
);
2244 -- The entity of the left-hand side
2246 function Replace_Target
(N
: Node_Id
) return Traverse_Result
;
2247 -- Replace occurrences of the target name by the proper entity: either
2248 -- the entity of the LHS in simple cases, or the formal of the
2249 -- constructed procedure otherwise.
2251 --------------------
2252 -- Replace_Target --
2253 --------------------
2255 function Replace_Target
(N
: Node_Id
) return Traverse_Result
is
2257 if Nkind
(N
) = N_Target_Name
then
2258 Rewrite
(N
, New_Occurrence_Of
(Ent
, Sloc
(N
)));
2260 -- The expression will be reanalyzed when the enclosing assignment
2261 -- is reanalyzed, so reset the entity, which may be a temporary
2262 -- created during analysis, e.g. a loop variable for an iterated
2263 -- component association. However, if entity is callable then
2264 -- resolution has established its proper identity (including in
2265 -- rewritten prefixed calls) so we must preserve it.
2267 elsif Is_Entity_Name
(N
) then
2268 if Present
(Entity
(N
))
2269 and then not Is_Overloadable
(Entity
(N
))
2271 Set_Entity
(N
, Empty
);
2275 Set_Analyzed
(N
, False);
2279 procedure Replace_Target_Name
is new Traverse_Proc
(Replace_Target
);
2284 Proc_Id
: Entity_Id
;
2286 -- Start of processing for Expand_Assign_With_Target_Names
2289 New_RHS
:= New_Copy_Tree
(RHS
);
2291 -- The left-hand side is a direct name
2293 if Is_Entity_Name
(LHS
)
2294 and then not Is_Renaming_Of_Object
(Entity
(LHS
))
2296 Ent
:= Entity
(LHS
);
2297 Replace_Target_Name
(New_RHS
);
2300 -- LHS := ... LHS ...;
2303 Make_Assignment_Statement
(Loc
,
2304 Name
=> Relocate_Node
(LHS
),
2305 Expression
=> New_RHS
));
2307 -- The left-hand side is not a direct name, but is side-effect-free.
2308 -- Capture its value in a temporary to avoid generating a procedure.
2309 -- We don't do this optimization if the target object's type may need
2310 -- finalization actions, because we don't want extra finalizations to
2311 -- be done for the temp object, and instead we use the more general
2312 -- procedure-based approach below.
2314 elsif Side_Effect_Free
(LHS
)
2315 and then not Needs_Finalization
(Etype
(LHS
))
2317 Ent
:= Make_Temporary
(Loc
, 'T');
2318 Replace_Target_Name
(New_RHS
);
2321 -- T : LHS_Typ := LHS;
2323 Insert_Before_And_Analyze
(N
,
2324 Make_Object_Declaration
(Loc
,
2325 Defining_Identifier
=> Ent
,
2326 Object_Definition
=> New_Occurrence_Of
(LHS_Typ
, Loc
),
2327 Expression
=> New_Copy_Tree
(LHS
)));
2330 -- LHS := ... T ...;
2333 Make_Assignment_Statement
(Loc
,
2334 Name
=> Relocate_Node
(LHS
),
2335 Expression
=> New_RHS
));
2337 -- Otherwise wrap the whole assignment statement in a procedure with an
2338 -- IN OUT parameter. The original assignment then becomes a call to the
2339 -- procedure with the left-hand side as an actual.
2342 Ent
:= Make_Temporary
(Loc
, 'T');
2343 Replace_Target_Name
(New_RHS
);
2346 -- procedure P (T : in out LHS_Typ) is
2351 Proc_Id
:= Make_Temporary
(Loc
, 'P');
2353 Insert_Before_And_Analyze
(N
,
2354 Make_Subprogram_Body
(Loc
,
2356 Make_Procedure_Specification
(Loc
,
2357 Defining_Unit_Name
=> Proc_Id
,
2358 Parameter_Specifications
=> New_List
(
2359 Make_Parameter_Specification
(Loc
,
2360 Defining_Identifier
=> Ent
,
2362 Out_Present
=> True,
2364 New_Occurrence_Of
(LHS_Typ
, Loc
)))),
2366 Declarations
=> Empty_List
,
2368 Handled_Statement_Sequence
=>
2369 Make_Handled_Sequence_Of_Statements
(Loc
,
2370 Statements
=> New_List
(
2371 Make_Assignment_Statement
(Loc
,
2372 Name
=> New_Occurrence_Of
(Ent
, Loc
),
2373 Expression
=> New_RHS
)))));
2379 Make_Procedure_Call_Statement
(Loc
,
2380 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
2381 Parameter_Associations
=> New_List
(Relocate_Node
(LHS
))));
2384 -- Analyze rewritten node, either as assignment or procedure call
2387 end Expand_Assign_With_Target_Names
;
2389 -----------------------------------
2390 -- Expand_N_Assignment_Statement --
2391 -----------------------------------
2393 -- This procedure implements various cases where an assignment statement
2394 -- cannot just be passed on to the back end in untransformed state.
2396 procedure Expand_N_Assignment_Statement
(N
: Node_Id
) is
2397 Crep
: constant Boolean := Change_Of_Representation
(N
);
2398 Lhs
: constant Node_Id
:= Name
(N
);
2399 Loc
: constant Source_Ptr
:= Sloc
(N
);
2400 Rhs
: constant Node_Id
:= Expression
(N
);
2401 Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Lhs
));
2405 -- Special case to check right away, if the Componentwise_Assignment
2406 -- flag is set, this is a reanalysis from the expansion of the primitive
2407 -- assignment procedure for a tagged type, and all we need to do is to
2408 -- expand to assignment of components, because otherwise, we would get
2409 -- infinite recursion (since this looks like a tagged assignment which
2410 -- would normally try to *call* the primitive assignment procedure).
2412 if Componentwise_Assignment
(N
) then
2413 Expand_Assign_Record
(N
);
2417 -- Defend against invalid subscripts on left side if we are in standard
2418 -- validity checking mode. No need to do this if we are checking all
2421 -- Note that we do this right away, because there are some early return
2422 -- paths in this procedure, and this is required on all paths.
2424 if Validity_Checks_On
2425 and then Validity_Check_Default
2426 and then not Validity_Check_Subscripts
2428 Check_Valid_Lvalue_Subscripts
(Lhs
);
2431 -- Separate expansion if RHS contain target names. Note that assignment
2432 -- may already have been expanded if RHS is aggregate.
2434 if Nkind
(N
) = N_Assignment_Statement
and then Has_Target_Names
(N
) then
2435 Expand_Assign_With_Target_Names
(N
);
2439 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
2441 -- Rewrite an assignment to X'Priority into a run-time call
2443 -- For example: X'Priority := New_Prio_Expr;
2444 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
2446 -- Note that although X'Priority is notionally an object, it is quite
2447 -- deliberately not defined as an aliased object in the RM. This means
2448 -- that it works fine to rewrite it as a call, without having to worry
2449 -- about complications that would other arise from X'Priority'Access,
2450 -- which is illegal, because of the lack of aliasing.
2452 if Ada_Version
>= Ada_2005
then
2456 Prottyp
: Entity_Id
;
2460 -- Handle chains of renamings
2463 while Nkind
(Ent
) in N_Has_Entity
2464 and then Present
(Entity
(Ent
))
2465 and then Is_Object
(Entity
(Ent
))
2466 and then Present
(Renamed_Object
(Entity
(Ent
)))
2468 Ent
:= Renamed_Object
(Entity
(Ent
));
2471 -- The attribute Priority applied to protected objects has been
2472 -- previously expanded into a call to the Get_Ceiling run-time
2473 -- subprogram. In restricted profiles this is not available.
2475 if Is_Expanded_Priority_Attribute
(Ent
) then
2477 -- Look for the enclosing protected type
2479 Prottyp
:= Current_Scope
;
2480 while not Is_Protected_Type
(Prottyp
) loop
2481 Prottyp
:= Scope
(Prottyp
);
2484 pragma Assert
(Is_Protected_Type
(Prottyp
));
2486 -- Select the appropriate run-time call
2488 if Has_Entries
(Prottyp
) then
2489 RT_Subprg
:= RO_PE_Set_Ceiling
;
2491 RT_Subprg
:= RE_Set_Ceiling
;
2495 Make_Procedure_Call_Statement
(Loc
,
2497 New_Occurrence_Of
(RTE
(RT_Subprg
), Loc
),
2498 Parameter_Associations
=> New_List
(
2499 New_Copy_Tree
(First
(Parameter_Associations
(Ent
))),
2500 Relocate_Node
(Expression
(N
))));
2510 -- Deal with assignment checks unless suppressed
2512 if not Suppress_Assignment_Checks
(N
) then
2514 -- First deal with generation of range check if required,
2515 -- and then predicate checks if the type carries a predicate.
2516 -- If the Rhs is an expression these tests may have been applied
2517 -- already. This is the case if the RHS is a type conversion.
2518 -- Other such redundant checks could be removed ???
2520 if Nkind
(Rhs
) /= N_Type_Conversion
2521 or else Entity
(Subtype_Mark
(Rhs
)) /= Typ
2523 if Do_Range_Check
(Rhs
) then
2524 Generate_Range_Check
(Rhs
, Typ
, CE_Range_Check_Failed
);
2527 Apply_Predicate_Check
(Rhs
, Typ
);
2531 -- Check for a special case where a high level transformation is
2532 -- required. If we have either of:
2537 -- where P is a reference to a bit packed array, then we have to unwind
2538 -- the assignment. The exact meaning of being a reference to a bit
2539 -- packed array is as follows:
2541 -- An indexed component whose prefix is a bit packed array is a
2542 -- reference to a bit packed array.
2544 -- An indexed component or selected component whose prefix is a
2545 -- reference to a bit packed array is itself a reference ot a
2546 -- bit packed array.
2548 -- The required transformation is
2550 -- Tnn : prefix_type := P;
2551 -- Tnn.field := rhs;
2556 -- Tnn : prefix_type := P;
2557 -- Tnn (subscr) := rhs;
2560 -- Since P is going to be evaluated more than once, any subscripts
2561 -- in P must have their evaluation forced.
2563 if Nkind
(Lhs
) in N_Indexed_Component | N_Selected_Component
2564 and then Is_Ref_To_Bit_Packed_Array
(Prefix
(Lhs
))
2567 BPAR_Expr
: constant Node_Id
:= Relocate_Node
(Prefix
(Lhs
));
2568 BPAR_Typ
: constant Entity_Id
:= Etype
(BPAR_Expr
);
2569 Tnn
: constant Entity_Id
:=
2570 Make_Temporary
(Loc
, 'T', BPAR_Expr
);
2573 -- Insert the post assignment first, because we want to copy the
2574 -- BPAR_Expr tree before it gets analyzed in the context of the
2575 -- pre assignment. Note that we do not analyze the post assignment
2576 -- yet (we cannot till we have completed the analysis of the pre
2577 -- assignment). As usual, the analysis of this post assignment
2578 -- will happen on its own when we "run into" it after finishing
2579 -- the current assignment.
2582 Make_Assignment_Statement
(Loc
,
2583 Name
=> New_Copy_Tree
(BPAR_Expr
),
2584 Expression
=> New_Occurrence_Of
(Tnn
, Loc
)));
2586 -- At this stage BPAR_Expr is a reference to a bit packed array
2587 -- where the reference was not expanded in the original tree,
2588 -- since it was on the left side of an assignment. But in the
2589 -- pre-assignment statement (the object definition), BPAR_Expr
2590 -- will end up on the right-hand side, and must be reexpanded. To
2591 -- achieve this, we reset the analyzed flag of all selected and
2592 -- indexed components down to the actual indexed component for
2593 -- the packed array.
2597 Set_Analyzed
(Exp
, False);
2599 if Nkind
(Exp
) in N_Indexed_Component | N_Selected_Component
2601 Exp
:= Prefix
(Exp
);
2607 -- Now we can insert and analyze the pre-assignment
2609 -- If the right-hand side requires a transient scope, it has
2610 -- already been placed on the stack. However, the declaration is
2611 -- inserted in the tree outside of this scope, and must reflect
2612 -- the proper scope for its variable. This awkward bit is forced
2613 -- by the stricter scope discipline imposed by GCC 2.97.
2616 Uses_Transient_Scope
: constant Boolean :=
2618 and then N
= Node_To_Be_Wrapped
;
2621 if Uses_Transient_Scope
then
2622 Push_Scope
(Scope
(Current_Scope
));
2625 Insert_Before_And_Analyze
(N
,
2626 Make_Object_Declaration
(Loc
,
2627 Defining_Identifier
=> Tnn
,
2628 Object_Definition
=> New_Occurrence_Of
(BPAR_Typ
, Loc
),
2629 Expression
=> BPAR_Expr
));
2631 if Uses_Transient_Scope
then
2636 -- Now fix up the original assignment and continue processing
2638 Rewrite
(Prefix
(Lhs
),
2639 New_Occurrence_Of
(Tnn
, Loc
));
2641 -- We do not need to reanalyze that assignment, and we do not need
2642 -- to worry about references to the temporary, but we do need to
2643 -- make sure that the temporary is not marked as a true constant
2644 -- since we now have a generated assignment to it.
2646 Set_Is_True_Constant
(Tnn
, False);
2650 -- When we have the appropriate type of aggregate in the expression (it
2651 -- has been determined during analysis of the aggregate by setting the
2652 -- delay flag), let's perform in place assignment and thus avoid
2653 -- creating a temporary.
2655 if Is_Delayed_Aggregate
(Rhs
) then
2656 Convert_Aggr_In_Assignment
(N
);
2657 Rewrite
(N
, Make_Null_Statement
(Loc
));
2662 -- An assignment between nonnative storage models requires creating an
2663 -- intermediate temporary on the host, which can potentially be large.
2665 if Nkind
(Lhs
) = N_Explicit_Dereference
2666 and then Has_Designated_Storage_Model_Aspect
(Etype
(Prefix
(Lhs
)))
2667 and then Present
(Storage_Model_Copy_To
2668 (Storage_Model_Object
(Etype
(Prefix
(Lhs
)))))
2669 and then Nkind
(Rhs
) = N_Explicit_Dereference
2670 and then Has_Designated_Storage_Model_Aspect
(Etype
(Prefix
(Rhs
)))
2671 and then Present
(Storage_Model_Copy_From
2672 (Storage_Model_Object
(Etype
(Prefix
(Rhs
)))))
2675 Assign_Code
: List_Id
;
2679 Assign_Code
:= New_List
;
2681 Tmp
:= Build_Temporary_On_Secondary_Stack
(Loc
, Typ
, Assign_Code
);
2683 Append_To
(Assign_Code
,
2684 Make_Assignment_Statement
(Loc
,
2686 Make_Explicit_Dereference
(Loc
,
2687 Prefix
=> New_Occurrence_Of
(Tmp
, Loc
)),
2688 Expression
=> Relocate_Node
(Rhs
)));
2690 Append_To
(Assign_Code
,
2691 Make_Assignment_Statement
(Loc
,
2692 Name
=> Relocate_Node
(Lhs
),
2694 Make_Explicit_Dereference
(Loc
,
2695 Prefix
=> New_Occurrence_Of
(Tmp
, Loc
))));
2697 Insert_Actions
(N
, Assign_Code
);
2698 Rewrite
(N
, Make_Null_Statement
(Loc
));
2703 -- Apply discriminant check if required. If Lhs is an access type to a
2704 -- designated type with discriminants, we must always check. If the
2705 -- type has unknown discriminants, more elaborate processing below.
2707 if Has_Discriminants
(Etype
(Lhs
))
2708 and then not Has_Unknown_Discriminants
(Etype
(Lhs
))
2710 -- Skip discriminant check if change of representation. Will be
2711 -- done when the change of representation is expanded out.
2713 if not Crep
and then not Suppress_Assignment_Checks
(N
) then
2714 Apply_Discriminant_Check
(Rhs
, Etype
(Lhs
), Lhs
);
2717 -- If the type is private without discriminants, and the full type
2718 -- has discriminants (necessarily with defaults) a check may still be
2719 -- necessary if the Lhs is aliased. The private discriminants must be
2720 -- visible to build the discriminant constraints.
2722 -- Only an explicit dereference that comes from source indicates
2723 -- aliasing. Access to formals of protected operations and entries
2724 -- create dereferences but are not semantic aliasings.
2726 elsif Is_Private_Type
(Etype
(Lhs
))
2727 and then Has_Discriminants
(Typ
)
2728 and then Nkind
(Lhs
) = N_Explicit_Dereference
2729 and then Comes_From_Source
(Lhs
)
2732 Lt
: constant Entity_Id
:= Etype
(Lhs
);
2733 Ubt
: Entity_Id
:= Base_Type
(Typ
);
2736 -- In the case of an expander-generated record subtype whose base
2737 -- type still appears private, Typ will have been set to that
2738 -- private type rather than the underlying record type (because
2739 -- Underlying type will have returned the record subtype), so it's
2740 -- necessary to apply Underlying_Type again to the base type to
2741 -- get the record type we need for the discriminant check. Such
2742 -- subtypes can be created for assignments in certain cases, such
2743 -- as within an instantiation passed this kind of private type.
2744 -- It would be good to avoid this special test, but making changes
2745 -- to prevent this odd form of record subtype seems difficult. ???
2747 if Is_Private_Type
(Ubt
) then
2748 Ubt
:= Underlying_Type
(Ubt
);
2751 Set_Etype
(Lhs
, Ubt
);
2752 Rewrite
(Rhs
, OK_Convert_To
(Base_Type
(Ubt
), Rhs
));
2753 if not Suppress_Assignment_Checks
(N
) then
2754 Apply_Discriminant_Check
(Rhs
, Ubt
, Lhs
);
2756 Set_Etype
(Lhs
, Lt
);
2759 -- If the Lhs has a private type with unknown discriminants, it may
2760 -- have a full view with discriminants, but those are nameable only
2761 -- in the underlying type, so convert the Rhs to it before potential
2762 -- checking. Convert Lhs as well, otherwise the actual subtype might
2763 -- not be constructible. If the discriminants have defaults the type
2764 -- is unconstrained and there is nothing to check.
2765 -- Ditto if a private type with unknown discriminants has a full view
2766 -- that is an unconstrained array, in which case a length check is
2769 elsif Has_Unknown_Discriminants
(Base_Type
(Etype
(Lhs
))) then
2770 if Has_Discriminants
(Typ
)
2771 and then not Has_Defaulted_Discriminants
(Typ
)
2773 Rewrite
(Rhs
, OK_Convert_To
(Base_Type
(Typ
), Rhs
));
2774 Rewrite
(Lhs
, OK_Convert_To
(Base_Type
(Typ
), Lhs
));
2775 if not Suppress_Assignment_Checks
(N
) then
2776 Apply_Discriminant_Check
(Rhs
, Typ
, Lhs
);
2779 elsif Is_Array_Type
(Typ
) and then Is_Constrained
(Typ
) then
2780 Rewrite
(Rhs
, OK_Convert_To
(Base_Type
(Typ
), Rhs
));
2781 Rewrite
(Lhs
, OK_Convert_To
(Base_Type
(Typ
), Lhs
));
2782 if not Suppress_Assignment_Checks
(N
) then
2783 Apply_Length_Check
(Rhs
, Typ
);
2787 -- In the access type case, we need the same discriminant check, and
2788 -- also range checks if we have an access to constrained array.
2790 elsif Is_Access_Type
(Etype
(Lhs
))
2791 and then Is_Constrained
(Designated_Type
(Etype
(Lhs
)))
2792 and then not Suppress_Assignment_Checks
(N
)
2794 if Has_Discriminants
(Designated_Type
(Etype
(Lhs
))) then
2796 -- Skip discriminant check if change of representation. Will be
2797 -- done when the change of representation is expanded out.
2800 Apply_Discriminant_Check
(Rhs
, Etype
(Lhs
));
2803 elsif Is_Array_Type
(Designated_Type
(Etype
(Lhs
))) then
2804 Apply_Range_Check
(Rhs
, Etype
(Lhs
));
2806 if Is_Constrained
(Etype
(Lhs
)) then
2807 Apply_Length_Check
(Rhs
, Etype
(Lhs
));
2812 -- Ada 2005 (AI-231): Generate the run-time check
2814 if Is_Access_Type
(Typ
)
2815 and then Can_Never_Be_Null
(Etype
(Lhs
))
2816 and then not Can_Never_Be_Null
(Etype
(Rhs
))
2818 -- If an actual is an out parameter of a null-excluding access
2819 -- type, there is access check on entry, so we set the flag
2820 -- Suppress_Assignment_Checks on the generated statement to
2821 -- assign the actual to the parameter block, and we do not want
2822 -- to generate an additional check at this point.
2824 and then not Suppress_Assignment_Checks
(N
)
2826 Apply_Constraint_Check
(Rhs
, Etype
(Lhs
));
2829 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2830 -- stand-alone obj of an anonymous access type. Do not install the check
2831 -- when the Lhs denotes a container cursor and the Next function employs
2832 -- an access type, because this can never result in a dangling pointer.
2834 if Is_Access_Type
(Typ
)
2835 and then Is_Entity_Name
(Lhs
)
2836 and then Ekind
(Entity
(Lhs
)) /= E_Loop_Parameter
2837 and then Present
(Effective_Extra_Accessibility
(Entity
(Lhs
)))
2840 function Lhs_Entity
return Entity_Id
;
2841 -- Look through renames to find the underlying entity.
2842 -- For assignment to a rename, we don't care about the
2843 -- Enclosing_Dynamic_Scope of the rename declaration.
2849 function Lhs_Entity
return Entity_Id
is
2850 Result
: Entity_Id
:= Entity
(Lhs
);
2853 while Present
(Renamed_Object
(Result
)) loop
2855 -- Renamed_Object must return an Entity_Name here
2856 -- because of preceding "Present (E_E_A (...))" test.
2858 Result
:= Entity
(Renamed_Object
(Result
));
2864 -- Local Declarations
2866 Access_Check
: constant Node_Id
:=
2867 Make_Raise_Program_Error
(Loc
,
2871 Accessibility_Level
(Rhs
, Dynamic_Level
),
2873 Make_Integer_Literal
(Loc
,
2876 (Enclosing_Dynamic_Scope
2878 Reason
=> PE_Accessibility_Check_Failed
);
2880 Access_Level_Update
: constant Node_Id
:=
2881 Make_Assignment_Statement
(Loc
,
2884 (Effective_Extra_Accessibility
2885 (Entity
(Lhs
)), Loc
),
2889 Level
=> Dynamic_Level
,
2890 Allow_Alt_Model
=> False));
2893 if not Accessibility_Checks_Suppressed
(Entity
(Lhs
)) then
2894 Insert_Action
(N
, Access_Check
);
2897 Insert_Action
(N
, Access_Level_Update
);
2901 -- Case of assignment to a bit packed array element. If there is a
2902 -- change of representation this must be expanded into components,
2903 -- otherwise this is a bit-field assignment.
2905 if Nkind
(Lhs
) = N_Indexed_Component
2906 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Lhs
)))
2908 -- Normal case, no change of representation
2911 Expand_Bit_Packed_Element_Set
(N
);
2914 -- Change of representation case
2917 -- Generate the following, to force component-by-component
2918 -- assignments in an efficient way. Otherwise each component
2919 -- will require a temporary and two bit-field manipulations.
2926 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
2932 Make_Object_Declaration
(Loc
,
2933 Defining_Identifier
=> Tnn
,
2934 Object_Definition
=>
2935 New_Occurrence_Of
(Etype
(Lhs
), Loc
)),
2936 Make_Assignment_Statement
(Loc
,
2937 Name
=> New_Occurrence_Of
(Tnn
, Loc
),
2938 Expression
=> Relocate_Node
(Rhs
)),
2939 Make_Assignment_Statement
(Loc
,
2940 Name
=> Relocate_Node
(Lhs
),
2941 Expression
=> New_Occurrence_Of
(Tnn
, Loc
)));
2943 Insert_Actions
(N
, Stats
);
2944 Rewrite
(N
, Make_Null_Statement
(Loc
));
2949 -- Build-in-place function call case. This is for assignment statements
2950 -- that come from aggregate component associations or from init procs.
2951 -- User-written assignment statements with b-i-p calls are handled
2954 elsif Is_Build_In_Place_Function_Call
(Rhs
) then
2955 pragma Assert
(not Comes_From_Source
(N
));
2956 Make_Build_In_Place_Call_In_Assignment
(N
, Rhs
);
2958 elsif Is_Tagged_Type
(Typ
)
2959 or else (Needs_Finalization
(Typ
) and then not Is_Array_Type
(Typ
))
2961 Tagged_Case
: declare
2962 L
: List_Id
:= No_List
;
2963 Expand_Ctrl_Actions
: constant Boolean
2964 := not No_Ctrl_Actions
(N
)
2965 and then not No_Finalize_Actions
(N
);
2968 -- In the controlled case, we ensure that function calls are
2969 -- evaluated before finalizing the target. In all cases, it makes
2970 -- the expansion easier if the side effects are removed first.
2972 Remove_Side_Effects
(Lhs
);
2973 Remove_Side_Effects
(Rhs
);
2975 -- Avoid recursion in the mechanism
2979 -- If dispatching assignment, we need to dispatch to _assign
2981 if Is_Class_Wide_Type
(Typ
)
2983 -- If the type is tagged, we may as well use the predefined
2984 -- primitive assignment. This avoids inlining a lot of code
2985 -- and in the class-wide case, the assignment is replaced
2986 -- by a dispatching call to _assign. It is suppressed in the
2987 -- case of assignments created by the expander that correspond
2988 -- to initializations, where we do want to copy the tag
2989 -- (Expand_Ctrl_Actions flag is set False in this case). It is
2990 -- also suppressed if restriction No_Dispatching_Calls is in
2991 -- force because in that case predefined primitives are not
2994 or else (Is_Tagged_Type
(Typ
)
2995 and then Chars
(Current_Scope
) /= Name_uAssign
2996 and then Expand_Ctrl_Actions
2998 not Restriction_Active
(No_Dispatching_Calls
))
3000 -- We should normally not encounter any limited type here,
3001 -- except in the corner case where an assignment was not
3002 -- intended like the pathological case of a raise expression
3003 -- within a return statement.
3005 if Is_Limited_Type
(Typ
) then
3006 pragma Assert
(not Comes_From_Source
(N
));
3010 -- Fetch the primitive op _assign and proper type to call it.
3011 -- Because of possible conflicts between private and full view,
3012 -- fetch the proper type directly from the operation profile.
3015 Op
: constant Entity_Id
:=
3016 Find_Prim_Op
(Typ
, Name_uAssign
);
3017 F_Typ
: Entity_Id
:= Etype
(First_Formal
(Op
));
3020 -- If the assignment is dispatching, make sure to use the
3023 if Is_Class_Wide_Type
(Typ
) then
3024 F_Typ
:= Class_Wide_Type
(F_Typ
);
3029 -- In case of assignment to a class-wide tagged type, before
3030 -- the assignment we generate run-time check to ensure that
3031 -- the tags of source and target match.
3033 if not Tag_Checks_Suppressed
(Typ
)
3034 and then Is_Class_Wide_Type
(Typ
)
3035 and then Is_Tagged_Type
(Typ
)
3036 and then Is_Tagged_Type
(Underlying_Type
(Etype
(Rhs
)))
3043 if not Is_Interface
(Typ
) then
3045 Make_Selected_Component
(Loc
,
3046 Prefix
=> Duplicate_Subexpr
(Lhs
),
3048 Make_Identifier
(Loc
, Name_uTag
));
3050 Make_Selected_Component
(Loc
,
3051 Prefix
=> Duplicate_Subexpr
(Rhs
),
3053 Make_Identifier
(Loc
, Name_uTag
));
3055 -- Displace the pointer to the base of the objects
3056 -- applying 'Address, which is later expanded into
3057 -- a call to RE_Base_Address.
3060 Make_Explicit_Dereference
(Loc
,
3062 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
3063 Make_Attribute_Reference
(Loc
,
3064 Prefix
=> Duplicate_Subexpr
(Lhs
),
3065 Attribute_Name
=> Name_Address
)));
3067 Make_Explicit_Dereference
(Loc
,
3069 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
3070 Make_Attribute_Reference
(Loc
,
3071 Prefix
=> Duplicate_Subexpr
(Rhs
),
3072 Attribute_Name
=> Name_Address
)));
3076 Make_Raise_Constraint_Error
(Loc
,
3079 Left_Opnd
=> Lhs_Tag
,
3080 Right_Opnd
=> Rhs_Tag
),
3081 Reason
=> CE_Tag_Check_Failed
));
3086 Left_N
: Node_Id
:= Duplicate_Subexpr
(Lhs
);
3087 Right_N
: Node_Id
:= Duplicate_Subexpr
(Rhs
);
3090 -- In order to dispatch the call to _assign the type of
3091 -- the actuals must match. Add conversion (if required).
3093 if Etype
(Lhs
) /= F_Typ
then
3094 Left_N
:= Unchecked_Convert_To
(F_Typ
, Left_N
);
3097 if Etype
(Rhs
) /= F_Typ
then
3098 Right_N
:= Unchecked_Convert_To
(F_Typ
, Right_N
);
3102 Make_Procedure_Call_Statement
(Loc
,
3103 Name
=> New_Occurrence_Of
(Op
, Loc
),
3104 Parameter_Associations
=> New_List
(
3106 Node2
=> Right_N
)));
3111 L
:= Make_Tag_Ctrl_Assignment
(N
);
3113 -- We can't afford to have destructive Finalization Actions in
3114 -- the Self assignment case, so if the target and the source
3115 -- are not obviously different, code is generated to avoid the
3116 -- self assignment case:
3118 -- if lhs'address /= rhs'address then
3119 -- <code for controlled and/or tagged assignment>
3122 -- Skip this if Restriction (No_Finalization) is active
3124 if not Statically_Different
(Lhs
, Rhs
)
3125 and then Expand_Ctrl_Actions
3126 and then not Restriction_Active
(No_Finalization
)
3129 Make_Implicit_If_Statement
(N
,
3133 Make_Attribute_Reference
(Loc
,
3134 Prefix
=> Duplicate_Subexpr
(Lhs
),
3135 Attribute_Name
=> Name_Address
),
3138 Make_Attribute_Reference
(Loc
,
3139 Prefix
=> Duplicate_Subexpr
(Rhs
),
3140 Attribute_Name
=> Name_Address
)),
3142 Then_Statements
=> L
));
3145 -- We need to set up an exception handler for implementing
3146 -- 7.6.1(18). The remaining adjustments are tackled by the
3147 -- implementation of adjust for record_controllers (see
3150 -- This is skipped if we have no finalization
3152 if Expand_Ctrl_Actions
3153 and then not Restriction_Active
(No_Finalization
)
3156 Make_Block_Statement
(Loc
,
3157 Handled_Statement_Sequence
=>
3158 Make_Handled_Sequence_Of_Statements
(Loc
,
3160 Exception_Handlers
=> New_List
(
3161 Make_Handler_For_Ctrl_Operation
(Loc
)))));
3165 -- We will analyze the block statement with all checks suppressed
3166 -- below, but we need elaboration checks for the primitives in the
3167 -- case of an assignment created by the expansion of an aggregate.
3169 if No_Finalize_Actions
(N
) then
3171 Make_Unsuppress_Block
(Loc
, Name_Elaboration_Check
, L
));
3175 Make_Block_Statement
(Loc
,
3176 Handled_Statement_Sequence
=>
3177 Make_Handled_Sequence_Of_Statements
(Loc
, L
)));
3180 -- If no restrictions on aborts, protect the whole assignment
3181 -- for controlled objects as per 9.8(11).
3183 if Needs_Finalization
(Typ
)
3184 and then Expand_Ctrl_Actions
3185 and then Abort_Allowed
3188 Blk
: constant Entity_Id
:=
3190 (E_Block
, Current_Scope
, Sloc
(N
), 'B');
3191 AUD
: constant Entity_Id
:= RTE
(RE_Abort_Undefer_Direct
);
3194 Set_Is_Abort_Block
(N
);
3196 Set_Scope
(Blk
, Current_Scope
);
3197 Set_Etype
(Blk
, Standard_Void_Type
);
3198 Set_Identifier
(N
, New_Occurrence_Of
(Blk
, Sloc
(N
)));
3200 Prepend_To
(L
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
3201 Set_At_End_Proc
(Handled_Statement_Sequence
(N
),
3202 New_Occurrence_Of
(AUD
, Loc
));
3204 -- Present the Abort_Undefer_Direct function to the backend
3205 -- so that it can inline the call to the function.
3207 Add_Inlined_Body
(AUD
, N
);
3209 Expand_At_End_Handler
3210 (Handled_Statement_Sequence
(N
), Blk
);
3214 -- N has been rewritten to a block statement for which it is
3215 -- known by construction that no checks are necessary: analyze
3216 -- it with all checks suppressed.
3218 Analyze
(N
, Suppress
=> All_Checks
);
3224 elsif Is_Array_Type
(Typ
) then
3226 Actual_Rhs
: Node_Id
:= Rhs
;
3229 while Nkind
(Actual_Rhs
) in
3230 N_Type_Conversion | N_Qualified_Expression
3232 Actual_Rhs
:= Expression
(Actual_Rhs
);
3235 Expand_Assign_Array
(N
, Actual_Rhs
);
3241 elsif Is_Record_Type
(Typ
) then
3242 Expand_Assign_Record
(N
);
3245 -- Scalar types. This is where we perform the processing related to the
3246 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
3249 elsif Is_Scalar_Type
(Typ
) then
3251 -- Case where right side is known valid
3253 if Expr_Known_Valid
(Rhs
) then
3255 -- Here the right side is valid, so it is fine. The case to deal
3256 -- with is when the left side is a local variable reference whose
3257 -- value is not currently known to be valid. If this is the case,
3258 -- and the assignment appears in an unconditional context, then
3259 -- we can mark the left side as now being valid if one of these
3260 -- conditions holds:
3262 -- The expression of the right side has Do_Range_Check set so
3263 -- that we know a range check will be performed. Note that it
3264 -- can be the case that a range check is omitted because we
3265 -- make the assumption that we can assume validity for operands
3266 -- appearing in the right side in determining whether a range
3267 -- check is required
3269 -- The subtype of the right side matches the subtype of the
3270 -- left side. In this case, even though we have not checked
3271 -- the range of the right side, we know it is in range of its
3272 -- subtype if the expression is valid.
3274 if Is_Local_Variable_Reference
(Lhs
)
3275 and then not Is_Known_Valid
(Entity
(Lhs
))
3276 and then In_Unconditional_Context
(N
)
3278 if Do_Range_Check
(Rhs
)
3279 or else Etype
(Lhs
) = Etype
(Rhs
)
3281 Set_Is_Known_Valid
(Entity
(Lhs
), True);
3285 -- Case where right side may be invalid in the sense of the RM
3286 -- reference above. The RM does not require that we check for the
3287 -- validity on an assignment, but it does require that the assignment
3288 -- of an invalid value not cause erroneous behavior.
3290 -- The general approach in GNAT is to use the Is_Known_Valid flag
3291 -- to avoid the need for validity checking on assignments. However
3292 -- in some cases, we have to do validity checking in order to make
3293 -- sure that the setting of this flag is correct.
3296 -- Validate right side if we are validating copies
3298 if Validity_Checks_On
3299 and then Validity_Check_Copies
3301 -- Skip this if left-hand side is an array or record component
3302 -- and elementary component validity checks are suppressed.
3304 if Nkind
(Lhs
) in N_Selected_Component | N_Indexed_Component
3305 and then not Validity_Check_Components
3312 -- We can propagate this to the left side where appropriate
3314 if Is_Local_Variable_Reference
(Lhs
)
3315 and then not Is_Known_Valid
(Entity
(Lhs
))
3316 and then In_Unconditional_Context
(N
)
3318 Set_Is_Known_Valid
(Entity
(Lhs
), True);
3321 -- Otherwise check to see what should be done
3323 -- If left side is a local variable, then we just set its flag to
3324 -- indicate that its value may no longer be valid, since we are
3325 -- copying a potentially invalid value.
3327 elsif Is_Local_Variable_Reference
(Lhs
) then
3328 Set_Is_Known_Valid
(Entity
(Lhs
), False);
3330 -- Check for case of a nonlocal variable on the left side which
3331 -- is currently known to be valid. In this case, we simply ensure
3332 -- that the right side is valid. We only play the game of copying
3333 -- validity status for local variables, since we are doing this
3334 -- statically, not by tracing the full flow graph.
3336 elsif Is_Entity_Name
(Lhs
)
3337 and then Is_Known_Valid
(Entity
(Lhs
))
3339 -- Note: If Validity_Checking mode is set to none, we ignore
3340 -- the Ensure_Valid call so don't worry about that case here.
3344 -- In all other cases, we can safely copy an invalid value without
3345 -- worrying about the status of the left side. Since it is not a
3346 -- variable reference it will not be considered
3347 -- as being known to be valid in any case.
3356 when RE_Not_Available
=>
3358 end Expand_N_Assignment_Statement
;
3360 ------------------------------
3361 -- Expand_N_Block_Statement --
3362 ------------------------------
3364 -- Encode entity names defined in block statement
3366 procedure Expand_N_Block_Statement
(N
: Node_Id
) is
3368 Qualify_Entity_Names
(N
);
3369 end Expand_N_Block_Statement
;
3371 -----------------------------
3372 -- Expand_N_Case_Statement --
3373 -----------------------------
3375 procedure Expand_N_Case_Statement
(N
: Node_Id
) is
3376 Loc
: constant Source_Ptr
:= Sloc
(N
);
3377 Expr
: constant Node_Id
:= Expression
(N
);
3378 From_Cond_Expr
: constant Boolean := From_Conditional_Expression
(N
);
3385 function Expand_General_Case_Statement
return Node_Id
;
3386 -- Expand a case statement whose selecting expression is not discrete
3388 -----------------------------------
3389 -- Expand_General_Case_Statement --
3390 -----------------------------------
3392 function Expand_General_Case_Statement
return Node_Id
is
3393 -- expand into a block statement
3395 Selector
: constant Entity_Id
:=
3396 Make_Temporary
(Loc
, 'J');
3398 function Selector_Subtype_Mark
return Node_Id
is
3399 (New_Occurrence_Of
(Etype
(Expr
), Loc
));
3401 Renamed_Name
: constant Node_Id
:=
3402 (if Is_Name_Reference
(Expr
)
3404 else Make_Qualified_Expression
(Loc
,
3405 Subtype_Mark
=> Selector_Subtype_Mark
,
3406 Expression
=> Expr
));
3408 Selector_Decl
: constant Node_Id
:=
3409 Make_Object_Renaming_Declaration
(Loc
,
3410 Defining_Identifier
=> Selector
,
3411 Subtype_Mark
=> Selector_Subtype_Mark
,
3412 Name
=> Renamed_Name
);
3414 First_Alt
: constant Node_Id
:= First
(Alternatives
(N
));
3416 function Choice_Index_Decl_If_Needed
return Node_Id
;
3417 -- If we are going to need a choice index object (that is, if
3418 -- Multidefined_Bindings is true for at least one of the case
3419 -- alternatives), then create and return that object's declaration.
3420 -- Otherwise, return Empty; no need for a decl in that case because
3421 -- it would never be referenced.
3423 ---------------------------------
3424 -- Choice_Index_Decl_If_Needed --
3425 ---------------------------------
3427 function Choice_Index_Decl_If_Needed
return Node_Id
is
3428 Alt
: Node_Id
:= First_Alt
;
3430 while Present
(Alt
) loop
3431 if Multidefined_Bindings
(Alt
) then
3432 return Make_Object_Declaration
3434 Defining_Identifier
=>
3435 Make_Temporary
(Loc
, 'K'),
3436 Object_Definition
=>
3437 New_Occurrence_Of
(Standard_Positive
, Loc
));
3442 return Empty
; -- decl not needed
3443 end Choice_Index_Decl_If_Needed
;
3445 Choice_Index_Decl
: constant Node_Id
:= Choice_Index_Decl_If_Needed
;
3447 function Pattern_Match
3450 Choice_Index
: Natural;
3452 Suppress_Choice_Index_Update
: Boolean := False) return Node_Id
;
3453 -- Returns a Boolean-valued expression indicating a pattern match
3454 -- for a given pattern and object. If Choice_Index is nonzero,
3455 -- then Choice_Index is assigned to Choice_Index_Decl (unless
3456 -- Suppress_Choice_Index_Update is specified, which should only
3457 -- be the case for a recursive call where the caller has already
3458 -- taken care of the update). Pattern occurs as a choice (or as a
3459 -- subexpression of a choice) of the case statement alternative Alt.
3461 function Top_Level_Pattern_Match_Condition
3462 (Alt
: Node_Id
) return Node_Id
;
3463 -- Returns a Boolean-valued expression indicating a pattern match
3464 -- for the given alternative's list of choices.
3470 function Pattern_Match
3473 Choice_Index
: Natural;
3475 Suppress_Choice_Index_Update
: Boolean := False) return Node_Id
3477 procedure Finish_Binding_Object_Declaration
3478 (Component_Assoc
: Node_Id
; Subobject
: Node_Id
);
3479 -- Finish the work that was started during analysis to
3480 -- declare a binding object. If we are generating a copy,
3481 -- then initialize it. If we are generating a renaming, then
3482 -- initialize the access value designating the renamed object.
3484 function Update_Choice_Index
return Node_Id
is (
3485 Make_Assignment_Statement
(Loc
,
3488 (Defining_Identifier
(Choice_Index_Decl
), Loc
),
3489 Expression
=> Make_Integer_Literal
(Loc
, Pos
(Choice_Index
))));
3494 Choice_Index
: Natural := Pattern_Match
.Choice_Index
;
3495 Alt
: Node_Id
:= Pattern_Match
.Alt
;
3496 Suppress_Choice_Index_Update
: Boolean :=
3497 Pattern_Match
.Suppress_Choice_Index_Update
) return Node_Id
3498 renames Pattern_Match
;
3499 -- convenient rename for recursive calls
3501 function Indexed_Element
(Idx
: Pos
) return Node_Id
;
3502 -- Returns the Nth (well, ok, the Idxth) element of Object
3504 ---------------------------------------
3505 -- Finish_Binding_Object_Declaration --
3506 ---------------------------------------
3508 procedure Finish_Binding_Object_Declaration
3509 (Component_Assoc
: Node_Id
; Subobject
: Node_Id
)
3511 Decl_Chars
: constant Name_Id
:=
3512 Binding_Chars
(Component_Assoc
);
3514 Block_Stmt
: constant Node_Id
:= First
(Statements
(Alt
));
3515 pragma Assert
(Nkind
(Block_Stmt
) = N_Block_Statement
);
3516 pragma Assert
(No
(Next
(Block_Stmt
)));
3518 Decl
: Node_Id
:= First
(Declarations
(Block_Stmt
));
3519 Def_Id
: Node_Id
:= Empty
;
3521 function Declare_Copy
(Decl
: Node_Id
) return Boolean is
3522 (Nkind
(Decl
) = N_Object_Declaration
);
3523 -- Declare_Copy indicates which of the two approaches
3524 -- was chosen during analysis: declare (and initialize)
3525 -- a new variable, or use access values to declare a renaming
3526 -- of the appropriate subcomponent of the selector value.
3528 function Make_Conditional
(Stmt
: Node_Id
) return Node_Id
;
3529 -- If there is only one choice for this alternative, then
3530 -- simply return the argument. If there is more than one
3531 -- choice, then wrap an if-statement around the argument
3532 -- so that it is only executed if the current choice matches.
3534 ----------------------
3535 -- Make_Conditional --
3536 ----------------------
3538 function Make_Conditional
(Stmt
: Node_Id
) return Node_Id
3540 Condition
: Node_Id
;
3542 if Present
(Choice_Index_Decl
) then
3546 (Defining_Identifier
(Choice_Index_Decl
), Loc
),
3547 Make_Integer_Literal
(Loc
, Int
(Choice_Index
)));
3549 return Make_If_Statement
(Loc
,
3550 Condition
=> Condition
,
3551 Then_Statements
=> New_List
(Stmt
));
3553 -- execute Stmt unconditionally
3556 end Make_Conditional
;
3559 -- find the variable to be modified (and its declaration)
3561 if Nkind
(Decl
) in N_Object_Declaration
3562 | N_Object_Renaming_Declaration
3564 Def_Id
:= Defining_Identifier
(Decl
);
3565 exit when Chars
(Def_Id
) = Decl_Chars
;
3568 pragma Assert
(Present
(Decl
));
3571 -- For a binding object, we sometimes make a copy and
3572 -- sometimes introduce a renaming. That decision is made
3573 -- elsewhere. The renaming case involves dereferencing an
3574 -- access value because of the possibility of multiple
3575 -- choices (with multiple binding definitions) for a single
3576 -- alternative. In the copy case, we initialize the copy
3577 -- here (conditionally if there are multiple choices); in the
3578 -- renaming case, we initialize (again, maybe conditionally)
3579 -- the access value.
3581 if Declare_Copy
(Decl
) then
3583 Assign_Value
: constant Node_Id
:=
3584 Make_Assignment_Statement
(Loc
,
3585 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
3586 Expression
=> Subobject
);
3588 HSS
: constant Node_Id
:=
3589 Handled_Statement_Sequence
(Block_Stmt
);
3591 Prepend
(Make_Conditional
(Assign_Value
),
3593 Set_Analyzed
(HSS
, False);
3596 pragma Assert
(Nkind
(Name
(Decl
)) = N_Explicit_Dereference
);
3599 Ptr_Obj
: constant Entity_Id
:=
3600 Entity
(Prefix
(Name
(Decl
)));
3601 Ptr_Decl
: constant Node_Id
:= Parent
(Ptr_Obj
);
3603 Assign_Reference
: constant Node_Id
:=
3604 Make_Assignment_Statement
(Loc
,
3605 Name
=> New_Occurrence_Of
(Ptr_Obj
, Loc
),
3607 Make_Attribute_Reference
(Loc
,
3608 Prefix
=> Subobject
,
3609 Attribute_Name
=> Name_Unrestricted_Access
));
3613 Node
=> Make_Conditional
(Assign_Reference
));
3615 if Present
(Expression
(Ptr_Decl
)) then
3616 -- Delete bogus initial value built during analysis.
3617 -- Look for "5432" in sem_case.adb.
3618 pragma Assert
(Nkind
(Expression
(Ptr_Decl
)) =
3619 N_Unchecked_Type_Conversion
);
3620 Set_Expression
(Ptr_Decl
, Empty
);
3625 Set_Analyzed
(Block_Stmt
, False);
3626 end Finish_Binding_Object_Declaration
;
3628 ---------------------
3629 -- Indexed_Element --
3630 ---------------------
3632 function Indexed_Element
(Idx
: Pos
) return Node_Id
is
3633 Obj_Index
: constant Node_Id
:=
3636 Make_Attribute_Reference
(Loc
,
3637 Attribute_Name
=> Name_First
,
3638 Prefix
=> New_Copy_Tree
(Object
)),
3640 Make_Integer_Literal
(Loc
, Idx
- 1));
3642 return Make_Indexed_Component
(Loc
,
3643 Prefix
=> New_Copy_Tree
(Object
),
3644 Expressions
=> New_List
(Obj_Index
));
3645 end Indexed_Element
;
3647 -- Start of processing for Pattern_Match
3650 if Choice_Index
/= 0 and not Suppress_Choice_Index_Update
then
3651 pragma Assert
(Present
(Choice_Index_Decl
));
3653 -- Add Choice_Index update as a side effect of evaluating
3654 -- this condition and try again, this time suppressing
3655 -- Choice_Index update.
3657 return Make_Expression_With_Actions
(Loc
,
3658 Actions
=> New_List
(Update_Choice_Index
),
3660 PM
(Pattern
, Object
,
3661 Suppress_Choice_Index_Update
=> True));
3664 if Nkind
(Pattern
) in N_Has_Etype
3665 and then Is_Discrete_Type
(Etype
(Pattern
))
3666 and then Compile_Time_Known_Value
(Pattern
)
3671 if Is_Enumeration_Type
(Etype
(Pattern
)) then
3672 Val
:= Get_Enum_Lit_From_Pos
3673 (Etype
(Pattern
), Expr_Value
(Pattern
), Loc
);
3675 Val
:= Make_Integer_Literal
(Loc
, Expr_Value
(Pattern
));
3677 return Make_Op_Eq
(Loc
, Object
, Val
);
3681 case Nkind
(Pattern
) is
3686 if Is_Array_Type
(Etype
(Pattern
)) then
3688 -- Nonpositional aggregates currently unimplemented.
3689 -- We flag that case during analysis, so an assertion
3693 (Is_Empty_List
(Component_Associations
(Pattern
)));
3696 Agg_Length
: constant Node_Id
:=
3697 Make_Integer_Literal
(Loc
,
3698 List_Length
(Expressions
(Pattern
)));
3700 Obj_Length
: constant Node_Id
:=
3701 Make_Attribute_Reference
(Loc
,
3702 Attribute_Name
=> Name_Length
,
3703 Prefix
=> New_Copy_Tree
(Object
));
3705 Result
:= Make_Op_Eq
(Loc
,
3706 Left_Opnd
=> Obj_Length
,
3707 Right_Opnd
=> Agg_Length
);
3711 Expr
: Node_Id
:= First
(Expressions
(Pattern
));
3714 while Present
(Expr
) loop
3717 Left_Opnd
=> Result
,
3719 PM
(Pattern
=> Expr
,
3720 Object
=> Indexed_Element
(Idx
)));
3729 -- positional notation should have been normalized
3730 pragma Assert
(No
(Expressions
(Pattern
)));
3733 Component_Assoc
: Node_Id
3734 := First
(Component_Associations
(Pattern
));
3737 function Subobject
return Node_Id
is
3738 (Make_Selected_Component
(Loc
,
3739 Prefix
=> New_Copy_Tree
(Object
),
3740 Selector_Name
=> New_Occurrence_Of
3741 (Entity
(Choice
), Loc
)));
3743 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
3745 while Present
(Component_Assoc
) loop
3746 Choice
:= First
(Choices
(Component_Assoc
));
3747 while Present
(Choice
) loop
3749 (Is_Entity_Name
(Choice
)
3750 and then Ekind
(Entity
(Choice
))
3751 in E_Discriminant | E_Component
);
3753 if Box_Present
(Component_Assoc
) then
3754 -- Box matches anything
3757 (No
(Expression
(Component_Assoc
)));
3759 Result
:= Make_And_Then
(Loc
,
3760 Left_Opnd
=> Result
,
3765 Object
=> Subobject
));
3768 -- If this component association defines
3769 -- (in the case where the pattern matches)
3770 -- the value of a binding object, then
3771 -- prepend to the statement list for this
3772 -- alternative an assignment to the binding
3773 -- object. This assignment will be conditional
3774 -- if there is more than one choice.
3776 if Binding_Chars
(Component_Assoc
) /= No_Name
3778 Finish_Binding_Object_Declaration
3779 (Component_Assoc
=> Component_Assoc
,
3780 Subobject
=> Subobject
);
3786 Next
(Component_Assoc
);
3792 when N_String_Literal
=>
3793 return Result
: Node_Id
do
3795 Char_Type
: constant Entity_Id
:=
3796 Root_Type
(Component_Type
(Etype
(Pattern
)));
3798 -- If the component type is not a standard character
3799 -- type then this string lit should have already been
3800 -- transformed into an aggregate in
3801 -- Resolve_String_Literal.
3803 pragma Assert
(Is_Standard_Character_Type
(Char_Type
));
3805 Str
: constant String_Id
:= Strval
(Pattern
);
3806 Strlen
: constant Nat
:= String_Length
(Str
);
3808 Lit_Length
: constant Node_Id
:=
3809 Make_Integer_Literal
(Loc
, Strlen
);
3811 Obj_Length
: constant Node_Id
:=
3812 Make_Attribute_Reference
(Loc
,
3813 Attribute_Name
=> Name_Length
,
3814 Prefix
=> New_Copy_Tree
(Object
));
3816 Result
:= Make_Op_Eq
(Loc
,
3817 Left_Opnd
=> Obj_Length
,
3818 Right_Opnd
=> Lit_Length
);
3820 for Idx
in 1 .. Strlen
loop
3822 C
: constant Char_Code
:=
3823 Get_String_Char
(Str
, Idx
);
3824 Obj_Element
: constant Node_Id
:=
3825 Indexed_Element
(Idx
);
3828 Set_Character_Literal_Name
(C
);
3830 Make_Character_Literal
(Loc
,
3832 Char_Literal_Value
=> UI_From_CC
(C
));
3836 Left_Opnd
=> Result
,
3839 Left_Opnd
=> Obj_Element
,
3840 Right_Opnd
=> Char_Lit
));
3846 when N_Qualified_Expression
=>
3847 return Make_And_Then
(Loc
,
3848 Left_Opnd
=> Make_In
(Loc
,
3849 Left_Opnd
=> New_Copy_Tree
(Object
),
3850 Right_Opnd
=> New_Copy_Tree
(Subtype_Mark
(Pattern
))),
3852 PM
(Pattern
=> Expression
(Pattern
),
3853 Object
=> New_Copy_Tree
(Object
)));
3855 when N_Identifier | N_Expanded_Name
=>
3856 if Is_Type
(Entity
(Pattern
)) then
3857 return Make_In
(Loc
,
3858 Left_Opnd
=> New_Copy_Tree
(Object
),
3859 Right_Opnd
=> New_Occurrence_Of
3860 (Entity
(Pattern
), Loc
));
3861 elsif Ekind
(Entity
(Pattern
)) = E_Constant
then
3862 return PM
(Pattern
=>
3863 Expression
(Parent
(Entity
(Pattern
))),
3867 when N_Others_Choice
=>
3868 return New_Occurrence_Of
(Standard_True
, Loc
);
3870 when N_Type_Conversion
=>
3871 -- aggregate expansion sometimes introduces conversions
3872 if not Comes_From_Source
(Pattern
)
3873 and then Base_Type
(Etype
(Pattern
))
3874 = Base_Type
(Etype
(Expression
(Pattern
)))
3876 return PM
(Expression
(Pattern
), Object
);
3883 -- Avoid cascading errors
3884 pragma Assert
(Serious_Errors_Detected
> 0);
3885 return New_Occurrence_Of
(Standard_True
, Loc
);
3888 ---------------------------------------
3889 -- Top_Level_Pattern_Match_Condition --
3890 ---------------------------------------
3892 function Top_Level_Pattern_Match_Condition
3893 (Alt
: Node_Id
) return Node_Id
3895 Top_Level_Object
: constant Node_Id
:=
3896 New_Occurrence_Of
(Selector
, Loc
);
3898 Choices
: constant List_Id
:= Discrete_Choices
(Alt
);
3900 First_Choice
: constant Node_Id
:= First
(Choices
);
3901 Subsequent
: Node_Id
:= Next
(First_Choice
);
3903 Choice_Index
: Natural := 0;
3905 if Multidefined_Bindings
(Alt
) then
3909 return Result
: Node_Id
:=
3910 Pattern_Match
(Pattern
=> First_Choice
,
3911 Object
=> Top_Level_Object
,
3912 Choice_Index
=> Choice_Index
,
3915 while Present
(Subsequent
) loop
3916 if Choice_Index
/= 0 then
3917 Choice_Index
:= Choice_Index
+ 1;
3920 Result
:= Make_Or_Else
(Loc
,
3921 Left_Opnd
=> Result
,
3922 Right_Opnd
=> Pattern_Match
3923 (Pattern
=> Subsequent
,
3924 Object
=> Top_Level_Object
,
3925 Choice_Index
=> Choice_Index
,
3927 Subsequent
:= Next
(Subsequent
);
3930 end Top_Level_Pattern_Match_Condition
;
3932 function Elsif_Parts
return List_Id
;
3933 -- Process subsequent alternatives
3939 function Elsif_Parts
return List_Id
is
3940 Alt
: Node_Id
:= First_Alt
;
3941 Result
: constant List_Id
:= New_List
;
3947 Append
(Make_Elsif_Part
(Loc
,
3948 Condition
=> Top_Level_Pattern_Match_Condition
(Alt
),
3949 Then_Statements
=> Statements
(Alt
)),
3955 function Else_Statements
return List_Id
;
3956 -- Returns a "raise Constraint_Error" statement if
3957 -- exception propagate is permitted and No_List otherwise.
3959 ---------------------
3960 -- Else_Statements --
3961 ---------------------
3963 function Else_Statements
return List_Id
is
3965 if Restriction_Active
(No_Exception_Propagation
) then
3968 return New_List
(Make_Raise_Constraint_Error
(Loc
,
3969 Reason
=> CE_Invalid_Data
));
3971 end Else_Statements
;
3975 If_Stmt
: constant Node_Id
:=
3976 Make_If_Statement
(Loc
,
3977 Condition
=> Top_Level_Pattern_Match_Condition
(First_Alt
),
3978 Then_Statements
=> Statements
(First_Alt
),
3979 Elsif_Parts
=> Elsif_Parts
,
3980 Else_Statements
=> Else_Statements
);
3982 Declarations
: constant List_Id
:= New_List
(Selector_Decl
);
3984 -- Start of processing for Expand_General_Case_Statement
3987 if Present
(Choice_Index_Decl
) then
3988 Append_To
(Declarations
, Choice_Index_Decl
);
3991 return Make_Block_Statement
(Loc
,
3992 Declarations
=> Declarations
,
3993 Handled_Statement_Sequence
=>
3994 Make_Handled_Sequence_Of_Statements
(Loc
,
3995 Statements
=> New_List
(If_Stmt
)));
3996 end Expand_General_Case_Statement
;
3998 -- Start of processing for Expand_N_Case_Statement
4001 if Core_Extensions_Allowed
4002 and then not Is_Discrete_Type
(Etype
(Expr
))
4004 Rewrite
(N
, Expand_General_Case_Statement
);
4009 -- Check for the situation where we know at compile time which branch
4012 -- If the value is static but its subtype is predicated and the value
4013 -- does not obey the predicate, the value is marked non-static, and
4014 -- there can be no corresponding static alternative. In that case we
4015 -- replace the case statement with an exception, regardless of whether
4016 -- assertions are enabled or not, unless predicates are ignored.
4018 if Compile_Time_Known_Value
(Expr
)
4019 and then Has_Predicates
(Etype
(Expr
))
4020 and then not Predicates_Ignored
(Etype
(Expr
))
4021 and then not Is_OK_Static_Expression
(Expr
)
4024 Make_Raise_Constraint_Error
(Loc
, Reason
=> CE_Invalid_Data
));
4028 elsif Compile_Time_Known_Value
(Expr
)
4029 and then (not Has_Predicates
(Etype
(Expr
))
4030 or else Is_Static_Expression
(Expr
))
4032 Alt
:= Find_Static_Alternative
(N
);
4034 -- Do not consider controlled objects found in a case statement which
4035 -- actually models a case expression because their early finalization
4036 -- will affect the result of the expression.
4038 if not From_Conditional_Expression
(N
) then
4039 Process_Statements_For_Controlled_Objects
(Alt
);
4042 -- Move statements from this alternative after the case statement.
4043 -- They are already analyzed, so will be skipped by the analyzer.
4045 Insert_List_After
(N
, Statements
(Alt
));
4047 -- That leaves the case statement as a shell. So now we can kill all
4048 -- other alternatives in the case statement.
4050 Kill_Dead_Code
(Expression
(N
));
4056 -- Loop through case alternatives, skipping pragmas, and skipping
4057 -- the one alternative that we select (and therefore retain).
4059 Dead_Alt
:= First
(Alternatives
(N
));
4060 while Present
(Dead_Alt
) loop
4062 and then Nkind
(Dead_Alt
) = N_Case_Statement_Alternative
4064 Kill_Dead_Code
(Statements
(Dead_Alt
), Warn_On_Deleted_Code
);
4071 Rewrite
(N
, Make_Null_Statement
(Loc
));
4075 -- Here if the choice is not determined at compile time
4078 Last_Alt
: constant Node_Id
:= Last
(Alternatives
(N
));
4080 Others_Present
: Boolean;
4081 Others_Node
: Node_Id
;
4083 Then_Stms
: List_Id
;
4084 Else_Stms
: List_Id
;
4087 if Nkind
(First
(Discrete_Choices
(Last_Alt
))) = N_Others_Choice
then
4088 Others_Present
:= True;
4089 Others_Node
:= Last_Alt
;
4091 Others_Present
:= False;
4094 -- First step is to worry about possible invalid argument. The RM
4095 -- requires (RM 4.5.7 (21/3) and 5.4 (13)) that if the result is
4096 -- invalid (e.g. it is outside the base range), then Constraint_Error
4099 -- Case of validity check required (validity checks are on, the
4100 -- expression is not known to be valid, and the case statement
4101 -- comes from source -- no need to validity check internally
4102 -- generated case statements).
4104 if Validity_Check_Default
4105 and then not Predicates_Ignored
(Etype
(Expr
))
4107 -- Recognize the simple case where Expr is an object reference
4108 -- and the case statement is directly preceded by an
4109 -- "if Obj'Valid then": in this case, do not emit another validity
4113 Check_Validity
: Boolean := True;
4116 if Nkind
(Expr
) = N_Identifier
4117 and then Nkind
(Parent
(N
)) = N_If_Statement
4118 and then Nkind
(Original_Node
(Condition
(Parent
(N
))))
4119 = N_Attribute_Reference
4120 and then No
(Prev
(N
))
4122 Attr
:= Original_Node
(Condition
(Parent
(N
)));
4124 if Attribute_Name
(Attr
) = Name_Valid
4125 and then Nkind
(Prefix
(Attr
)) = N_Identifier
4126 and then Entity
(Prefix
(Attr
)) = Entity
(Expr
)
4128 Check_Validity
:= False;
4132 if Check_Validity
then
4133 Ensure_Valid
(Expr
);
4138 -- If there is only a single alternative, just replace it with the
4139 -- sequence of statements since obviously that is what is going to
4140 -- be executed in all cases, except if it is the node to be wrapped
4141 -- by a transient scope, because this would cause the sequence of
4142 -- statements to be leaked out of the transient scope.
4144 Len
:= List_Length
(Alternatives
(N
));
4147 and then not (Scope_Is_Transient
and then Node_To_Be_Wrapped
= N
)
4150 -- We still need to evaluate the expression if it has any side
4153 Remove_Side_Effects
(Expression
(N
));
4154 Alt
:= First
(Alternatives
(N
));
4156 -- Do not consider controlled objects found in a case statement
4157 -- which actually models a case expression because their early
4158 -- finalization will affect the result of the expression.
4160 if not From_Conditional_Expression
(N
) then
4161 Process_Statements_For_Controlled_Objects
(Alt
);
4164 Insert_List_After
(N
, Statements
(Alt
));
4166 -- That leaves the case statement as a shell. The alternative that
4167 -- will be executed is reset to a null list. So now we can kill
4168 -- the entire case statement.
4170 Kill_Dead_Code
(Expression
(N
));
4171 Rewrite
(N
, Make_Null_Statement
(Loc
));
4174 -- An optimization. If there are only two alternatives, and only
4175 -- a single choice, then rewrite the whole case statement as an
4176 -- if statement, since this can result in subsequent optimizations.
4177 -- This helps not only with case statements in the source of a
4178 -- simple form, but also with generated code (discriminant check
4179 -- functions in particular).
4181 -- Note: it is OK to do this before expanding out choices for any
4182 -- static predicates, since the if statement processing will handle
4183 -- the static predicate case fine.
4186 Chlist
:= Discrete_Choices
(First
(Alternatives
(N
)));
4188 if List_Length
(Chlist
) = 1 then
4189 Choice
:= First
(Chlist
);
4191 Then_Stms
:= Statements
(First
(Alternatives
(N
)));
4192 Else_Stms
:= Statements
(Last
(Alternatives
(N
)));
4194 -- For TRUE, generate "expression", not expression = true
4196 if Nkind
(Choice
) = N_Identifier
4197 and then Entity
(Choice
) = Standard_True
4199 Cond
:= Expression
(N
);
4201 -- For FALSE, generate "expression" and switch then/else
4203 elsif Nkind
(Choice
) = N_Identifier
4204 and then Entity
(Choice
) = Standard_False
4206 Cond
:= Expression
(N
);
4207 Else_Stms
:= Statements
(First
(Alternatives
(N
)));
4208 Then_Stms
:= Statements
(Last
(Alternatives
(N
)));
4210 -- For a range, generate "expression in range"
4212 elsif Nkind
(Choice
) = N_Range
4213 or else (Nkind
(Choice
) = N_Attribute_Reference
4214 and then Attribute_Name
(Choice
) = Name_Range
)
4215 or else (Is_Entity_Name
(Choice
)
4216 and then Is_Type
(Entity
(Choice
)))
4220 Left_Opnd
=> Expression
(N
),
4221 Right_Opnd
=> Relocate_Node
(Choice
));
4223 -- A subtype indication is not a legal operator in a membership
4224 -- test, so retrieve its range.
4226 elsif Nkind
(Choice
) = N_Subtype_Indication
then
4229 Left_Opnd
=> Expression
(N
),
4232 (Range_Expression
(Constraint
(Choice
))));
4234 -- For any other subexpression "expression = value"
4239 Left_Opnd
=> Expression
(N
),
4240 Right_Opnd
=> Relocate_Node
(Choice
));
4243 -- Now rewrite the case as an IF
4246 Make_If_Statement
(Loc
,
4248 Then_Statements
=> Then_Stms
,
4249 Else_Statements
=> Else_Stms
));
4251 -- The rewritten if statement needs to inherit whether the
4252 -- case statement was expanded from a conditional expression,
4253 -- for proper handling of nested controlled objects.
4255 Set_From_Conditional_Expression
(N
, From_Cond_Expr
);
4263 -- If the last alternative is not an Others choice, replace it with
4264 -- an N_Others_Choice. Note that we do not bother to call Analyze on
4265 -- the modified case statement, since it's only effect would be to
4266 -- compute the contents of the Others_Discrete_Choices which is not
4267 -- needed by the back end anyway.
4269 -- The reason for this is that the back end always needs some default
4270 -- for a switch, so if we have not supplied one in the processing
4271 -- above for validity checking, then we need to supply one here.
4273 if not Others_Present
then
4274 Others_Node
:= Make_Others_Choice
(Sloc
(Last_Alt
));
4276 -- If Predicates_Ignored is true the value does not satisfy the
4277 -- predicate, and there is no Others choice, Constraint_Error
4278 -- must be raised (RM 4.5.7 (21/3) and 5.4 (13)).
4280 if Predicates_Ignored
(Etype
(Expr
)) then
4282 Except
: constant Node_Id
:=
4283 Make_Raise_Constraint_Error
(Loc
,
4284 Reason
=> CE_Invalid_Data
);
4285 New_Alt
: constant Node_Id
:=
4286 Make_Case_Statement_Alternative
(Loc
,
4287 Discrete_Choices
=> New_List
(
4288 Make_Others_Choice
(Loc
)),
4289 Statements
=> New_List
(Except
));
4292 Append
(New_Alt
, Alternatives
(N
));
4293 Analyze_And_Resolve
(Except
);
4297 Set_Others_Discrete_Choices
4298 (Others_Node
, Discrete_Choices
(Last_Alt
));
4299 Set_Discrete_Choices
(Last_Alt
, New_List
(Others_Node
));
4304 -- Deal with possible declarations of controlled objects, and also
4305 -- with rewriting choice sequences for static predicate references.
4307 Alt
:= First_Non_Pragma
(Alternatives
(N
));
4308 while Present
(Alt
) loop
4310 -- Do not consider controlled objects found in a case statement
4311 -- which actually models a case expression because their early
4312 -- finalization will affect the result of the expression.
4314 if not From_Conditional_Expression
(N
) then
4315 Process_Statements_For_Controlled_Objects
(Alt
);
4318 if Has_SP_Choice
(Alt
) then
4319 Expand_Static_Predicates_In_Choices
(Alt
);
4322 Next_Non_Pragma
(Alt
);
4325 end Expand_N_Case_Statement
;
4327 -----------------------------
4328 -- Expand_N_Exit_Statement --
4329 -----------------------------
4331 -- The only processing required is to deal with a possible C/Fortran
4332 -- boolean value used as the condition for the exit statement.
4334 procedure Expand_N_Exit_Statement
(N
: Node_Id
) is
4336 Adjust_Condition
(Condition
(N
));
4337 end Expand_N_Exit_Statement
;
4339 ----------------------------------
4340 -- Expand_Formal_Container_Loop --
4341 ----------------------------------
4343 procedure Expand_Formal_Container_Loop
(N
: Node_Id
) is
4344 Loc
: constant Source_Ptr
:= Sloc
(N
);
4345 Isc
: constant Node_Id
:= Iteration_Scheme
(N
);
4346 I_Spec
: constant Node_Id
:= Iterator_Specification
(Isc
);
4347 Cursor
: constant Entity_Id
:= Defining_Identifier
(I_Spec
);
4348 Container
: constant Node_Id
:= Entity
(Name
(I_Spec
));
4349 Stats
: constant List_Id
:= Statements
(N
);
4352 Init_Decl
: Node_Id
;
4353 Init_Name
: Entity_Id
;
4357 -- The expansion of a formal container loop resembles the one for Ada
4358 -- containers. The only difference is that the primitives mention the
4359 -- domain of iteration explicitly, and function First applied to the
4360 -- container yields a cursor directly.
4362 -- Cursor : Cursor_type := First (Container);
4363 -- while Has_Element (Cursor, Container) loop
4364 -- <original loop statements>
4365 -- Cursor := Next (Container, Cursor);
4368 Build_Formal_Container_Iteration
4369 (N
, Container
, Cursor
, Init_Decl
, Advance
, New_Loop
);
4371 Append_To
(Stats
, Advance
);
4373 -- Build a block to capture declaration of the cursor
4376 Make_Block_Statement
(Loc
,
4377 Declarations
=> New_List
(Init_Decl
),
4378 Handled_Statement_Sequence
=>
4379 Make_Handled_Sequence_Of_Statements
(Loc
,
4380 Statements
=> New_List
(New_Loop
))));
4382 -- The loop parameter is declared by an object declaration, but within
4383 -- the loop we must prevent user assignments to it, so we analyze the
4384 -- declaration and reset the entity kind, before analyzing the rest of
4387 Analyze
(Init_Decl
);
4388 Init_Name
:= Defining_Identifier
(Init_Decl
);
4389 Reinit_Field_To_Zero
(Init_Name
, F_Has_Initial_Value
,
4390 Old_Ekind
=> (E_Variable
=> True, others => False));
4391 Reinit_Field_To_Zero
(Init_Name
, F_Is_Elaboration_Checks_OK_Id
);
4392 Reinit_Field_To_Zero
(Init_Name
, F_Is_Elaboration_Warnings_OK_Id
);
4393 Reinit_Field_To_Zero
(Init_Name
, F_SPARK_Pragma
);
4394 Reinit_Field_To_Zero
(Init_Name
, F_SPARK_Pragma_Inherited
);
4395 Mutate_Ekind
(Init_Name
, E_Loop_Parameter
);
4397 -- The cursor was marked as a loop parameter to prevent user assignments
4398 -- to it, however this renders the advancement step illegal as it is not
4399 -- possible to change the value of a constant. Flag the advancement step
4400 -- as a legal form of assignment to remedy this side effect.
4402 Set_Assignment_OK
(Name
(Advance
));
4405 -- Because we have to analyze the initial declaration of the loop
4406 -- parameter multiple times its scope is incorrectly set at this point
4407 -- to the one surrounding the block statement - so set the scope
4408 -- manually to be the actual block statement, and indicate that it is
4409 -- not visible after the block has been analyzed.
4411 Set_Scope
(Init_Name
, Entity
(Identifier
(N
)));
4412 Set_Is_Immediately_Visible
(Init_Name
, False);
4413 end Expand_Formal_Container_Loop
;
4415 ------------------------------------------
4416 -- Expand_Formal_Container_Element_Loop --
4417 ------------------------------------------
4419 procedure Expand_Formal_Container_Element_Loop
(N
: Node_Id
) is
4420 Loc
: constant Source_Ptr
:= Sloc
(N
);
4421 Isc
: constant Node_Id
:= Iteration_Scheme
(N
);
4422 I_Spec
: constant Node_Id
:= Iterator_Specification
(Isc
);
4423 Element
: constant Entity_Id
:= Defining_Identifier
(I_Spec
);
4424 Container
: constant Node_Id
:= Entity
(Name
(I_Spec
));
4425 Container_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
4426 Stats
: constant List_Id
:= Statements
(N
);
4428 Cursor
: constant Entity_Id
:=
4429 Make_Defining_Identifier
(Loc
,
4430 Chars
=> New_External_Name
(Chars
(Element
), 'C'));
4431 Elmt_Decl
: Node_Id
;
4433 Element_Op
: constant Entity_Id
:=
4434 Get_Iterable_Type_Primitive
(Container_Typ
, Name_Element
);
4441 -- For an element iterator, the Element aspect must be present,
4442 -- (this is checked during analysis).
4444 -- We create a block to hold a variable declaration initialized with
4445 -- a call to Element, and generate:
4447 -- Cursor : Cursor_Type := First (Container);
4448 -- while Has_Element (Cursor, Container) loop
4450 -- Elmt : Element_Type := Element (Container, Cursor);
4452 -- <original loop statements>
4453 -- Cursor := Next (Container, Cursor);
4457 Build_Formal_Container_Iteration
4458 (N
, Container
, Cursor
, Init
, Advance
, New_Loop
);
4459 Append_To
(Stats
, Advance
);
4461 Mutate_Ekind
(Cursor
, E_Variable
);
4462 Insert_Action
(N
, Init
);
4464 -- The loop parameter is declared by an object declaration, but within
4465 -- the loop we must prevent user assignments to it; the following flag
4466 -- accomplishes that.
4468 Set_Is_Loop_Parameter
(Element
);
4470 -- Declaration for Element
4473 Make_Object_Declaration
(Loc
,
4474 Defining_Identifier
=> Element
,
4475 Object_Definition
=> New_Occurrence_Of
(Etype
(Element_Op
), Loc
));
4477 Set_Expression
(Elmt_Decl
,
4478 Make_Function_Call
(Loc
,
4479 Name
=> New_Occurrence_Of
(Element_Op
, Loc
),
4480 Parameter_Associations
=> New_List
(
4481 Convert_To_Iterable_Type
(Container
, Loc
),
4482 New_Occurrence_Of
(Cursor
, Loc
))));
4484 Set_Statements
(New_Loop
,
4486 (Make_Block_Statement
(Loc
,
4487 Declarations
=> New_List
(Elmt_Decl
),
4488 Handled_Statement_Sequence
=>
4489 Make_Handled_Sequence_Of_Statements
(Loc
,
4490 Statements
=> Stats
))));
4492 -- The element is only modified in expanded code, so it appears as
4493 -- unassigned to the warning machinery. We must suppress this spurious
4494 -- warning explicitly.
4496 Set_Warnings_Off
(Element
);
4498 Rewrite
(N
, New_Loop
);
4500 end Expand_Formal_Container_Element_Loop
;
4502 ----------------------------------
4503 -- Expand_N_Goto_When_Statement --
4504 ----------------------------------
4506 procedure Expand_N_Goto_When_Statement
(N
: Node_Id
) is
4507 Loc
: constant Source_Ptr
:= Sloc
(N
);
4510 Make_If_Statement
(Loc
,
4511 Condition
=> Condition
(N
),
4512 Then_Statements
=> New_List
(
4513 Make_Goto_Statement
(Loc
,
4514 Name
=> Name
(N
)))));
4517 end Expand_N_Goto_When_Statement
;
4519 ---------------------------
4520 -- Expand_N_If_Statement --
4521 ---------------------------
4523 -- First we deal with the case of C and Fortran convention boolean values,
4524 -- with zero/nonzero semantics.
4526 -- Second, we deal with the obvious rewriting for the cases where the
4527 -- condition of the IF is known at compile time to be True or False.
4529 -- Third, we remove elsif parts which have non-empty Condition_Actions and
4530 -- rewrite as independent if statements. For example:
4541 -- <<condition actions of y>>
4547 -- This rewriting is needed if at least one elsif part has a non-empty
4548 -- Condition_Actions list. We also do the same processing if there is a
4549 -- constant condition in an elsif part (in conjunction with the first
4550 -- processing step mentioned above, for the recursive call made to deal
4551 -- with the created inner if, this deals with properly optimizing the
4552 -- cases of constant elsif conditions).
4554 procedure Expand_N_If_Statement
(N
: Node_Id
) is
4555 Loc
: constant Source_Ptr
:= Sloc
(N
);
4560 Warn_If_Deleted
: constant Boolean :=
4561 Warn_On_Deleted_Code
and then Comes_From_Source
(N
);
4562 -- Indicates whether we want warnings when we delete branches of the
4563 -- if statement based on constant condition analysis. We never want
4564 -- these warnings for expander generated code.
4567 -- Do not consider controlled objects found in an if statement which
4568 -- actually models an if expression because their early finalization
4569 -- will affect the result of the expression.
4571 if not From_Conditional_Expression
(N
) then
4572 Process_Statements_For_Controlled_Objects
(N
);
4575 Adjust_Condition
(Condition
(N
));
4577 -- The following loop deals with constant conditions for the IF. We
4578 -- need a loop because as we eliminate False conditions, we grab the
4579 -- first elsif condition and use it as the primary condition.
4581 while Compile_Time_Known_Value
(Condition
(N
)) loop
4583 -- If condition is True, we can simply rewrite the if statement now
4584 -- by replacing it by the series of then statements.
4586 if Is_True
(Expr_Value
(Condition
(N
))) then
4588 -- All the else parts can be killed
4590 Kill_Dead_Code
(Elsif_Parts
(N
), Warn_If_Deleted
);
4591 Kill_Dead_Code
(Else_Statements
(N
), Warn_If_Deleted
);
4593 Hed
:= Remove_Head
(Then_Statements
(N
));
4594 Insert_List_After
(N
, Then_Statements
(N
));
4598 -- If condition is False, then we can delete the condition and
4599 -- the Then statements
4602 -- We do not delete the condition if constant condition warnings
4603 -- are enabled, since otherwise we end up deleting the desired
4604 -- warning. Of course the backend will get rid of this True/False
4605 -- test anyway, so nothing is lost here.
4607 if not Constant_Condition_Warnings
then
4608 Kill_Dead_Code
(Condition
(N
));
4611 Kill_Dead_Code
(Then_Statements
(N
), Warn_If_Deleted
);
4613 -- If there are no elsif statements, then we simply replace the
4614 -- entire if statement by the sequence of else statements.
4616 if No
(Elsif_Parts
(N
)) then
4617 if Is_Empty_List
(Else_Statements
(N
)) then
4619 Make_Null_Statement
(Sloc
(N
)));
4621 Hed
:= Remove_Head
(Else_Statements
(N
));
4622 Insert_List_After
(N
, Else_Statements
(N
));
4628 -- If there are elsif statements, the first of them becomes the
4629 -- if/then section of the rebuilt if statement This is the case
4630 -- where we loop to reprocess this copied condition.
4633 Hed
:= Remove_Head
(Elsif_Parts
(N
));
4634 Insert_Actions
(N
, Condition_Actions
(Hed
));
4635 Set_Condition
(N
, Condition
(Hed
));
4636 Set_Then_Statements
(N
, Then_Statements
(Hed
));
4638 -- Hed might have been captured as the condition determining
4639 -- the current value for an entity. Now it is detached from
4640 -- the tree, so a Current_Value pointer in the condition might
4641 -- need to be updated.
4643 Set_Current_Value_Condition
(N
);
4645 if Is_Empty_List
(Elsif_Parts
(N
)) then
4646 Set_Elsif_Parts
(N
, No_List
);
4652 -- Loop through elsif parts, dealing with constant conditions and
4653 -- possible condition actions that are present.
4655 E
:= First
(Elsif_Parts
(N
));
4656 while Present
(E
) loop
4658 -- Do not consider controlled objects found in an if statement which
4659 -- actually models an if expression because their early finalization
4660 -- will affect the result of the expression.
4662 if not From_Conditional_Expression
(N
) then
4663 Process_Statements_For_Controlled_Objects
(E
);
4666 Adjust_Condition
(Condition
(E
));
4668 -- If there are condition actions, then rewrite the if statement as
4669 -- indicated above. We also do the same rewrite for a True or False
4670 -- condition. The further processing of this constant condition is
4671 -- then done by the recursive call to expand the newly created if
4674 if Present
(Condition_Actions
(E
))
4675 or else Compile_Time_Known_Value
(Condition
(E
))
4678 Make_If_Statement
(Sloc
(E
),
4679 Condition
=> Condition
(E
),
4680 Then_Statements
=> Then_Statements
(E
),
4681 Elsif_Parts
=> No_List
,
4682 Else_Statements
=> Else_Statements
(N
));
4684 -- Elsif parts for new if come from remaining elsif's of parent
4686 while Present
(Next
(E
)) loop
4687 if No
(Elsif_Parts
(New_If
)) then
4688 Set_Elsif_Parts
(New_If
, New_List
);
4691 Append
(Remove_Next
(E
), Elsif_Parts
(New_If
));
4694 Set_Else_Statements
(N
, New_List
(New_If
));
4696 Insert_List_Before
(New_If
, Condition_Actions
(E
));
4700 if Is_Empty_List
(Elsif_Parts
(N
)) then
4701 Set_Elsif_Parts
(N
, No_List
);
4706 -- Note this is not an implicit if statement, since it is part of
4707 -- an explicit if statement in the source (or of an implicit if
4708 -- statement that has already been tested). We set the flag after
4709 -- calling Analyze to avoid generating extra warnings specific to
4710 -- pure if statements, however (see Sem_Ch5.Analyze_If_Statement).
4712 Preserve_Comes_From_Source
(New_If
, N
);
4715 -- No special processing for that elsif part, move to next
4722 -- Some more optimizations applicable if we still have an IF statement
4724 if Nkind
(N
) /= N_If_Statement
then
4728 -- Another optimization, special cases that can be simplified
4730 -- if expression then
4731 -- return [standard.]true;
4733 -- return [standard.]false;
4736 -- can be changed to:
4738 -- return expression;
4742 -- if expression then
4743 -- return [standard.]false;
4745 -- return [standard.]true;
4748 -- can be changed to:
4750 -- return not (expression);
4752 -- Do these optimizations only for internally generated code and only
4753 -- when -fpreserve-control-flow isn't set, to preserve the original
4754 -- source control flow.
4756 if not Comes_From_Source
(N
)
4757 and then not Opt
.Suppress_Control_Flow_Optimizations
4758 and then Nkind
(N
) = N_If_Statement
4759 and then No
(Elsif_Parts
(N
))
4760 and then List_Length
(Then_Statements
(N
)) = 1
4761 and then List_Length
(Else_Statements
(N
)) = 1
4764 Then_Stm
: constant Node_Id
:= First
(Then_Statements
(N
));
4765 Else_Stm
: constant Node_Id
:= First
(Else_Statements
(N
));
4767 Then_Expr
: Node_Id
;
4768 Else_Expr
: Node_Id
;
4771 if Nkind
(Then_Stm
) = N_Simple_Return_Statement
4773 Nkind
(Else_Stm
) = N_Simple_Return_Statement
4775 Then_Expr
:= Expression
(Then_Stm
);
4776 Else_Expr
:= Expression
(Else_Stm
);
4778 if Nkind
(Then_Expr
) in N_Expanded_Name | N_Identifier
4780 Nkind
(Else_Expr
) in N_Expanded_Name | N_Identifier
4782 if Entity
(Then_Expr
) = Standard_True
4783 and then Entity
(Else_Expr
) = Standard_False
4786 Make_Simple_Return_Statement
(Loc
,
4787 Expression
=> Relocate_Node
(Condition
(N
))));
4790 elsif Entity
(Then_Expr
) = Standard_False
4791 and then Entity
(Else_Expr
) = Standard_True
4794 Make_Simple_Return_Statement
(Loc
,
4797 Right_Opnd
=> Relocate_Node
(Condition
(N
)))));
4804 end Expand_N_If_Statement
;
4806 --------------------------
4807 -- Expand_Iterator_Loop --
4808 --------------------------
4810 procedure Expand_Iterator_Loop
(N
: Node_Id
) is
4811 Isc
: constant Node_Id
:= Iteration_Scheme
(N
);
4812 I_Spec
: constant Node_Id
:= Iterator_Specification
(Isc
);
4814 Container
: constant Node_Id
:= Name
(I_Spec
);
4815 Container_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
4818 -- Processing for arrays
4820 if Is_Array_Type
(Container_Typ
) then
4821 pragma Assert
(Of_Present
(I_Spec
));
4822 Expand_Iterator_Loop_Over_Array
(N
);
4824 elsif Has_Aspect
(Container_Typ
, Aspect_Iterable
) then
4825 if Of_Present
(I_Spec
) then
4826 Expand_Formal_Container_Element_Loop
(N
);
4828 Expand_Formal_Container_Loop
(N
);
4831 -- Processing for containers
4834 Expand_Iterator_Loop_Over_Container
4835 (N
, I_Spec
, Container
, Container_Typ
);
4837 end Expand_Iterator_Loop
;
4839 -------------------------------------
4840 -- Expand_Iterator_Loop_Over_Array --
4841 -------------------------------------
4843 procedure Expand_Iterator_Loop_Over_Array
(N
: Node_Id
) is
4844 Isc
: constant Node_Id
:= Iteration_Scheme
(N
);
4845 I_Spec
: constant Node_Id
:= Iterator_Specification
(Isc
);
4846 Array_Node
: constant Node_Id
:= Name
(I_Spec
);
4847 Array_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Array_Node
));
4848 Array_Dim
: constant Pos
:= Number_Dimensions
(Array_Typ
);
4849 Id
: constant Entity_Id
:= Defining_Identifier
(I_Spec
);
4850 Loc
: constant Source_Ptr
:= Sloc
(Isc
);
4851 Stats
: List_Id
:= Statements
(N
);
4852 Core_Loop
: Node_Id
;
4855 Iterator
: Entity_Id
;
4858 if Present
(Iterator_Filter
(I_Spec
)) then
4859 pragma Assert
(Ada_Version
>= Ada_2022
);
4860 Stats
:= New_List
(Make_If_Statement
(Loc
,
4861 Condition
=> Iterator_Filter
(I_Spec
),
4862 Then_Statements
=> Stats
));
4865 -- for Element of Array loop
4867 -- It requires an internally generated cursor to iterate over the array
4869 pragma Assert
(Of_Present
(I_Spec
));
4871 Iterator
:= Make_Temporary
(Loc
, 'C');
4874 -- Element : Component_Type renames Array (Iterator);
4875 -- Iterator is the index value, or a list of index values
4876 -- in the case of a multidimensional array.
4879 Make_Indexed_Component
(Loc
,
4880 Prefix
=> New_Copy_Tree
(Array_Node
),
4881 Expressions
=> New_List
(New_Occurrence_Of
(Iterator
, Loc
)));
4883 -- Propagate the original node to the copy since the analysis of the
4884 -- following object renaming declaration relies on the original node.
4886 Set_Original_Node
(Prefix
(Ind_Comp
), Original_Node
(Array_Node
));
4889 Make_Object_Renaming_Declaration
(Loc
,
4890 Defining_Identifier
=> Id
,
4892 New_Occurrence_Of
(Component_Type
(Array_Typ
), Loc
),
4895 -- Mark the loop variable as needing debug info, so that expansion
4896 -- of the renaming will result in Materialize_Entity getting set via
4897 -- Debug_Renaming_Declaration. (This setting is needed here because
4898 -- the setting in Freeze_Entity comes after the expansion, which is
4901 Set_Debug_Info_Needed
(Id
);
4905 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
4906 -- Element : Component_Type renames Array (Iterator);
4907 -- <original loop statements>
4910 -- If this is an iteration over a multidimensional array, the
4911 -- innermost loop is over the last dimension in Ada, and over
4912 -- the first dimension in Fortran.
4914 if Convention
(Array_Typ
) = Convention_Fortran
then
4921 Make_Loop_Statement
(Sloc
(N
),
4923 Make_Iteration_Scheme
(Loc
,
4924 Loop_Parameter_Specification
=>
4925 Make_Loop_Parameter_Specification
(Loc
,
4926 Defining_Identifier
=> Iterator
,
4927 Discrete_Subtype_Definition
=>
4928 Make_Attribute_Reference
(Loc
,
4929 Prefix
=> New_Copy_Tree
(Array_Node
),
4930 Attribute_Name
=> Name_Range
,
4931 Expressions
=> New_List
(
4932 Make_Integer_Literal
(Loc
, Dim1
))),
4933 Reverse_Present
=> Reverse_Present
(I_Spec
))),
4934 Statements
=> Stats
,
4935 End_Label
=> Empty
);
4937 -- Processing for multidimensional array. The body of each loop is
4938 -- a loop over a previous dimension, going in decreasing order in Ada
4939 -- and in increasing order in Fortran.
4941 if Array_Dim
> 1 then
4942 for Dim
in 1 .. Array_Dim
- 1 loop
4943 if Convention
(Array_Typ
) = Convention_Fortran
then
4946 Dim1
:= Array_Dim
- Dim
;
4949 Iterator
:= Make_Temporary
(Loc
, 'C');
4951 -- Generate the dimension loops starting from the innermost one
4953 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
4958 Make_Loop_Statement
(Sloc
(N
),
4960 Make_Iteration_Scheme
(Loc
,
4961 Loop_Parameter_Specification
=>
4962 Make_Loop_Parameter_Specification
(Loc
,
4963 Defining_Identifier
=> Iterator
,
4964 Discrete_Subtype_Definition
=>
4965 Make_Attribute_Reference
(Loc
,
4966 Prefix
=> New_Copy_Tree
(Array_Node
),
4967 Attribute_Name
=> Name_Range
,
4968 Expressions
=> New_List
(
4969 Make_Integer_Literal
(Loc
, Dim1
))),
4970 Reverse_Present
=> Reverse_Present
(I_Spec
))),
4971 Statements
=> New_List
(Core_Loop
),
4972 End_Label
=> Empty
);
4974 -- Update the previously created object renaming declaration with
4975 -- the new iterator, by adding the index of the next loop to the
4976 -- indexed component, in the order that corresponds to the
4979 if Convention
(Array_Typ
) = Convention_Fortran
then
4980 Append_To
(Expressions
(Ind_Comp
),
4981 New_Occurrence_Of
(Iterator
, Loc
));
4983 Prepend_To
(Expressions
(Ind_Comp
),
4984 New_Occurrence_Of
(Iterator
, Loc
));
4989 -- Inherit the loop identifier from the original loop. This ensures that
4990 -- the scope stack is consistent after the rewriting.
4992 if Present
(Identifier
(N
)) then
4993 Set_Identifier
(Core_Loop
, Relocate_Node
(Identifier
(N
)));
4996 Rewrite
(N
, Core_Loop
);
4998 end Expand_Iterator_Loop_Over_Array
;
5000 -----------------------------------------
5001 -- Expand_Iterator_Loop_Over_Container --
5002 -----------------------------------------
5004 -- For a 'for ... in' loop, such as:
5006 -- for Cursor in Iterator_Function (...) loop
5012 -- Iter : Iterator_Type := Iterator_Function (...);
5013 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
5014 -- while Has_Element (Cursor) loop
5017 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
5020 -- For a 'for ... of' loop, such as:
5022 -- for X of Container loop
5026 -- the RM implies the generation of:
5028 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
5029 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
5030 -- while Has_Element (Cursor) loop
5032 -- X : Element_Type renames Element (Cursor).Element.all;
5033 -- -- or Constant_Element
5037 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
5040 -- In the general case, we do what the RM says. However, the operations
5041 -- Element and Iter.Next are slow, which is bad inside a loop, because they
5042 -- involve dispatching via interfaces, secondary stack manipulation,
5043 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
5044 -- predefined containers, we use an equivalent but optimized expansion.
5046 -- In the optimized case, we make use of these:
5048 -- procedure _Next (Position : in out Cursor); -- instead of Iter.Next
5049 -- (or _Previous for reverse loops)
5051 -- function Pseudo_Reference
5052 -- (Container : aliased Vector'Class) return Reference_Control_Type;
5054 -- type Element_Access is access all Element_Type;
5056 -- function Get_Element_Access
5057 -- (Position : Cursor) return not null Element_Access;
5059 -- Next is declared in the visible part of the container packages.
5060 -- The other three are added in the private part. (We're not supposed to
5061 -- pollute the namespace for clients. The compiler has no trouble breaking
5062 -- privacy to call things in the private part of an instance.)
5064 -- Note that Next and Previous are renamed as _Next and _Previous with
5065 -- leading underscores. Leading underscores are illegal in Ada, but we
5066 -- allow them in the run-time library. This allows us to avoid polluting
5067 -- the user-visible namespaces.
5071 -- for X of My_Vector loop
5072 -- X.Count := X.Count + 1;
5076 -- The compiler will generate:
5078 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector);
5079 -- -- Reversible_Iterator is an interface. Iterate is the
5080 -- -- Default_Iterator aspect of Vector. This increments Lock,
5081 -- -- disallowing tampering with cursors. Unfortunately, it does not
5082 -- -- increment Busy. The result of Iterate is Limited_Controlled;
5083 -- -- finalization will decrement Lock. This is a build-in-place
5084 -- -- dispatching call to Iterate.
5086 -- Cur : Cursor := First (Iter); -- or Last
5087 -- -- Dispatching call via interface.
5089 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
5090 -- -- Pseudo_Reference increments Busy, to detect tampering with
5091 -- -- elements, as required by RM. Also redundantly increment
5092 -- -- Lock. Finalization of Control will decrement both Busy and
5093 -- -- Lock. Pseudo_Reference returns a record containing a pointer to
5094 -- -- My_Vector, used by Finalize.
5096 -- -- Control is not used below, except to finalize it -- it's purely
5097 -- -- an RAII thing. This is needed because we are eliminating the
5098 -- -- call to Reference within the loop.
5100 -- while Has_Element (Cur) loop
5102 -- X : My_Element renames Get_Element_Access (Cur).all;
5103 -- -- Get_Element_Access returns a pointer to the element
5104 -- -- designated by Cur. No dispatching here, and no horsing
5105 -- -- around with access discriminants. This is instead of the
5108 -- -- X : My_Element renames Reference (Cur).Element.all;
5110 -- -- which creates a controlled object.
5112 -- -- Any attempt to tamper with My_Vector here in the loop
5113 -- -- will correctly raise Program_Error, because of the
5116 -- X.Count := X.Count + 1;
5119 -- _Next (Cur); -- or _Previous
5120 -- -- This is instead of "Cur := Next (Iter, Cur);"
5122 -- -- No finalization here
5124 -- Finalize Iter and Control here, decrementing Lock twice and Busy
5127 -- This optimization makes "for ... of" loops over 30 times faster in cases
5130 procedure Expand_Iterator_Loop_Over_Container
5133 Container
: Node_Id
;
5134 Container_Typ
: Entity_Id
)
5136 Id
: constant Entity_Id
:= Defining_Identifier
(I_Spec
);
5137 Elem_Typ
: constant Entity_Id
:= Etype
(Id
);
5138 Id_Kind
: constant Entity_Kind
:= Ekind
(Id
);
5139 Loc
: constant Source_Ptr
:= Sloc
(N
);
5141 Stats
: List_Id
:= Statements
(N
);
5142 -- Maybe wrapped in a conditional if a filter is present
5146 Iter_Type
: Entity_Id
;
5147 Iterator
: Entity_Id
;
5148 Name_Init
: Name_Id
;
5149 Name_Step
: Name_Id
;
5150 Name_Fast_Step
: Name_Id
;
5153 Fast_Element_Access_Op
: Entity_Id
:= Empty
;
5154 Fast_Step_Op
: Entity_Id
:= Empty
;
5155 -- Only for optimized version of "for ... of"
5157 Iter_Pack
: Entity_Id
;
5158 -- The package in which the iterator interface is instantiated. This is
5159 -- typically an instance within the container package.
5162 if Present
(Iterator_Filter
(I_Spec
)) then
5163 pragma Assert
(Ada_Version
>= Ada_2022
);
5164 Stats
:= New_List
(Make_If_Statement
(Loc
,
5165 Condition
=> Iterator_Filter
(I_Spec
),
5166 Then_Statements
=> Stats
));
5169 -- Determine the advancement and initialization steps for the cursor.
5170 -- Analysis of the expanded loop will verify that the container has a
5171 -- reverse iterator.
5173 if Reverse_Present
(I_Spec
) then
5174 Name_Init
:= Name_Last
;
5175 Name_Step
:= Name_Previous
;
5176 Name_Fast_Step
:= Name_uPrevious
;
5178 Name_Init
:= Name_First
;
5179 Name_Step
:= Name_Next
;
5180 Name_Fast_Step
:= Name_uNext
;
5183 -- The type of the iterator is the return type of the Iterate function
5184 -- used. For the "of" form this is the default iterator for the type,
5185 -- otherwise it is the type of the explicit function used in the
5186 -- iterator specification. The most common case will be an Iterate
5187 -- function in the container package.
5189 -- The Iterator type is declared in an instance within the container
5190 -- package itself, for example:
5192 -- package Vector_Iterator_Interfaces is new
5193 -- Ada.Iterator_Interfaces (Cursor, Has_Element);
5195 if Of_Present
(I_Spec
) then
5197 Container_Arg
: Node_Id
;
5199 function Get_Default_Iterator
5200 (T
: Entity_Id
) return Entity_Id
;
5201 -- Return the default iterator for a specific type. If the type is
5202 -- derived, we return the inherited or overridden one if
5205 --------------------------
5206 -- Get_Default_Iterator --
5207 --------------------------
5209 function Get_Default_Iterator
5210 (T
: Entity_Id
) return Entity_Id
5212 Iter
: constant Entity_Id
:=
5213 Entity
(Find_Value_Of_Aspect
(T
, Aspect_Default_Iterator
));
5218 Container_Arg
:= New_Copy_Tree
(Container
);
5220 -- A previous version of GNAT allowed indexing aspects to be
5221 -- redefined on derived container types, while the default
5222 -- iterator was inherited from the parent type. This
5223 -- nonstandard extension is preserved for use by the
5224 -- modeling project under debug flag -gnatd.X.
5226 if Debug_Flag_Dot_XX
then
5227 if Base_Type
(Etype
(Container
)) /=
5228 Base_Type
(Etype
(First_Formal
(Iter
)))
5231 Make_Type_Conversion
(Loc
,
5234 (Etype
(First_Formal
(Iter
)), Loc
),
5235 Expression
=> Container_Arg
);
5240 elsif Is_Derived_Type
(T
) then
5242 -- The default iterator must be a primitive operation of the
5243 -- type, at the same dispatch slot position. The DT position
5244 -- may not be established if type is not frozen yet.
5246 Prim
:= First_Elmt
(Primitive_Operations
(T
));
5247 while Present
(Prim
) loop
5250 if Alias
(Op
) = Iter
5252 (Chars
(Op
) = Chars
(Iter
)
5253 and then Present
(DTC_Entity
(Op
))
5254 and then DT_Position
(Op
) = DT_Position
(Iter
))
5262 -- If we didn't find it, then our parent type is not
5263 -- iterable, so we return the Default_Iterator aspect of
5268 -- Otherwise not a derived type
5273 end Get_Default_Iterator
;
5277 Default_Iter
: Entity_Id
;
5280 Cont_Type_Pack
: Entity_Id
;
5281 -- The package in which the container type is declared
5283 Reference_Control_Type
: Entity_Id
:= Empty
;
5284 Pseudo_Reference
: Entity_Id
:= Empty
;
5286 -- Start of processing for Handle_Of
5289 if Is_Class_Wide_Type
(Container_Typ
) then
5291 Get_Default_Iterator
(Etype
(Base_Type
(Container_Typ
)));
5293 Default_Iter
:= Get_Default_Iterator
(Etype
(Container
));
5296 Cursor
:= Make_Temporary
(Loc
, 'C');
5298 -- For a container element iterator, the iterator type is obtained
5299 -- from the corresponding aspect, whose return type is descended
5300 -- from the corresponding interface type in some instance of
5301 -- Ada.Iterator_Interfaces. The actuals of that instantiation
5302 -- are Cursor and Has_Element.
5304 Iter_Type
:= Etype
(Default_Iter
);
5306 -- If the container type is a derived type, the cursor type is
5307 -- found in the package of the ultimate ancestor type.
5309 if Is_Derived_Type
(Container_Typ
) then
5310 Cont_Type_Pack
:= Scope
(Root_Type
(Container_Typ
));
5312 Cont_Type_Pack
:= Scope
(Container_Typ
);
5315 -- Find declarations needed for "for ... of" optimization.
5316 -- These declarations come from GNAT sources or sources
5317 -- derived from them. User code may include additional
5318 -- overloadings with similar names, and we need to perforn
5319 -- some reasonable resolution to find the needed primitives.
5320 -- Note that we use _Next or _Previous to avoid picking up
5321 -- some arbitrary user-defined Next or Previous.
5323 Ent
:= First_Entity
(Cont_Type_Pack
);
5324 while Present
(Ent
) loop
5325 -- Get_Element_Access function with one parameter called
5328 if Chars
(Ent
) = Name_Get_Element_Access
5329 and then Ekind
(Ent
) = E_Function
5330 and then Present
(First_Formal
(Ent
))
5331 and then Chars
(First_Formal
(Ent
)) = Name_Position
5332 and then No
(Next_Formal
(First_Formal
(Ent
)))
5334 pragma Assert
(No
(Fast_Element_Access_Op
));
5335 Fast_Element_Access_Op
:= Ent
;
5337 -- Next or Prev procedure with one parameter called
5340 elsif Chars
(Ent
) = Name_Fast_Step
then
5341 pragma Assert
(No
(Fast_Step_Op
));
5342 Fast_Step_Op
:= Ent
;
5344 elsif Chars
(Ent
) = Name_Reference_Control_Type
then
5345 pragma Assert
(No
(Reference_Control_Type
));
5346 Reference_Control_Type
:= Ent
;
5348 elsif Chars
(Ent
) = Name_Pseudo_Reference
then
5349 pragma Assert
(No
(Pseudo_Reference
));
5350 Pseudo_Reference
:= Ent
;
5356 if Present
(Reference_Control_Type
)
5357 and then Present
(Pseudo_Reference
)
5360 Make_Object_Declaration
(Loc
,
5361 Defining_Identifier
=> Make_Temporary
(Loc
, 'D'),
5362 Object_Definition
=>
5363 New_Occurrence_Of
(Reference_Control_Type
, Loc
),
5365 Make_Function_Call
(Loc
,
5367 New_Occurrence_Of
(Pseudo_Reference
, Loc
),
5368 Parameter_Associations
=>
5369 New_List
(New_Copy_Tree
(Container_Arg
)))));
5372 -- Rewrite domain of iteration as a call to the default iterator
5373 -- for the container type. The formal may be an access parameter
5374 -- in which case we must build a reference to the container.
5379 if Is_Access_Type
(Etype
(First_Entity
(Default_Iter
))) then
5381 Make_Attribute_Reference
(Loc
,
5382 Prefix
=> Container_Arg
,
5383 Attribute_Name
=> Name_Unrestricted_Access
);
5385 Arg
:= Container_Arg
;
5388 Rewrite
(Name
(I_Spec
),
5389 Make_Function_Call
(Loc
,
5391 New_Occurrence_Of
(Default_Iter
, Loc
),
5392 Parameter_Associations
=> New_List
(Arg
)));
5395 Analyze_And_Resolve
(Name
(I_Spec
));
5397 -- The desired instantiation is the scope of an iterator interface
5398 -- type that is an ancestor of the iterator type.
5400 Iter_Pack
:= Scope
(Iterator_Interface_Ancestor
(Iter_Type
));
5402 -- Find cursor type in proper iterator package, which is an
5403 -- instantiation of Iterator_Interfaces.
5405 Ent
:= First_Entity
(Iter_Pack
);
5406 while Present
(Ent
) loop
5407 if Chars
(Ent
) = Name_Cursor
then
5408 Set_Etype
(Cursor
, Etype
(Ent
));
5415 if Present
(Fast_Element_Access_Op
) then
5417 Make_Object_Renaming_Declaration
(Loc
,
5418 Defining_Identifier
=> Id
,
5420 New_Occurrence_Of
(Elem_Typ
, Loc
),
5422 Make_Explicit_Dereference
(Loc
,
5424 Make_Function_Call
(Loc
,
5426 New_Occurrence_Of
(Fast_Element_Access_Op
, Loc
),
5427 Parameter_Associations
=>
5428 New_List
(New_Occurrence_Of
(Cursor
, Loc
)))));
5432 Make_Object_Renaming_Declaration
(Loc
,
5433 Defining_Identifier
=> Id
,
5435 New_Occurrence_Of
(Elem_Typ
, Loc
),
5437 Make_Indexed_Component
(Loc
,
5438 Prefix
=> Relocate_Node
(Container_Arg
),
5440 New_List
(New_Occurrence_Of
(Cursor
, Loc
))));
5443 -- The defining identifier in the iterator is user-visible and
5444 -- must be visible in the debugger.
5446 Set_Debug_Info_Needed
(Id
);
5448 -- If the container does not have a variable indexing aspect,
5449 -- the element is a constant in the loop. The container itself
5450 -- may be constant, in which case the element is a constant as
5451 -- well. The container has been rewritten as a call to Iterate,
5452 -- so examine original node.
5454 if No
(Find_Value_Of_Aspect
5455 (Container_Typ
, Aspect_Variable_Indexing
))
5456 or else not Is_Variable
(Original_Node
(Container
))
5458 Mutate_Ekind
(Id
, E_Constant
);
5461 Prepend_To
(Stats
, Decl
);
5464 -- X in Iterate (S) : type of iterator is type of explicitly given
5465 -- Iterate function, and the loop variable is the cursor. It will be
5466 -- assigned in the loop and must be a variable.
5469 Iter_Type
:= Etype
(Name
(I_Spec
));
5471 -- The instantiation in which to locate the Has_Element function
5472 -- is the scope containing an iterator interface type that is
5473 -- an ancestor of the iterator type.
5475 Iter_Pack
:= Scope
(Iterator_Interface_Ancestor
(Iter_Type
));
5480 Iterator
:= Make_Temporary
(Loc
, 'I');
5482 -- For both iterator forms, add a call to the step operation to advance
5483 -- the cursor. Generate:
5485 -- Cursor := Iterator.Next (Cursor);
5489 -- Cursor := Next (Cursor);
5491 if Present
(Fast_Element_Access_Op
) and then Present
(Fast_Step_Op
) then
5493 Curs_Name
: constant Node_Id
:= New_Occurrence_Of
(Cursor
, Loc
);
5494 Step_Call
: Node_Id
;
5498 Make_Procedure_Call_Statement
(Loc
,
5500 New_Occurrence_Of
(Fast_Step_Op
, Loc
),
5501 Parameter_Associations
=> New_List
(Curs_Name
));
5503 Append_To
(Stats
, Step_Call
);
5504 Set_Assignment_OK
(Curs_Name
);
5513 Make_Function_Call
(Loc
,
5515 Make_Selected_Component
(Loc
,
5516 Prefix
=> New_Occurrence_Of
(Iterator
, Loc
),
5517 Selector_Name
=> Make_Identifier
(Loc
, Name_Step
)),
5518 Parameter_Associations
=> New_List
(
5519 New_Occurrence_Of
(Cursor
, Loc
)));
5522 Make_Assignment_Statement
(Loc
,
5523 Name
=> New_Occurrence_Of
(Cursor
, Loc
),
5524 Expression
=> Rhs
));
5525 Set_Assignment_OK
(Name
(Last
(Stats
)));
5530 -- while Has_Element (Cursor) loop
5534 -- Has_Element is the second actual in the iterator package
5537 Make_Loop_Statement
(Loc
,
5539 Make_Iteration_Scheme
(Loc
,
5541 Make_Function_Call
(Loc
,
5544 (Next_Entity
(First_Entity
(Iter_Pack
)), Loc
),
5545 Parameter_Associations
=> New_List
(
5546 New_Occurrence_Of
(Cursor
, Loc
)))),
5548 Statements
=> Stats
,
5549 End_Label
=> Empty
);
5551 -- If present, preserve identifier of loop, which can be used in an exit
5552 -- statement in the body.
5554 if Present
(Identifier
(N
)) then
5555 Set_Identifier
(New_Loop
, Relocate_Node
(Identifier
(N
)));
5558 -- Create the declarations for Iterator and cursor and insert them
5559 -- before the source loop. Given that the domain of iteration is already
5560 -- an entity, the iterator is just a renaming of that entity. Possible
5564 Make_Object_Renaming_Declaration
(Loc
,
5565 Defining_Identifier
=> Iterator
,
5566 Subtype_Mark
=> New_Occurrence_Of
(Iter_Type
, Loc
),
5567 Name
=> Relocate_Node
(Name
(I_Spec
))));
5569 -- Create declaration for cursor
5572 Cursor_Decl
: constant Node_Id
:=
5573 Make_Object_Declaration
(Loc
,
5574 Defining_Identifier
=> Cursor
,
5575 Object_Definition
=>
5576 New_Occurrence_Of
(Etype
(Cursor
), Loc
),
5578 Make_Selected_Component
(Loc
,
5580 New_Occurrence_Of
(Iterator
, Loc
),
5582 Make_Identifier
(Loc
, Name_Init
)));
5585 -- The cursor is only modified in expanded code, so it appears
5586 -- as unassigned to the warning machinery. We must suppress this
5587 -- spurious warning explicitly. The cursor's kind is that of the
5588 -- original loop parameter (it is a constant if the domain of
5589 -- iteration is constant).
5591 Set_Warnings_Off
(Cursor
);
5592 Set_Assignment_OK
(Cursor_Decl
);
5594 Insert_Action
(N
, Cursor_Decl
);
5595 Reinit_Field_To_Zero
(Cursor
, F_Has_Initial_Value
,
5596 Old_Ekind
=> (E_Variable
=> True, others => False));
5597 Reinit_Field_To_Zero
(Cursor
, F_Is_Elaboration_Checks_OK_Id
);
5598 Reinit_Field_To_Zero
(Cursor
, F_Is_Elaboration_Warnings_OK_Id
);
5599 Reinit_Field_To_Zero
(Cursor
, F_SPARK_Pragma
);
5600 Reinit_Field_To_Zero
(Cursor
, F_SPARK_Pragma_Inherited
);
5601 Mutate_Ekind
(Cursor
, Id_Kind
);
5604 Rewrite
(N
, New_Loop
);
5606 end Expand_Iterator_Loop_Over_Container
;
5608 -----------------------------
5609 -- Expand_N_Loop_Statement --
5610 -----------------------------
5612 -- 1. Remove null loop entirely
5613 -- 2. Deal with while condition for C/Fortran boolean
5614 -- 3. Deal with loops with a non-standard enumeration type range
5615 -- 4. Deal with while loops where Condition_Actions is set
5616 -- 5. Deal with loops over predicated subtypes
5617 -- 6. Deal with loops with iterators over arrays and containers
5619 procedure Expand_N_Loop_Statement
(N
: Node_Id
) is
5620 Loc
: constant Source_Ptr
:= Sloc
(N
);
5621 Scheme
: constant Node_Id
:= Iteration_Scheme
(N
);
5627 if Is_Null_Loop
(N
) then
5628 Rewrite
(N
, Make_Null_Statement
(Loc
));
5632 -- Deal with condition for C/Fortran Boolean
5634 if Present
(Scheme
) then
5635 Adjust_Condition
(Condition
(Scheme
));
5638 -- Nothing more to do for plain loop with no iteration scheme
5643 -- Case of for loop (Loop_Parameter_Specification present)
5645 -- Note: we do not have to worry about validity checking of the for loop
5646 -- range bounds here, since they were frozen with constant declarations
5647 -- and it is during that process that the validity checking is done.
5649 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
5651 LPS
: constant Node_Id
:=
5652 Loop_Parameter_Specification
(Scheme
);
5653 Loop_Id
: constant Entity_Id
:= Defining_Identifier
(LPS
);
5654 Ltype
: constant Entity_Id
:= Etype
(Loop_Id
);
5655 Btype
: constant Entity_Id
:= Base_Type
(Ltype
);
5656 Stats
: constant List_Id
:= Statements
(N
);
5662 -- If Discrete_Subtype_Definition has been rewritten as an
5663 -- N_Raise_xxx_Error, rewrite the whole loop as a raise node to
5664 -- avoid confusing the code generator down the line.
5666 if Nkind
(Discrete_Subtype_Definition
(LPS
)) in N_Raise_xxx_Error
5668 Rewrite
(N
, Discrete_Subtype_Definition
(LPS
));
5672 if Present
(Iterator_Filter
(LPS
)) then
5673 pragma Assert
(Ada_Version
>= Ada_2022
);
5675 New_List
(Make_If_Statement
(Loc
,
5676 Condition
=> Iterator_Filter
(LPS
),
5677 Then_Statements
=> Stats
)));
5678 Analyze_List
(Statements
(N
));
5681 -- Deal with loop over predicates
5683 if Is_Discrete_Type
(Ltype
)
5684 and then Present
(Predicate_Function
(Ltype
))
5686 Expand_Predicated_Loop
(N
);
5688 -- Handle the case where we have a for loop with the range type
5689 -- being an enumeration type with non-standard representation.
5690 -- In this case we expand:
5692 -- for x in [reverse] a .. b loop
5698 -- for xP in [reverse] integer
5699 -- range etype'Pos (a) .. etype'Pos (b)
5702 -- x : constant etype := Pos_To_Rep (xP);
5708 elsif Is_Enumeration_Type
(Btype
)
5709 and then Present
(Enum_Pos_To_Rep
(Btype
))
5712 Make_Defining_Identifier
(Loc
,
5713 Chars
=> New_External_Name
(Chars
(Loop_Id
), 'P'));
5715 -- If the type has a contiguous representation, successive
5716 -- values can be generated as offsets from the first literal.
5718 if Has_Contiguous_Rep
(Btype
) then
5720 Unchecked_Convert_To
(Btype
,
5723 Make_Integer_Literal
(Loc
,
5724 Enumeration_Rep
(First_Literal
(Btype
))),
5725 Right_Opnd
=> New_Occurrence_Of
(New_Id
, Loc
)));
5727 -- Use the constructed array Enum_Pos_To_Rep
5730 Make_Indexed_Component
(Loc
,
5732 New_Occurrence_Of
(Enum_Pos_To_Rep
(Btype
), Loc
),
5734 New_List
(New_Occurrence_Of
(New_Id
, Loc
)));
5737 -- Build declaration for loop identifier
5741 Make_Object_Declaration
(Loc
,
5742 Defining_Identifier
=> Loop_Id
,
5743 Constant_Present
=> True,
5744 Object_Definition
=> New_Occurrence_Of
(Ltype
, Loc
),
5745 Expression
=> Expr
));
5748 Make_Loop_Statement
(Loc
,
5749 Identifier
=> Identifier
(N
),
5752 Make_Iteration_Scheme
(Loc
,
5753 Loop_Parameter_Specification
=>
5754 Make_Loop_Parameter_Specification
(Loc
,
5755 Defining_Identifier
=> New_Id
,
5756 Reverse_Present
=> Reverse_Present
(LPS
),
5758 Discrete_Subtype_Definition
=>
5759 Make_Subtype_Indication
(Loc
,
5762 New_Occurrence_Of
(Standard_Natural
, Loc
),
5765 Make_Range_Constraint
(Loc
,
5770 Make_Attribute_Reference
(Loc
,
5772 New_Occurrence_Of
(Btype
, Loc
),
5774 Attribute_Name
=> Name_Pos
,
5776 Expressions
=> New_List
(
5778 (Type_Low_Bound
(Ltype
)))),
5781 Make_Attribute_Reference
(Loc
,
5783 New_Occurrence_Of
(Btype
, Loc
),
5785 Attribute_Name
=> Name_Pos
,
5787 Expressions
=> New_List
(
5792 Statements
=> New_List
(
5793 Make_Block_Statement
(Loc
,
5794 Declarations
=> Decls
,
5795 Handled_Statement_Sequence
=>
5796 Make_Handled_Sequence_Of_Statements
(Loc
,
5797 Statements
=> Stats
))),
5799 End_Label
=> End_Label
(N
)));
5801 -- The loop parameter's entity must be removed from the loop
5802 -- scope's entity list and rendered invisible, since it will
5803 -- now be located in the new block scope. Any other entities
5804 -- already associated with the loop scope, such as the loop
5805 -- parameter's subtype, will remain there.
5807 -- In an element loop, the loop will contain a declaration for
5808 -- a cursor variable; otherwise the loop id is the first entity
5809 -- in the scope constructed for the loop.
5811 if Comes_From_Source
(Loop_Id
) then
5812 pragma Assert
(First_Entity
(Scope
(Loop_Id
)) = Loop_Id
);
5816 Set_First_Entity
(Scope
(Loop_Id
), Next_Entity
(Loop_Id
));
5817 Remove_Homonym
(Loop_Id
);
5819 if Last_Entity
(Scope
(Loop_Id
)) = Loop_Id
then
5820 Set_Last_Entity
(Scope
(Loop_Id
), Empty
);
5825 -- Nothing to do with other cases of for loops
5832 -- Second case, if we have a while loop with Condition_Actions set, then
5833 -- we change it into a plain loop:
5842 -- <<condition actions>>
5847 elsif Present
(Scheme
)
5848 and then Present
(Condition_Actions
(Scheme
))
5849 and then Present
(Condition
(Scheme
))
5856 Make_Exit_Statement
(Sloc
(Condition
(Scheme
)),
5858 Make_Op_Not
(Sloc
(Condition
(Scheme
)),
5859 Right_Opnd
=> Condition
(Scheme
)));
5861 Prepend
(ES
, Statements
(N
));
5862 Insert_List_Before
(ES
, Condition_Actions
(Scheme
));
5864 -- This is not an implicit loop, since it is generated in response
5865 -- to the loop statement being processed. If this is itself
5866 -- implicit, the restriction has already been checked. If not,
5867 -- it is an explicit loop.
5870 Make_Loop_Statement
(Sloc
(N
),
5871 Identifier
=> Identifier
(N
),
5872 Statements
=> Statements
(N
),
5873 End_Label
=> End_Label
(N
)));
5878 -- Here to deal with iterator case
5880 elsif Present
(Scheme
)
5881 and then Present
(Iterator_Specification
(Scheme
))
5883 Expand_Iterator_Loop
(N
);
5885 -- An iterator loop may generate renaming declarations for elements
5886 -- that require debug information. This is the case in particular
5887 -- with element iterators, where debug information must be generated
5888 -- for the temporary that holds the element value. These temporaries
5889 -- are created within a transient block whose local declarations are
5890 -- transferred to the loop, which now has nontrivial local objects.
5892 if Nkind
(N
) = N_Loop_Statement
5893 and then Present
(Identifier
(N
))
5895 Qualify_Entity_Names
(N
);
5899 -- When the iteration scheme mentions attribute 'Loop_Entry, the loop
5900 -- is transformed into a conditional block where the original loop is
5901 -- the sole statement. Inspect the statements of the nested loop for
5902 -- controlled objects.
5906 if Subject_To_Loop_Entry_Attributes
(Stmt
) then
5907 Stmt
:= Find_Loop_In_Conditional_Block
(Stmt
);
5910 Process_Statements_For_Controlled_Objects
(Stmt
);
5911 end Expand_N_Loop_Statement
;
5913 ----------------------------
5914 -- Expand_Predicated_Loop --
5915 ----------------------------
5917 -- Note: the expander can handle generation of loops over predicated
5918 -- subtypes for both the dynamic and static cases. Depending on what
5919 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
5920 -- mode, the semantic analyzer may disallow one or both forms.
5922 procedure Expand_Predicated_Loop
(N
: Node_Id
) is
5923 Orig_Loop_Id
: Node_Id
:= Empty
;
5924 Loc
: constant Source_Ptr
:= Sloc
(N
);
5925 Isc
: constant Node_Id
:= Iteration_Scheme
(N
);
5926 LPS
: constant Node_Id
:= Loop_Parameter_Specification
(Isc
);
5927 Loop_Id
: constant Entity_Id
:= Defining_Identifier
(LPS
);
5928 Ltype
: constant Entity_Id
:= Etype
(Loop_Id
);
5929 Stat
: constant List_Id
:= Static_Discrete_Predicate
(Ltype
);
5930 Stmts
: constant List_Id
:= Statements
(N
);
5933 -- Case of iteration over non-static predicate, should not be possible
5934 -- since this is not allowed by the semantics and should have been
5935 -- caught during analysis of the loop statement.
5938 raise Program_Error
;
5940 -- If the predicate list is empty, that corresponds to a predicate of
5941 -- False, in which case the loop won't run at all, and we rewrite the
5942 -- entire loop as a null statement.
5944 elsif Is_Empty_List
(Stat
) then
5945 Rewrite
(N
, Make_Null_Statement
(Loc
));
5948 -- For expansion over a static predicate we generate the following
5951 -- J : Ltype := min-val;
5956 -- when endpoint => J := startpoint;
5957 -- when endpoint => J := startpoint;
5959 -- when max-val => exit;
5960 -- when others => J := Lval'Succ (J);
5965 -- with min-val replaced by max-val and Succ replaced by Pred if the
5966 -- loop parameter specification carries a Reverse indicator.
5968 -- To make this a little clearer, let's take a specific example:
5970 -- type Int is range 1 .. 10;
5971 -- subtype StaticP is Int with
5972 -- predicate => StaticP in 3 | 10 | 5 .. 7;
5974 -- for L in StaticP loop
5975 -- Put_Line ("static:" & J'Img);
5978 -- In this case, the loop is transformed into
5985 -- when 3 => J := 5;
5986 -- when 7 => J := 10;
5988 -- when others => J := L'Succ (J);
5993 -- In addition, if the loop specification is given by a subtype
5994 -- indication that constrains a predicated type, the bounds of
5995 -- iteration are given by those of the subtype indication.
5998 Static_Predicate
: declare
6005 -- If the domain is an itype, note the bounds of its range.
6007 L_Hi
: Node_Id
:= Empty
;
6008 L_Lo
: Node_Id
:= Empty
;
6010 function Lo_Val
(N
: Node_Id
) return Node_Id
;
6011 -- Given static expression or static range, returns an identifier
6012 -- whose value is the low bound of the expression value or range.
6014 function Hi_Val
(N
: Node_Id
) return Node_Id
;
6015 -- Given static expression or static range, returns an identifier
6016 -- whose value is the high bound of the expression value or range.
6022 function Hi_Val
(N
: Node_Id
) return Node_Id
is
6024 if Is_OK_Static_Expression
(N
) then
6025 return New_Copy
(N
);
6027 pragma Assert
(Nkind
(N
) = N_Range
);
6028 return New_Copy
(High_Bound
(N
));
6036 function Lo_Val
(N
: Node_Id
) return Node_Id
is
6038 if Is_OK_Static_Expression
(N
) then
6039 return New_Copy
(N
);
6041 pragma Assert
(Nkind
(N
) = N_Range
);
6042 return New_Copy
(Low_Bound
(N
));
6046 -- Start of processing for Static_Predicate
6049 -- Convert loop identifier to normal variable and reanalyze it so
6050 -- that this conversion works. We have to use the same defining
6051 -- identifier, since there may be references in the loop body.
6053 Set_Analyzed
(Loop_Id
, False);
6054 Mutate_Ekind
(Loop_Id
, E_Variable
);
6056 -- In most loops the loop variable is assigned in various
6057 -- alternatives in the body. However, in the rare case when
6058 -- the range specifies a single element, the loop variable
6059 -- may trigger a spurious warning that is could be constant.
6060 -- This warning might as well be suppressed.
6062 Set_Warnings_Off
(Loop_Id
);
6064 if Is_Itype
(Ltype
) then
6065 L_Hi
:= High_Bound
(Scalar_Range
(Ltype
));
6066 L_Lo
:= Low_Bound
(Scalar_Range
(Ltype
));
6069 -- Loop to create branches of case statement
6073 if Reverse_Present
(LPS
) then
6075 -- Initial value is largest value in predicate.
6077 if Is_Itype
(Ltype
) then
6079 Make_Object_Declaration
(Loc
,
6080 Defining_Identifier
=> Loop_Id
,
6081 Object_Definition
=> New_Occurrence_Of
(Ltype
, Loc
),
6082 Expression
=> L_Hi
);
6086 Make_Object_Declaration
(Loc
,
6087 Defining_Identifier
=> Loop_Id
,
6088 Object_Definition
=> New_Occurrence_Of
(Ltype
, Loc
),
6089 Expression
=> Hi_Val
(Last
(Stat
)));
6093 while Present
(P
) loop
6094 if No
(Prev
(P
)) then
6095 S
:= Make_Exit_Statement
(Loc
);
6098 Make_Assignment_Statement
(Loc
,
6099 Name
=> New_Occurrence_Of
(Loop_Id
, Loc
),
6100 Expression
=> Hi_Val
(Prev
(P
)));
6101 Set_Suppress_Assignment_Checks
(S
);
6105 Make_Case_Statement_Alternative
(Loc
,
6106 Statements
=> New_List
(S
),
6107 Discrete_Choices
=> New_List
(Lo_Val
(P
))));
6113 and then Is_OK_Static_Expression
(L_Lo
)
6115 Expr_Value
(L_Lo
) /= Expr_Value
(Lo_Val
(First
(Stat
)))
6118 Make_Case_Statement_Alternative
(Loc
,
6119 Statements
=> New_List
(Make_Exit_Statement
(Loc
)),
6120 Discrete_Choices
=> New_List
(L_Lo
)));
6124 -- Initial value is smallest value in predicate
6126 if Is_Itype
(Ltype
) then
6128 Make_Object_Declaration
(Loc
,
6129 Defining_Identifier
=> Loop_Id
,
6130 Object_Definition
=> New_Occurrence_Of
(Ltype
, Loc
),
6131 Expression
=> L_Lo
);
6134 Make_Object_Declaration
(Loc
,
6135 Defining_Identifier
=> Loop_Id
,
6136 Object_Definition
=> New_Occurrence_Of
(Ltype
, Loc
),
6137 Expression
=> Lo_Val
(First
(Stat
)));
6141 while Present
(P
) loop
6142 if No
(Next
(P
)) then
6143 S
:= Make_Exit_Statement
(Loc
);
6146 Make_Assignment_Statement
(Loc
,
6147 Name
=> New_Occurrence_Of
(Loop_Id
, Loc
),
6148 Expression
=> Lo_Val
(Next
(P
)));
6149 Set_Suppress_Assignment_Checks
(S
);
6153 Make_Case_Statement_Alternative
(Loc
,
6154 Statements
=> New_List
(S
),
6155 Discrete_Choices
=> New_List
(Hi_Val
(P
))));
6161 and then Is_OK_Static_Expression
(L_Hi
)
6163 Expr_Value
(L_Hi
) /= Expr_Value
(Lo_Val
(Last
(Stat
)))
6166 Make_Case_Statement_Alternative
(Loc
,
6167 Statements
=> New_List
(Make_Exit_Statement
(Loc
)),
6168 Discrete_Choices
=> New_List
(L_Hi
)));
6172 -- Add others choice
6175 Name_Next
: Name_Id
;
6178 if Reverse_Present
(LPS
) then
6179 Name_Next
:= Name_Pred
;
6181 Name_Next
:= Name_Succ
;
6185 Make_Assignment_Statement
(Loc
,
6186 Name
=> New_Occurrence_Of
(Loop_Id
, Loc
),
6188 Make_Attribute_Reference
(Loc
,
6189 Prefix
=> New_Occurrence_Of
(Ltype
, Loc
),
6190 Attribute_Name
=> Name_Next
,
6191 Expressions
=> New_List
(
6192 New_Occurrence_Of
(Loop_Id
, Loc
))));
6193 Set_Suppress_Assignment_Checks
(S
);
6197 Make_Case_Statement_Alternative
(Loc
,
6198 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
6199 Statements
=> New_List
(S
)));
6201 -- Construct case statement and append to body statements
6204 Make_Case_Statement
(Loc
,
6205 Expression
=> New_Occurrence_Of
(Loop_Id
, Loc
),
6206 Alternatives
=> Alts
);
6207 Append_To
(Stmts
, Cstm
);
6209 -- Rewrite the loop preserving the loop identifier in case there
6210 -- are exit statements referencing it.
6212 if Present
(Identifier
(N
)) then
6213 Orig_Loop_Id
:= New_Occurrence_Of
6214 (Entity
(Identifier
(N
)), Loc
);
6217 Set_Suppress_Assignment_Checks
(D
);
6220 Make_Block_Statement
(Loc
,
6221 Declarations
=> New_List
(D
),
6222 Handled_Statement_Sequence
=>
6223 Make_Handled_Sequence_Of_Statements
(Loc
,
6224 Statements
=> New_List
(
6225 Make_Loop_Statement
(Loc
,
6226 Statements
=> Stmts
,
6227 Identifier
=> Orig_Loop_Id
,
6228 End_Label
=> Empty
)))));
6231 end Static_Predicate
;
6233 end Expand_Predicated_Loop
;
6235 ------------------------------
6236 -- Make_Tag_Ctrl_Assignment --
6237 ------------------------------
6239 function Make_Tag_Ctrl_Assignment
(N
: Node_Id
) return List_Id
is
6240 Asn
: constant Node_Id
:= Relocate_Node
(N
);
6241 L
: constant Node_Id
:= Name
(N
);
6242 Loc
: constant Source_Ptr
:= Sloc
(N
);
6243 Res
: constant List_Id
:= New_List
;
6244 T
: constant Entity_Id
:= Underlying_Type
(Etype
(L
));
6246 Adj_Act
: constant Boolean := Needs_Finalization
(T
)
6247 and then not No_Ctrl_Actions
(N
);
6248 Comp_Asn
: constant Boolean := Is_Fully_Repped_Tagged_Type
(T
);
6249 Ctrl_Act
: constant Boolean := Needs_Finalization
(T
)
6250 and then not No_Ctrl_Actions
(N
)
6251 and then not No_Finalize_Actions
(N
);
6252 Save_Tag
: constant Boolean := Is_Tagged_Type
(T
)
6253 and then not Comp_Asn
6254 and then not No_Ctrl_Actions
(N
)
6255 and then not No_Finalize_Actions
(N
)
6256 and then Tagged_Type_Expansion
;
6257 Set_Tag
: constant Boolean := Is_Tagged_Type
(T
)
6258 and then not Comp_Asn
6259 and then not No_Ctrl_Actions
(N
)
6260 and then Tagged_Type_Expansion
;
6266 -- Finalize the target of the assignment when controlled
6268 -- We have two exceptions here:
6270 -- 1. If we are in an init proc or within an aggregate, since it is an
6271 -- initialization more than an assignment.
6273 -- 2. If the left-hand side is a temporary that was not initialized
6274 -- (or the parent part of a temporary since it is the case in
6275 -- extension aggregates). Such a temporary does not come from
6276 -- source. We must examine the original node for the prefix, because
6277 -- it may be a component of an entry formal, in which case it has
6278 -- been rewritten and does not appear to come from source either.
6280 -- Case of init proc or aggregate
6282 if not Ctrl_Act
then
6285 -- The left-hand side is an uninitialized temporary object
6287 elsif Nkind
(L
) = N_Type_Conversion
6288 and then Is_Entity_Name
(Expression
(L
))
6289 and then Nkind
(Parent
(Entity
(Expression
(L
)))) =
6290 N_Object_Declaration
6291 and then No_Initialization
(Parent
(Entity
(Expression
(L
))))
6298 (Obj_Ref
=> Duplicate_Subexpr_No_Checks
(L
),
6301 if Present
(Fin_Call
) then
6302 Append_To
(Res
, Fin_Call
);
6306 -- Save the Tag in a local variable Tag_Id
6309 Tag_Id
:= Make_Temporary
(Loc
, 'A');
6312 Make_Object_Declaration
(Loc
,
6313 Defining_Identifier
=> Tag_Id
,
6314 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6316 Make_Selected_Component
(Loc
,
6317 Prefix
=> Duplicate_Subexpr_No_Checks
(L
),
6319 New_Occurrence_Of
(First_Tag_Component
(T
), Loc
))));
6321 -- Otherwise Tag_Id is not used
6327 -- If the tagged type has a full rep clause, expand the assignment into
6328 -- component-wise assignments. Mark the node as unanalyzed in order to
6329 -- generate the proper code and propagate this scenario by setting a
6330 -- flag to avoid infinite recursion.
6333 Set_Analyzed
(Asn
, False);
6334 Set_Componentwise_Assignment
(Asn
, True);
6337 Append_To
(Res
, Asn
);
6343 Make_Assignment_Statement
(Loc
,
6345 Make_Selected_Component
(Loc
,
6346 Prefix
=> Duplicate_Subexpr_No_Checks
(L
),
6348 New_Occurrence_Of
(First_Tag_Component
(T
), Loc
)),
6349 Expression
=> New_Occurrence_Of
(Tag_Id
, Loc
)));
6351 -- Or else just initialize it
6355 Make_Tag_Assignment_From_Type
6356 (Loc
, Duplicate_Subexpr_No_Checks
(L
), T
));
6359 -- Adjust the target after the assignment when controlled (not in the
6360 -- init proc since it is an initialization more than an assignment).
6362 if Ctrl_Act
or else Adj_Act
then
6365 (Obj_Ref
=> Duplicate_Subexpr_Move_Checks
(L
),
6368 if Present
(Adj_Call
) then
6369 Append_To
(Res
, Adj_Call
);
6377 -- Could use comment here ???
6379 when RE_Not_Available
=>
6381 end Make_Tag_Ctrl_Assignment
;