| blob | 2072935d2ca61a9b3d228ccad3135cd72bee1d25 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 5 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
71 procedure Build_Formal_Container_Iteration
78 -- Utility to create declarations and loop statement for both forms
79 -- of formal container iterators.
81 function Convert_To_Iterable_Type
84 -- Returns New_Occurrence_Of (Container), possibly converted to an ancestor
85 -- type, if the type of Container inherited the Iterable aspect from that
86 -- ancestor.
89 -- Determine if the right-hand side of assignment N is a type conversion
90 -- which requires a change of representation. Called only for the array
91 -- and record cases.
94 -- N is an assignment which assigns an array value. This routine process
95 -- the various special cases and checks required for such assignments,
96 -- including change of representation. Rhs is normally simply the right-
97 -- hand side of the assignment, except that if the right-hand side is a
98 -- type conversion or a qualified expression, then the RHS is the actual
99 -- expression inside any such type conversions or qualifications.
101 function Expand_Assign_Array_Loop
109 -- N is an assignment statement which assigns an array value. This routine
110 -- expands the assignment into a loop (or nested loops for the case of a
111 -- multi-dimensional array) to do the assignment component by component.
112 -- Larray and Rarray are the entities of the actual arrays on the left-hand
113 -- and right-hand sides. L_Type and R_Type are the types of these arrays
114 -- (which may not be the same, due to either sliding, or to a change of
115 -- representation case). Ndim is the number of dimensions and the parameter
116 -- Rev indicates if the loops run normally (Rev = False), or reversed
117 -- (Rev = True). The value returned is the constructed loop statement.
118 -- Auxiliary declarations are inserted before node N using the standard
119 -- Insert_Actions mechanism.
121 function Expand_Assign_Array_Bitfield
128 -- Alternative to Expand_Assign_Array_Loop for packed bitfields. Generates
129 -- a call to System.Bitfields.Copy_Bitfield, which is more efficient than
130 -- copying component-by-component.
132 function Expand_Assign_Array_Bitfield_Fast
136 -- Alternative to Expand_Assign_Array_Bitfield. Generates a call to
137 -- System.Bitfields.Fast_Copy_Bitfield, which is more efficient than
138 -- Copy_Bitfield, but only works in restricted situations.
140 function Expand_Assign_Array_Loop_Or_Bitfield
148 -- Calls either Expand_Assign_Array_Loop, Expand_Assign_Array_Bitfield, or
149 -- Expand_Assign_Array_Bitfield_Fast as appropriate.
152 -- N is an assignment of an untagged record value. This routine handles
153 -- the case where the assignment must be made component by component,
154 -- either because the target is not byte aligned, or there is a change
155 -- of representation, or when we have a tagged type with a representation
156 -- clause (this last case is required because holes in the tagged type
157 -- might be filled with components from child types).
160 -- (AI12-0125): N is an assignment statement whose RHS contains occurrences
161 -- of @ that designate the value of the LHS of the assignment. If the LHS
162 -- is side-effect free the target names can be replaced with a copy of the
163 -- LHS; otherwise the semantics of the assignment is described in terms of
164 -- a procedure with an in-out parameter, and expanded as such.
167 -- Use the primitives specified in an Iterable aspect to expand a loop
168 -- over a so-called formal container, primarily for SPARK usage.
171 -- Same, for an iterator of the form " For E of C". In this case the
172 -- iterator provides the name of the element, and the cursor is generated
173 -- internally.
176 -- Expand loop over arrays and containers that uses the form "for X of C"
177 -- with an optional subtype mark, or "for Y in C".
179 procedure Expand_Iterator_Loop_Over_Container
185 -- Expand loop over containers that uses the form "for X of C" with an
186 -- optional subtype mark, or "for Y in C". Isc is the iteration scheme.
187 -- I_Spec is the iterator specification and Container is either the
188 -- Container (for OF) or the iterator (for IN).
191 -- Expand for loop over predicated subtype
194 -- Generate the necessary code for controlled and tagged assignment, that
195 -- is to say, finalization of the target before, adjustment of the target
196 -- after and save and restore of the tag and finalization pointers which
197 -- are not 'part of the value' and must not be changed upon assignment. N
198 -- is the original Assignment node.
200 --------------------------------------
201 -- Build_Formal_Container_Iteration --
202 --------------------------------------
204 procedure Build_Formal_Container_Iteration
211 is
222 begin
223 -- Use the proper set of primitives depending on the direction of
224 -- iteration. The legality of a reverse iteration has been checked
225 -- during analysis.
231 else
236 -- Declaration for Cursor
238 Init :=
242 Expression =>
248 -- Statement that advances (in the right direction) cursor in loop
250 Advance :=
253 Expression =>
260 -- Iterator is rewritten as a while_loop
262 New_Loop :=
264 Iteration_Scheme =>
266 Condition =>
275 -- If the contruct has a specified loop name, preserve it in the new
276 -- loop, for possible use in exit statements.
280 then
285 ------------------------------
286 -- Change_Of_Representation --
287 ------------------------------
291 begin
292 return
294 and then not Has_Compatible_Representation
299 ------------------------------
300 -- Convert_To_Iterable_Type --
301 ------------------------------
303 function Convert_To_Iterable_Type
306 is
311 begin
315 Result :=
324 -------------------------
325 -- Expand_Assign_Array --
326 -------------------------
328 -- There are two issues here. First, do we let Gigi do a block move, or
329 -- do we expand out into a loop? Second, we need to set the two flags
330 -- Forwards_OK and Backwards_OK which show whether the block move (or
331 -- corresponding loops) can be legitimately done in a forwards (low to
332 -- high) or backwards (high to low) manner.
352 pragma Assert
353 (Crep
362 -- This switch is set to True if the array move must be done using
363 -- an explicit front end generated loop.
366 -- If the argument is an access to an array, and the assignment is
367 -- converted into a procedure call, apply explicit dereference.
370 -- Test if Exp is a reference to an array whose declaration has
371 -- an address clause, or it is a slice of such an array.
374 -- Test if Exp is a reference to an array which is either a formal
375 -- parameter or a slice of a formal parameter. These are the cases
376 -- where hidden aliasing can occur.
379 -- Determine if Exp is a reference to an array variable which is other
380 -- than an object defined in the current scope, or a component or a
381 -- slice of such an object. Such objects can be aliased to parameters
382 -- (unlike local array references).
384 -----------------------
385 -- Apply_Dereference --
386 -----------------------
390 begin
398 ------------------------
399 -- Has_Address_Clause --
400 ------------------------
403 begin
404 return
407 or else
411 ---------------------
412 -- Is_Formal_Array --
413 ---------------------
416 begin
417 return
419 or else
423 ------------------------
424 -- Is_Non_Local_Array --
425 ------------------------
428 begin
430 when N_Indexed_Component
431 | N_Selected_Component
432 | N_Slice
433 =>
437 return
443 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
451 -- Start of processing for Expand_Assign_Array
453 begin
454 -- Deal with length check. Note that the length check is done with
455 -- respect to the right-hand side as given, not a possible underlying
456 -- renamed object, since this would generate incorrect extra checks.
460 -- We start by assuming that the move can be done in either direction,
461 -- i.e. that the two sides are completely disjoint.
466 -- Normally it is only the slice case that can lead to overlap, and
467 -- explicit checks for slices are made below. But there is one case
468 -- where the slice can be implicit and invisible to us: when we have a
469 -- one dimensional array, and either both operands are parameters, or
470 -- one is a parameter (which can be a slice passed by reference) and the
471 -- other is a non-local variable. In this case the parameter could be a
472 -- slice that overlaps with the other operand.
474 -- However, if the array subtype is a constrained first subtype in the
475 -- parameter case, then we don't have to worry about overlap, since
476 -- slice assignments aren't possible (other than for a slice denoting
477 -- the whole array).
479 -- Note: No overlap is possible if there is a change of representation,
480 -- so we can exclude this case.
483 and then not Crep
484 and then
486 or else
488 or else
490 and then
493 then
497 -- Note: the bit-packed case is not worrisome here, since if we have
498 -- a slice passed as a parameter, it is always aligned on a byte
499 -- boundary, and if there are no explicit slices, the assignment
500 -- can be performed directly.
503 -- If either operand has an address clause clear Backwards_OK and
504 -- Forwards_OK, since we cannot tell if the operands overlap. We
505 -- exclude this treatment when Rhs is an aggregate, since we know
506 -- that overlap can't occur.
510 then
515 -- We certainly must use a loop for change of representation and also
516 -- we use the operand of the conversion on the right-hand side as the
517 -- effective right-hand side (the component types must match in this
518 -- situation).
525 -- We require a loop if the left side is possibly bit unaligned
528 or else
530 then
533 -- Arrays with controlled components are expanded into a loop to force
534 -- calls to Adjust at the component level.
539 -- If object is full access, we cannot tolerate a loop
542 or else
544 then
547 -- Loop is required if we have atomic components since we have to
548 -- be sure to do any accesses on an element by element basis.
554 then
557 -- Case where no slice is involved
561 -- The following code deals with the case of unconstrained bit packed
562 -- arrays. The problem is that the template for such arrays contains
563 -- the bounds of the actual source level array, but the copy of an
564 -- entire array requires the bounds of the underlying array. It would
565 -- be nice if the back end could take care of this, but right now it
566 -- does not know how, so if we have such a type, then we expand out
567 -- into a loop, which is inefficient but works correctly. If we don't
568 -- do this, we get the wrong length computed for the array to be
569 -- moved. The two cases we need to worry about are:
571 -- Explicit dereference of an unconstrained packed array type as in
572 -- the following example:
574 -- procedure C52 is
575 -- type BITS is array(INTEGER range <>) of BOOLEAN;
576 -- pragma PACK(BITS);
577 -- type A is access BITS;
578 -- P1,P2 : A;
579 -- begin
580 -- P1 := new BITS (1 .. 65_535);
581 -- P2 := new BITS (1 .. 65_535);
582 -- P2.ALL := P1.ALL;
583 -- end C52;
585 -- A formal parameter reference with an unconstrained bit array type
586 -- is the other case we need to worry about (here we assume the same
587 -- BITS type declared above):
589 -- procedure Write_All (File : out BITS; Contents : BITS);
590 -- begin
591 -- File.Storage := Contents;
592 -- end Write_All;
594 -- We expand to a loop in either of these two cases
596 -- Question for future thought. Another potentially more efficient
597 -- approach would be to create the actual subtype, and then do an
598 -- unchecked conversion to this actual subtype ???
603 -- Function to perform required test for the first case, above
604 -- (dereference of an unconstrained bit packed array).
606 -----------------------
607 -- Is_UBPA_Reference --
608 -----------------------
615 begin
619 then
628 else
630 return
635 else
640 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
642 begin
644 or else
646 then
649 -- Here if we do not have the case of a reference to a bit packed
650 -- unconstrained array case. In this case gigi can most certainly
651 -- handle the assignment if a forwards move is allowed.
653 -- (could it handle the backwards case also???)
660 -- The back end can always handle the assignment if the right side is a
661 -- string literal (note that overlap is definitely impossible in this
662 -- case). If the type is packed, a string literal is always converted
663 -- into an aggregate, except in the case of a null slice, for which no
664 -- aggregate can be written. In that case, rewrite the assignment as a
665 -- null statement, a length check has already been emitted to verify
666 -- that the range of the left-hand side is empty.
668 -- Note that this code is not executed if we have an assignment of a
669 -- string literal to a non-bit aligned component of a record, a case
670 -- which cannot be handled by the backend.
675 then
682 -- If either operand is bit packed, then we need a loop, since we can't
683 -- be sure that the slice is byte aligned. Similarly, if either operand
684 -- is a possibly unaligned slice, then we need a loop (since the back
685 -- end cannot handle unaligned slices).
691 then
694 -- If we are not bit-packed, and we have only one slice, then no overlap
695 -- is possible except in the parameter case, so we can let the back end
696 -- handle things.
704 -- If the right-hand side is a string literal, introduce a temporary for
705 -- it, for use in the generated loop that will follow.
708 declare
712 begin
713 Decl :=
725 -- Come here to complete the analysis
727 -- Loop_Required: Set to True if we know that a loop is required
728 -- regardless of overlap considerations.
730 -- Forwards_OK: Set to False if we already know that a forwards
731 -- move is not safe, else set to True.
733 -- Backwards_OK: Set to False if we already know that a backwards
734 -- move is not safe, else set to True
736 -- Our task at this stage is to complete the overlap analysis, which can
737 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
738 -- then generating the final code, either by deciding that it is OK
739 -- after all to let Gigi handle it, or by generating appropriate code
740 -- in the front end.
742 declare
760 begin
761 -- Get the expressions for the arrays. If we are dealing with a
762 -- private type, then convert to the underlying type. We can do
763 -- direct assignments to an array that is a private type, but we
764 -- cannot assign to elements of the array without this extra
765 -- unchecked conversion.
767 -- Note: We propagate Parent to the conversion nodes to generate
768 -- a well-formed subtree.
772 else
776 declare
778 begin
779 Larray :=
780 Unchecked_Convert_To
789 else
793 declare
795 begin
796 Rarray :=
797 Unchecked_Convert_To
804 -- If both sides are slices, we must figure out whether it is safe
805 -- to do the move in one direction or the other. It is always safe
806 -- if there is a change of representation since obviously two arrays
807 -- with different representations cannot possibly overlap.
813 -- If both left- and right-hand arrays are entity names, and refer
814 -- to different entities, then we know that the move is safe (the
815 -- two storage areas are completely disjoint).
820 then
823 -- Otherwise, we assume the worst, which is that the two arrays
824 -- are the same array. There is no need to check if we know that
825 -- is the case, because if we don't know it, we still have to
826 -- assume it.
828 -- Generally if the same array is involved, then we have an
829 -- overlapping case. We will have to really assume the worst (i.e.
830 -- set neither of the OK flags) unless we can determine the lower
831 -- or upper bounds at compile time and compare them.
833 else
834 Cresult :=
835 Compile_Time_Compare
839 Cresult :=
840 Compile_Time_Compare
858 -- If after that analysis Loop_Required is False, meaning that we
859 -- have not discovered some non-overlap reason for requiring a loop,
860 -- then the outcome depends on the capabilities of the back end.
863 -- Assume the back end can deal with all cases of overlap by
864 -- falling back to memmove if it cannot use a more efficient
865 -- approach.
870 -- At this stage we have to generate an explicit loop, and we have
871 -- the following cases:
873 -- Forwards_OK = True
875 -- Rnn : right_index := right_index'First;
876 -- for Lnn in left-index loop
877 -- left (Lnn) := right (Rnn);
878 -- Rnn := right_index'Succ (Rnn);
879 -- end loop;
881 -- Note: the above code MUST be analyzed with checks off, because
882 -- otherwise the Succ could overflow. But in any case this is more
883 -- efficient.
885 -- Forwards_OK = False, Backwards_OK = True
887 -- Rnn : right_index := right_index'Last;
888 -- for Lnn in reverse left-index loop
889 -- left (Lnn) := right (Rnn);
890 -- Rnn := right_index'Pred (Rnn);
891 -- end loop;
893 -- Note: the above code MUST be analyzed with checks off, because
894 -- otherwise the Pred could overflow. But in any case this is more
895 -- efficient.
897 -- Forwards_OK = Backwards_OK = False
899 -- This only happens if we have the same array on each side. It is
900 -- possible to create situations using overlays that violate this,
901 -- but we simply do not promise to get this "right" in this case.
903 -- There are two possible subcases. If the No_Implicit_Conditionals
904 -- restriction is set, then we generate the following code:
906 -- declare
907 -- T : constant <operand-type> := rhs;
908 -- begin
909 -- lhs := T;
910 -- end;
912 -- If implicit conditionals are permitted, then we generate:
914 -- if Left_Lo <= Right_Lo then
915 -- <code for Forwards_OK = True above>
916 -- else
917 -- <code for Backwards_OK = True above>
918 -- end if;
920 -- In order to detect possible aliasing, we examine the renamed
921 -- expression when the source or target is a renaming. However,
922 -- the renaming may be intended to capture an address that may be
923 -- affected by subsequent code, and therefore we must recover
924 -- the actual entity for the expansion that follows, not the
925 -- object it renames. In particular, if source or target designate
926 -- a portion of a dynamically allocated object, the pointer to it
927 -- may be reassigned but the renaming preserves the proper location.
930 and then
933 then
938 and then
941 then
945 -- Cases where either Forwards_OK or Backwards_OK is true
952 then
953 declare
958 begin
970 New_Occurrence_Of (
979 else
981 Expand_Assign_Array_Loop_Or_Bitfield
986 -- Case of both are false with No_Implicit_Conditionals
989 declare
993 begin
1000 Object_Definition =>
1004 Handled_Statement_Sequence =>
1012 -- Case of both are false with implicit conditionals allowed
1014 else
1015 -- Before we generate this code, we must ensure that the left and
1016 -- right side array types are defined. They may be itypes, and we
1017 -- cannot let them be defined inside the if, since the first use
1018 -- in the then may not be executed.
1023 -- We normally compare addresses to find out which way round to
1024 -- do the loop, since this is reliable, and handles the cases of
1025 -- parameters, conversions etc. But we can't do that in the bit
1026 -- packed case, because addresses don't work there.
1029 Condition :=
1031 Left_Opnd =>
1034 Prefix =>
1036 Prefix =>
1040 Prefix =>
1041 New_Occurrence_Of
1046 Right_Opnd =>
1049 Prefix =>
1051 Prefix =>
1055 Prefix =>
1056 New_Occurrence_Of
1061 -- For the bit packed and VM cases we use the bounds. That's OK,
1062 -- because we don't have to worry about parameters, since they
1063 -- cannot cause overlap. Perhaps we should worry about weird slice
1064 -- conversions ???
1066 else
1067 -- Copy the bounds
1072 -- If the types do not match we add an implicit conversion
1073 -- here to ensure proper match
1076 Cright_Lo :=
1080 -- Reset the Analyzed flag, because the bounds of the index
1081 -- type itself may be universal, and must be reanalyzed to
1082 -- acquire the proper type for the back end.
1087 Condition :=
1097 then
1099 -- Call TSS procedure for array assignment, passing the
1100 -- explicit bounds of right- and left-hand sides.
1102 declare
1107 begin
1128 else
1134 Expand_Assign_Array_Loop_Or_Bitfield
1139 Expand_Assign_Array_Loop_Or_Bitfield
1148 exception
1153 ------------------------------
1154 -- Expand_Assign_Array_Loop --
1155 ------------------------------
1157 -- The following is an example of the loop generated for the case of a
1158 -- two-dimensional array:
1160 -- declare
1161 -- R2b : Tm1X1 := 1;
1162 -- begin
1163 -- for L1b in 1 .. 100 loop
1164 -- declare
1165 -- R4b : Tm1X2 := 1;
1166 -- begin
1167 -- for L3b in 1 .. 100 loop
1168 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
1169 -- R4b := Tm1X2'succ(R4b);
1170 -- end loop;
1171 -- end;
1172 -- R2b := Tm1X1'succ(R2b);
1173 -- end loop;
1174 -- end;
1176 -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand
1177 -- side. The declarations of R2b and R4b are inserted before the original
1178 -- assignment statement.
1180 function Expand_Assign_Array_Loop
1188 is
1193 -- Entities used as subscripts on left and right sides
1197 -- Left and right index types
1205 -- The increment step for the index of the right-hand side is written
1206 -- as an attribute reference (Succ or Pred). This function returns
1207 -- the corresponding node, which is placed at the end of the loop body.
1209 ----------------
1210 -- Build_Step --
1211 ----------------
1217 begin
1220 else
1224 Step :=
1227 Expression =>
1229 Prefix =>
1235 -- Note that on the last iteration of the loop, the index is increased
1236 -- (or decreased) past the corresponding bound. This is consistent with
1237 -- the C semantics of the back-end, where such an off-by-one value on a
1238 -- dead index variable is OK. However, in CodePeer mode this leads to
1239 -- spurious warnings, and thus we place a guard around the attribute
1240 -- reference. For obvious reasons we only do this for CodePeer.
1243 Step :=
1245 Condition =>
1248 Right_Opnd =>
1258 -- Start of processing for Expand_Assign_Array_Loop
1260 begin
1264 else
1269 -- Setup index types and subscript entities
1271 declare
1275 begin
1291 -- Now construct the assignment statement
1293 declare
1297 begin
1303 Assign :=
1305 Name =>
1309 Expression =>
1314 -- We set assignment OK, since there are some cases, e.g. in object
1315 -- declarations, where we are actually assigning into a constant.
1316 -- If there really is an illegality, it was caught long before now,
1317 -- and was flagged when the original assignment was analyzed.
1321 -- Propagate the No_Ctrl_Actions flag to individual assignments
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.
1331 Assign :=
1336 Object_Definition =>
1338 Expression =>
1343 Handled_Statement_Sequence =>
1347 Iteration_Scheme =>
1349 Loop_Parameter_Specification =>
1353 Discrete_Subtype_Definition =>
1362 ----------------------------------
1363 -- Expand_Assign_Array_Bitfield --
1364 ----------------------------------
1366 function Expand_Assign_Array_Bitfield
1373 is
1375 -- Reverse copying is not yet supported by Copy_Bitfield.
1378 -- This won't work, for example, to copy a packed array to an unpacked
1379 -- array.
1390 Prefix =>
1392 Prefix =>
1399 Prefix =>
1401 Prefix =>
1408 Prefix =>
1410 Prefix =>
1417 Prefix =>
1419 Prefix =>
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).
1435 Prefix =>
1439 Prefix =>
1443 begin
1450 ---------------------------------------
1451 -- Expand_Assign_Array_Bitfield_Fast --
1452 ---------------------------------------
1454 function Expand_Assign_Array_Bitfield_Fast
1458 is
1460 -- This won't work, for example, to copy a packed array to an unpacked
1461 -- array.
1463 -- For L (A .. B) := R (C .. D), we generate:
1464 --
1465 -- L := Fast_Copy_Bitfield (R, <offset of R(C)>, L, <offset of L(A)>,
1466 -- L (A .. B)'Length * L'Component_Size);
1467 --
1468 -- with L and R suitably uncheckedly converted to/from Val_2.
1469 -- The offsets are from the start of L and R.
1475 -- The original type of the arrays
1481 -- Converted values of left- and right-hand sides
1489 -- Whether the above unchecked conversions need to be padded with zeros
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.
1506 Make_Integer_Literal
1517 Make_Integer_Literal
1523 Prefix =>
1527 Prefix =>
1533 begin
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.
1540 if L_Small
1542 then
1547 else
1551 if R_Small
1553 then
1558 else
1567 -- Conversely, the final unchecked conversion must take significant bits
1569 if L_Small
1571 then
1583 ------------------------------------------
1584 -- Expand_Assign_Array_Loop_Or_Bitfield --
1585 ------------------------------------------
1587 function Expand_Assign_Array_Loop_Or_Bitfield
1595 is
1599 -- Left- and right-hand sides of the assignment statement
1604 -- True if the left-hand side is a slice of a component or slice
1607 N_Selected_Component | N_Indexed_Component | N_Slice;
1609 -- Likewise for the right-hand side
1612 N_Selected_Component | N_Indexed_Component | N_Slice;
1614 begin
1615 -- Determine whether Copy_Bitfield or Fast_Copy_Bitfield is appropriate
1616 -- (will work, and will be more efficient than component-by-component
1617 -- copy). Copy_Bitfield doesn't work for reversed storage orders. It is
1618 -- efficient for slices of bit-packed arrays. Copy_Bitfield can read and
1619 -- write bits that are not part of the objects being copied, so we don't
1620 -- want to use it if there are volatile or independent components. If
1621 -- the Prefix of the slice is a component or slice, then it might be a
1622 -- part of an object with some other volatile or independent components,
1623 -- so we disable the optimization in that case as well. We could
1624 -- complicate this code by actually looking for such volatile and
1625 -- independent components.
1632 and then Slices
1637 and then not L_Prefix_Comp
1638 and then not R_Prefix_Comp
1639 then
1640 -- Here if Copy_Bitfield can work (except for the Rev test below).
1641 -- Determine whether to call Fast_Copy_Bitfield instead. If we
1642 -- are assigning slices, and all the relevant bounds are known at
1643 -- compile time, and the maximum object size is no greater than
1644 -- System.Bitfields.Val_Bits (i.e. Long_Long_Integer'Size / 2), and
1645 -- we don't have enumeration representation clauses, we can use
1646 -- Fast_Copy_Bitfield. The max size test is to ensure that the slices
1647 -- cannot overlap boundaries not supported by Fast_Copy_Bitfield.
1652 -- Note that L_Type and R_Type do not necessarily have the same base
1653 -- type, because of array type conversions. Hence the need to check
1654 -- various properties of both.
1658 then
1659 declare
1672 then Compile_Time_Known_Value
1676 then Compile_Time_Known_Value
1681 begin
1684 Val_Bits
1687 and then Known_Left_Slice_Low
1688 and then Known_Right_Slice_Low
1689 and then Compile_Time_Known_Value
1691 and then Compile_Time_Known_Value
1693 and then
1695 and then Has_Enumeration_Rep_Clause
1698 then
1707 -- Fast_Copy_Bitfield can work if Rev is True, because the data is
1708 -- passed and returned by copy. Copy_Bitfield cannot.
1711 return Expand_Assign_Array_Bitfield
1716 -- Here if we did not return above, with Fast_Copy_Bitfield or
1717 -- Copy_Bitfield.
1719 return Expand_Assign_Array_Loop
1723 --------------------------
1724 -- Expand_Assign_Record --
1725 --------------------------
1732 begin
1733 -- If change of representation, then extract the real right-hand side
1734 -- from the type conversion, and proceed with component-wise assignment,
1735 -- since the two types are not the same as far as the back end is
1736 -- concerned.
1741 -- If this may be a case of a large bit aligned component, then proceed
1742 -- with component-wise assignment, to avoid possible clobbering of other
1743 -- components sharing bits in the first or last byte of the component to
1744 -- be assigned.
1747 or else
1749 then
1752 -- If we have a tagged type that has a complete record representation
1753 -- clause, we must do we must do component-wise assignments, since child
1754 -- types may have used gaps for their components, and we might be
1755 -- dealing with a view conversion.
1760 -- If neither condition met, then nothing special to do, the back end
1761 -- can handle assignment of the entire component as a single entity.
1763 else
1767 -- At this stage we know that we must do a component wise assignment
1769 declare
1776 function Find_Component
1779 -- Find the component with the given name in the underlying record
1780 -- declaration for Typ. We need to use the actual entity because the
1781 -- type may be private and resolution by identifier alone would fail.
1783 function Make_Component_List_Assign
1786 -- Returns a sequence of statements to assign the components that
1787 -- are referenced in the given component list. The flag U_U is
1788 -- used to force the usage of the inferred value of the variant
1789 -- part expression as the switch for the generated case statement.
1791 function Make_Field_Assign
1794 -- Given C, the entity for a discriminant or component, build an
1795 -- assignment for the corresponding field values. The flag U_U
1796 -- signals the presence of an Unchecked_Union and forces the usage
1797 -- of the inferred discriminant value of C as the right-hand side
1798 -- of the assignment.
1801 -- Given CI, a component items list, construct series of statements
1802 -- for fieldwise assignment of the corresponding components.
1804 --------------------
1805 -- Find_Component --
1806 --------------------
1808 function Find_Component
1811 is
1815 begin
1821 -- The component may be a renamed discriminant, in
1822 -- which case check against the name of the original
1823 -- discriminant of the parent type.
1828 and then
1830 then
1840 --------------------------------
1841 -- Make_Component_List_Assign --
1842 --------------------------------
1844 function Make_Component_List_Assign
1847 is
1858 begin
1875 Statements =>
1880 -- Try to find a constrained type or a derived type to extract
1881 -- discriminant values from, so that the case statement built
1882 -- below can be folded by Expand_N_Case_Statement.
1885 Expr :=
1892 Expr :=
1900 then
1901 Expr :=
1907 else
1912 Expr :=
1915 Selector_Name =>
1928 -----------------------
1929 -- Make_Field_Assign --
1930 -----------------------
1932 function Make_Field_Assign
1935 is
1940 begin
1941 -- The discriminant entity to be used in the retrieval below must
1942 -- be one in the corresponding type, given that the assignment may
1943 -- be between derived and parent types.
1947 else
1951 -- In the case of an Unchecked_Union, use the discriminant
1952 -- constraint value as on the right-hand side of the assignment.
1955 Expr :=
1959 else
1960 Expr :=
1966 -- Generate the assignment statement. When the left-hand side
1967 -- is an object with an address clause present, force generated
1968 -- temporaries to be renamings so as to correctly assign to any
1969 -- overlaid objects.
1971 A :=
1973 Name =>
1975 Prefix =>
1976 Duplicate_Subexpr
1979 Renaming_Req =>
1982 Selector_Name =>
1986 -- Set Assignment_OK, so discriminants can be assigned
1993 then
2000 ------------------------
2001 -- Make_Field_Assigns --
2002 ------------------------
2008 begin
2014 -- Look for components, but exclude _tag field assignment if
2015 -- the special Componentwise_Assignment flag is set.
2020 then
2021 Append_To
2031 -- Start of processing for Expand_Assign_Record
2033 begin
2034 -- Note that we need to use the base types for this processing in
2035 -- order to retrieve the Type_Definition. In the constrained case,
2036 -- we filter out the non relevant fields in
2037 -- Make_Component_List_Assign.
2039 -- First copy the discriminants. This is done unconditionally. It
2040 -- is required in the unconstrained left side case, and also in the
2041 -- case where this assignment was constructed during the expansion
2042 -- of a type conversion (since initialization of discriminants is
2043 -- suppressed in this case). It is unnecessary but harmless in
2044 -- other cases.
2046 -- Special case: no copy if the target has no discriminants
2050 then
2057 -- If we are expanding the initialization of a derived record
2058 -- that constrains or renames discriminants of the parent, we
2059 -- must use the corresponding discriminant in the parent.
2061 declare
2064 begin
2065 if Inside_Init_Proc
2067 then
2069 else
2075 -- Within an initialization procedure this is the
2076 -- assignment to an unchecked union component, in which
2077 -- case there is no discriminant to initialize.
2082 else
2083 -- The assignment is part of a conversion from a
2084 -- derived unchecked union type with an inferable
2085 -- discriminant, to a parent type.
2090 else
2098 -- If the derived type has a stored constraint, assign the value
2099 -- of the corresponding discriminants explicitly, skipping those
2100 -- that are renamed discriminants. We cannot just retrieve them
2101 -- from the Rhs by selected component because they are invisible
2102 -- in the type of the right-hand side.
2105 declare
2109 begin
2116 and then
2119 E_Discriminant)
2120 then
2121 Assign :=
2123 Name =>
2126 Selector_Name =>
2127 New_Occurrence_Of
2142 -- We know the underlying type is a record, but its current view
2143 -- may be private. We must retrieve the usable record declaration.
2146 | N_Private_Extension_Declaration
2148 then
2150 else
2160 then
2164 else
2174 -------------------------------------
2175 -- Expand_Assign_With_Target_Names --
2176 -------------------------------------
2185 -- The entity of the left-hand side
2188 -- Replace occurrences of the target name by the proper entity: either
2189 -- the entity of the LHS in simple cases, or the formal of the
2190 -- constructed procedure otherwise.
2192 --------------------
2193 -- Replace_Target --
2194 --------------------
2197 begin
2201 -- The expression will be reanalyzed when the enclosing assignment
2202 -- is reanalyzed, so reset the entity, which may be a temporary
2203 -- created during analysis, e.g. a loop variable for an iterated
2204 -- component association. However, if entity is callable then
2205 -- resolution has established its proper identity (including in
2206 -- rewritten prefixed calls) so we must preserve it.
2211 then
2222 -- Local variables
2227 -- Start of processing for Expand_Assign_With_Target_Names
2229 begin
2232 -- The left-hand side is a direct name
2236 then
2240 -- Generate:
2241 -- LHS := ... LHS ...;
2248 -- The left-hand side is not a direct name, but is side-effect free.
2249 -- Capture its value in a temporary to avoid generating a procedure.
2250 -- We don't do this optimization if the target object's type may need
2251 -- finalization actions, because we don't want extra finalizations to
2252 -- be done for the temp object, and instead we use the more general
2253 -- procedure-based approach below.
2257 then
2261 -- Generate:
2262 -- T : LHS_Typ := LHS;
2270 -- Generate:
2271 -- LHS := ... T ...;
2278 -- Otherwise wrap the whole assignment statement in a procedure with an
2279 -- IN OUT parameter. The original assignment then becomes a call to the
2280 -- procedure with the left-hand side as an actual.
2282 else
2286 -- Generate:
2287 -- procedure P (T : in out LHS_Typ) is
2288 -- begin
2289 -- T := ... T ...;
2290 -- end P;
2296 Specification =>
2304 Parameter_Type =>
2309 Handled_Statement_Sequence =>
2316 -- Generate:
2317 -- P (LHS);
2325 -- Analyze rewritten node, either as assignment or procedure call
2330 -----------------------------------
2331 -- Expand_N_Assignment_Statement --
2332 -----------------------------------
2334 -- This procedure implements various cases where an assignment statement
2335 -- cannot just be passed on to the back end in untransformed state.
2345 begin
2346 -- Special case to check right away, if the Componentwise_Assignment
2347 -- flag is set, this is a reanalysis from the expansion of the primitive
2348 -- assignment procedure for a tagged type, and all we need to do is to
2349 -- expand to assignment of components, because otherwise, we would get
2350 -- infinite recursion (since this looks like a tagged assignment which
2351 -- would normally try to *call* the primitive assignment procedure).
2358 -- Defend against invalid subscripts on left side if we are in standard
2359 -- validity checking mode. No need to do this if we are checking all
2360 -- subscripts.
2362 -- Note that we do this right away, because there are some early return
2363 -- paths in this procedure, and this is required on all paths.
2365 if Validity_Checks_On
2366 and then Validity_Check_Default
2367 and then not Validity_Check_Subscripts
2368 then
2372 -- Separate expansion if RHS contain target names. Note that assignment
2373 -- may already have been expanded if RHS is aggregate.
2380 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
2382 -- Rewrite an assignment to X'Priority into a run-time call
2384 -- For example: X'Priority := New_Prio_Expr;
2385 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
2387 -- Note that although X'Priority is notionally an object, it is quite
2388 -- deliberately not defined as an aliased object in the RM. This means
2389 -- that it works fine to rewrite it as a call, without having to worry
2390 -- about complications that would other arise from X'Priority'Access,
2391 -- which is illegal, because of the lack of aliasing.
2394 declare
2401 begin
2402 -- Handle chains of renamings
2409 loop
2413 -- The attribute Priority applied to protected objects has been
2414 -- previously expanded into a call to the Get_Ceiling run-time
2415 -- subprogram. In restricted profiles this is not available.
2419 -- Look for the enclosing concurrent type
2428 -- Generate the first actual of the call
2435 -- Select the appropriate run-time call
2438 RT_Subprg_Name :=
2440 else
2441 RT_Subprg_Name :=
2445 Call :=
2460 -- Deal with assignment checks unless suppressed
2464 -- First deal with generation of range check if required,
2465 -- and then predicate checks if the type carries a predicate.
2466 -- If the Rhs is an expression these tests may have been applied
2467 -- already. This is the case if the RHS is a type conversion.
2468 -- Other such redundant checks could be removed ???
2472 then
2481 -- Check for a special case where a high level transformation is
2482 -- required. If we have either of:
2484 -- P.field := rhs;
2485 -- P (sub) := rhs;
2487 -- where P is a reference to a bit packed array, then we have to unwind
2488 -- the assignment. The exact meaning of being a reference to a bit
2489 -- packed array is as follows:
2491 -- An indexed component whose prefix is a bit packed array is a
2492 -- reference to a bit packed array.
2494 -- An indexed component or selected component whose prefix is a
2495 -- reference to a bit packed array is itself a reference ot a
2496 -- bit packed array.
2498 -- The required transformation is
2500 -- Tnn : prefix_type := P;
2501 -- Tnn.field := rhs;
2502 -- P := Tnn;
2504 -- or
2506 -- Tnn : prefix_type := P;
2507 -- Tnn (subscr) := rhs;
2508 -- P := Tnn;
2510 -- Since P is going to be evaluated more than once, any subscripts
2511 -- in P must have their evaluation forced.
2515 then
2516 declare
2522 begin
2523 -- Insert the post assignment first, because we want to copy the
2524 -- BPAR_Expr tree before it gets analyzed in the context of the
2525 -- pre assignment. Note that we do not analyze the post assignment
2526 -- yet (we cannot till we have completed the analysis of the pre
2527 -- assignment). As usual, the analysis of this post assignment
2528 -- will happen on its own when we "run into" it after finishing
2529 -- the current assignment.
2536 -- At this stage BPAR_Expr is a reference to a bit packed array
2537 -- where the reference was not expanded in the original tree,
2538 -- since it was on the left side of an assignment. But in the
2539 -- pre-assignment statement (the object definition), BPAR_Expr
2540 -- will end up on the right-hand side, and must be reexpanded. To
2541 -- achieve this, we reset the analyzed flag of all selected and
2542 -- indexed components down to the actual indexed component for
2543 -- the packed array.
2546 loop
2550 then
2552 else
2557 -- Now we can insert and analyze the pre-assignment
2559 -- If the right-hand side requires a transient scope, it has
2560 -- already been placed on the stack. However, the declaration is
2561 -- inserted in the tree outside of this scope, and must reflect
2562 -- the proper scope for its variable. This awkward bit is forced
2563 -- by the stricter scope discipline imposed by GCC 2.97.
2565 declare
2567 Scope_Is_Transient
2570 begin
2582 Pop_Scope;
2586 -- Now fix up the original assignment and continue processing
2591 -- We do not need to reanalyze that assignment, and we do not need
2592 -- to worry about references to the temporary, but we do need to
2593 -- make sure that the temporary is not marked as a true constant
2594 -- since we now have a generated assignment to it.
2600 -- When we have the appropriate type of aggregate in the expression (it
2601 -- has been determined during analysis of the aggregate by setting the
2602 -- delay flag), let's perform in place assignment and thus avoid
2603 -- creating a temporary.
2613 -- Apply discriminant check if required. If Lhs is an access type to a
2614 -- designated type with discriminants, we must always check. If the
2615 -- type has unknown discriminants, more elaborate processing below.
2619 then
2620 -- Skip discriminant check if change of representation. Will be
2621 -- done when the change of representation is expanded out.
2627 -- If the type is private without discriminants, and the full type
2628 -- has discriminants (necessarily with defaults) a check may still be
2629 -- necessary if the Lhs is aliased. The private discriminants must be
2630 -- visible to build the discriminant constraints.
2632 -- Only an explicit dereference that comes from source indicates
2633 -- aliasing. Access to formals of protected operations and entries
2634 -- create dereferences but are not semantic aliasings.
2640 then
2641 declare
2645 begin
2646 -- In the case of an expander-generated record subtype whose base
2647 -- type still appears private, Typ will have been set to that
2648 -- private type rather than the underlying record type (because
2649 -- Underlying type will have returned the record subtype), so it's
2650 -- necessary to apply Underlying_Type again to the base type to
2651 -- get the record type we need for the discriminant check. Such
2652 -- subtypes can be created for assignments in certain cases, such
2653 -- as within an instantiation passed this kind of private type.
2654 -- It would be good to avoid this special test, but making changes
2655 -- to prevent this odd form of record subtype seems difficult. ???
2667 -- If the Lhs has a private type with unknown discriminants, it may
2668 -- have a full view with discriminants, but those are nameable only
2669 -- in the underlying type, so convert the Rhs to it before potential
2670 -- checking. Convert Lhs as well, otherwise the actual subtype might
2671 -- not be constructible. If the discriminants have defaults the type
2672 -- is unconstrained and there is nothing to check.
2673 -- Ditto if a private type with unknown discriminants has a full view
2674 -- that is an unconstrained array, in which case a length check is
2675 -- needed.
2680 then
2691 -- In the access type case, we need the same discriminant check, and
2692 -- also range checks if we have an access to constrained array.
2696 then
2699 -- Skip discriminant check if change of representation. Will be
2700 -- done when the change of representation is expanded out.
2715 -- Ada 2005 (AI-231): Generate the run-time check
2721 -- If an actual is an out parameter of a null-excluding access
2722 -- type, there is access check on entry, so we set the flag
2723 -- Suppress_Assignment_Checks on the generated statement to
2724 -- assign the actual to the parameter block, and we do not want
2725 -- to generate an additional check at this point.
2728 then
2732 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2733 -- stand-alone obj of an anonymous access type. Do not install the check
2734 -- when the Lhs denotes a container cursor and the Next function employs
2735 -- an access type, because this can never result in a dangling pointer.
2741 then
2742 declare
2744 -- Look through renames to find the underlying entity.
2745 -- For assignment to a rename, we don't care about the
2746 -- Enclosing_Dynamic_Scope of the rename declaration.
2748 ----------------
2749 -- Lhs_Entity --
2750 ----------------
2755 begin
2758 -- Renamed_Object must return an Entity_Name here
2759 -- because of preceding "Present (E_E_A (...))" test.
2767 -- Local Declarations
2771 Condition =>
2773 Left_Opnd =>
2775 Right_Opnd =>
2777 Intval =>
2778 Scope_Depth
2779 (Enclosing_Dynamic_Scope
2785 Name =>
2786 New_Occurrence_Of
2787 (Effective_Extra_Accessibility
2789 Expression =>
2790 Accessibility_Level
2795 begin
2804 -- Case of assignment to a bit packed array element. If there is a
2805 -- change of representation this must be expanded into components,
2806 -- otherwise this is a bit-field assignment.
2810 then
2811 -- Normal case, no change of representation
2817 -- Change of representation case
2819 else
2820 -- Generate the following, to force component-by-component
2821 -- assignments in an efficient way. Otherwise each component
2822 -- will require a temporary and two bit-field manipulations.
2824 -- T1 : Elmt_Type;
2825 -- T1 := RhS;
2826 -- Lhs := T1;
2828 declare
2832 begin
2833 Stats :=
2834 New_List (
2837 Object_Definition =>
2852 -- Build-in-place function call case. This is for assignment statements
2853 -- that come from aggregate component associations or from init procs.
2854 -- User-written assignment statements with b-i-p calls are handled
2855 -- elsewhere.
2863 then
2868 begin
2869 -- In the controlled case, we ensure that function calls are
2870 -- evaluated before finalizing the target. In all cases, it makes
2871 -- the expansion easier if the side effects are removed first.
2876 -- Avoid recursion in the mechanism
2880 -- If dispatching assignment, we need to dispatch to _assign
2884 -- If the type is tagged, we may as well use the predefined
2885 -- primitive assignment. This avoids inlining a lot of code
2886 -- and in the class-wide case, the assignment is replaced
2887 -- by a dispatching call to _assign. It is suppressed in the
2888 -- case of assignments created by the expander that correspond
2889 -- to initializations, where we do want to copy the tag
2890 -- (Expand_Ctrl_Actions flag is set False in this case). It is
2891 -- also suppressed if restriction No_Dispatching_Calls is in
2892 -- force because in that case predefined primitives are not
2893 -- generated.
2897 and then Expand_Ctrl_Actions
2898 and then
2900 then
2901 -- We should normally not encounter any limited type here,
2902 -- except in the corner case where an assignment was not
2903 -- intended like the pathological case of a raise expression
2904 -- within a return statement.
2911 -- Fetch the primitive op _assign and proper type to call it.
2912 -- Because of possible conflicts between private and full view,
2913 -- fetch the proper type directly from the operation profile.
2915 declare
2920 begin
2921 -- If the assignment is dispatching, make sure to use the
2922 -- proper type.
2930 -- In case of assignment to a class-wide tagged type, before
2931 -- the assignment we generate run-time check to ensure that
2932 -- the tags of source and target match.
2938 then
2939 declare
2943 begin
2945 Lhs_Tag :=
2948 Selector_Name =>
2950 Rhs_Tag :=
2953 Selector_Name =>
2955 else
2956 -- Displace the pointer to the base of the objects
2957 -- applying 'Address, which is later expanded into
2958 -- a call to RE_Base_Address.
2960 Lhs_Tag :=
2962 Prefix =>
2967 Rhs_Tag :=
2969 Prefix =>
2978 Condition =>
2986 declare
2990 begin
2991 -- In order to dispatch the call to _assign the type of
2992 -- the actuals must match. Add conversion (if required).
3011 else
3014 -- We can't afford to have destructive Finalization Actions in
3015 -- the Self assignment case, so if the target and the source
3016 -- are not obviously different, code is generated to avoid the
3017 -- self assignment case:
3019 -- if lhs'address /= rhs'address then
3020 -- <code for controlled and/or tagged assignment>
3021 -- end if;
3023 -- Skip this if Restriction (No_Finalization) is active
3026 and then Expand_Ctrl_Actions
3028 then
3031 Condition =>
3033 Left_Opnd =>
3038 Right_Opnd =>
3046 -- We need to set up an exception handler for implementing
3047 -- 7.6.1(18). The remaining adjustments are tackled by the
3048 -- implementation of adjust for record_controllers (see
3049 -- s-finimp.adb).
3051 -- This is skipped if we have no finalization
3053 if Expand_Ctrl_Actions
3055 then
3058 Handled_Statement_Sequence =>
3068 Handled_Statement_Sequence =>
3071 -- If no restrictions on aborts, protect the whole assignment
3072 -- for controlled objects as per 9.8(11).
3075 and then Expand_Ctrl_Actions
3076 and then Abort_Allowed
3077 then
3078 declare
3080 New_Internal_Entity
3084 begin
3095 -- Present the Abort_Undefer_Direct function to the backend
3096 -- so that it can inline the call to the function.
3100 Expand_At_End_Handler
3105 -- N has been rewritten to a block statement for which it is
3106 -- known by construction that no checks are necessary: analyze
3107 -- it with all checks suppressed.
3113 -- Array types
3116 declare
3119 begin
3121 N_Type_Conversion | N_Qualified_Expression
3122 loop
3130 -- Record types
3136 -- Scalar types. This is where we perform the processing related to the
3137 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
3138 -- scalar values.
3142 -- Case where right side is known valid
3146 -- Here the right side is valid, so it is fine. The case to deal
3147 -- with is when the left side is a local variable reference whose
3148 -- value is not currently known to be valid. If this is the case,
3149 -- and the assignment appears in an unconditional context, then
3150 -- we can mark the left side as now being valid if one of these
3151 -- conditions holds:
3153 -- The expression of the right side has Do_Range_Check set so
3154 -- that we know a range check will be performed. Note that it
3155 -- can be the case that a range check is omitted because we
3156 -- make the assumption that we can assume validity for operands
3157 -- appearing in the right side in determining whether a range
3158 -- check is required
3160 -- The subtype of the right side matches the subtype of the
3161 -- left side. In this case, even though we have not checked
3162 -- the range of the right side, we know it is in range of its
3163 -- subtype if the expression is valid.
3168 then
3171 then
3176 -- Case where right side may be invalid in the sense of the RM
3177 -- reference above. The RM does not require that we check for the
3178 -- validity on an assignment, but it does require that the assignment
3179 -- of an invalid value not cause erroneous behavior.
3181 -- The general approach in GNAT is to use the Is_Known_Valid flag
3182 -- to avoid the need for validity checking on assignments. However
3183 -- in some cases, we have to do validity checking in order to make
3184 -- sure that the setting of this flag is correct.
3186 else
3187 -- Validate right side if we are validating copies
3189 if Validity_Checks_On
3190 and then Validity_Check_Copies
3191 then
3192 -- Skip this if left-hand side is an array or record component
3193 -- and elementary component validity checks are suppressed.
3196 and then not Validity_Check_Components
3197 then
3199 else
3203 -- We can propagate this to the left side where appropriate
3208 then
3212 -- Otherwise check to see what should be done
3214 -- If left side is a local variable, then we just set its flag to
3215 -- indicate that its value may no longer be valid, since we are
3216 -- copying a potentially invalid value.
3221 -- Check for case of a nonlocal variable on the left side which
3222 -- is currently known to be valid. In this case, we simply ensure
3223 -- that the right side is valid. We only play the game of copying
3224 -- validity status for local variables, since we are doing this
3225 -- statically, not by tracing the full flow graph.
3229 then
3230 -- Note: If Validity_Checking mode is set to none, we ignore
3231 -- the Ensure_Valid call so don't worry about that case here.
3235 -- In all other cases, we can safely copy an invalid value without
3236 -- worrying about the status of the left side. Since it is not a
3237 -- variable reference it will not be considered
3238 -- as being known to be valid in any case.
3240 else
3246 exception
3251 ------------------------------
3252 -- Expand_N_Block_Statement --
3253 ------------------------------
3255 -- Encode entity names defined in block statement
3258 begin
3262 -----------------------------
3263 -- Expand_N_Case_Statement --
3264 -----------------------------
3277 -- Expand a case statement whose selecting expression is not discrete
3279 -----------------------------------
3280 -- Expand_General_Case_Statement --
3281 -----------------------------------
3284 -- expand into a block statement
3294 then Expr
3308 -- If we are going to need a choice index object (that is, if
3309 -- Multidefined_Bindings is true for at least one of the case
3310 -- alternatives), then create and return that object's declaration.
3311 -- Otherwise, return Empty; no need for a decl in that case because
3312 -- it would never be referenced.
3314 ---------------------------------
3315 -- Choice_Index_Decl_If_Needed --
3316 ---------------------------------
3320 begin
3323 return Make_Object_Declaration
3325 Defining_Identifier =>
3327 Object_Definition =>
3338 function Pattern_Match
3344 -- Returns a Boolean-valued expression indicating a pattern match
3345 -- for a given pattern and object. If Choice_Index is nonzero,
3346 -- then Choice_Index is assigned to Choice_Index_Decl (unless
3347 -- Suppress_Choice_Index_Update is specified, which should only
3348 -- be the case for a recursive call where the caller has already
3349 -- taken care of the update). Pattern occurs as a choice (or as a
3350 -- subexpression of a choice) of the case statement alternative Alt.
3352 function Top_Level_Pattern_Match_Condition
3354 -- Returns a Boolean-valued expression indicating a pattern match
3355 -- for the given alternative's list of choices.
3357 -------------------
3358 -- Pattern_Match --
3359 -------------------
3361 function Pattern_Match
3367 is
3368 procedure Finish_Binding_Object_Declaration
3370 -- Finish the work that was started during analysis to
3371 -- declare a binding object. If we are generating a copy,
3372 -- then initialize it. If we are generating a renaming, then
3373 -- initialize the access value designating the renamed object.
3377 Name =>
3378 New_Occurrence_Of
3382 function PM
3390 -- convenient rename for recursive calls
3393 -- Returns the Nth (well, ok, the Idxth) element of Object
3395 ---------------------------------------
3396 -- Finish_Binding_Object_Declaration --
3397 ---------------------------------------
3399 procedure Finish_Binding_Object_Declaration
3401 is
3414 -- Declare_Copy indicates which of the two approaches
3415 -- was chosen during analysis: declare (and initialize)
3416 -- a new variable, or use access values to declare a renaming
3417 -- of the appropriate subcomponent of the selector value.
3420 -- If there is only one choice for this alternative, then
3421 -- simply return the argument. If there is more than one
3422 -- choice, then wrap an if-statement around the argument
3423 -- so that it is only executed if the current choice matches.
3425 ----------------------
3426 -- Make_Conditional --
3427 ----------------------
3430 is
3432 begin
3434 Condition :=
3436 New_Occurrence_Of
3443 else
3444 -- execute Stmt unconditionally
3449 begin
3450 -- find the variable to be modified (and its declaration)
3451 loop
3453 | N_Object_Renaming_Declaration
3454 then
3462 -- For a binding object, we sometimes make a copy and
3463 -- sometimes introduce a renaming. That decision is made
3464 -- elsewhere. The renaming case involves dereferencing an
3465 -- access value because of the possibility of multiple
3466 -- choices (with multiple binding definitions) for a single
3467 -- alternative. In the copy case, we initialize the copy
3468 -- here (conditionally if there are multiple choices); in the
3469 -- renaming case, we initialize (again, maybe conditionally)
3470 -- the access value.
3473 declare
3481 begin
3486 else
3489 declare
3497 Expression =>
3501 begin
3502 Insert_After
3507 -- Delete bogus initial value built during analysis.
3508 -- Look for "5432" in sem_case.adb.
3510 N_Unchecked_Type_Conversion);
3519 ---------------------
3520 -- Indexed_Element --
3521 ---------------------
3526 Left_Opnd =>
3530 Right_Opnd =>
3532 begin
3538 -- Start of processing for Pattern_Match
3540 begin
3544 -- Add Choice_Index update as a side effect of evaluating
3545 -- this condition and try again, this time suppressing
3546 -- Choice_Index update.
3550 Expression =>
3558 then
3559 declare
3561 begin
3563 Val := Get_Enum_Lit_From_Pos
3565 else
3574 declare
3576 begin
3579 -- Nonpositional aggregates currently unimplemented.
3580 -- We flag that case during analysis, so an assertion
3581 -- is ok here.
3582 --
3583 pragma Assert
3586 declare
3595 begin
3601 declare
3604 begin
3606 Result :=
3609 Right_Opnd =>
3620 -- positional notation should have been normalized
3623 declare
3624 Component_Assoc : Node_Id
3631 Selector_Name => New_Occurrence_Of
3633 begin
3639 pragma Assert
3645 -- Box matches anything
3647 pragma Assert
3649 else
3652 Right_Opnd =>
3654 Expression
3659 -- If this component association defines
3660 -- (in the case where the pattern matches)
3661 -- the value of a binding object, then
3662 -- prepend to the statement list for this
3663 -- alternative an assignment to the binding
3664 -- object. This assignment will be conditional
3665 -- if there is more than one choice.
3668 then
3669 Finish_Binding_Object_Declaration
3685 declare
3689 -- If the component type is not a standard character
3690 -- type then this string lit should have already been
3691 -- transformed into an aggregate in
3692 -- Resolve_String_Literal.
3693 --
3706 begin
3712 declare
3718 begin
3720 Char_Lit :=
3725 Result :=
3728 Right_Opnd =>
3742 Right_Opnd =>
3750 Right_Opnd => New_Occurrence_Of
3762 -- aggregate expansion sometimes introduces conversions
3766 then
3774 -- Avoid cascading errors
3779 ---------------------------------------
3780 -- Top_Level_Pattern_Match_Condition --
3781 ---------------------------------------
3783 function Top_Level_Pattern_Match_Condition
3785 is
3795 begin
3805 do
3813 Right_Opnd => Pattern_Match
3824 -- Process subsequent alternatives
3826 -----------------
3827 -- Elsif_Parts --
3828 -----------------
3833 begin
3834 loop
3841 Result);
3847 -- Returns a "raise Constraint_Error" statement if
3848 -- exception propagate is permitted and No_List otherwise.
3850 ---------------------
3851 -- Else_Statements --
3852 ---------------------
3855 begin
3858 else
3864 -- Local constants
3875 -- Start of processing for Expand_General_Case_Statment
3877 begin
3884 Handled_Statement_Sequence =>
3889 -- Start of processing for Expand_N_Case_Statement
3891 begin
3898 -- Check for the situation where we know at compile time which branch
3899 -- will be taken.
3901 -- If the value is static but its subtype is predicated and the value
3902 -- does not obey the predicate, the value is marked non-static, and
3903 -- there can be no corresponding static alternative. In that case we
3904 -- replace the case statement with an exception, regardless of whether
3905 -- assertions are enabled or not, unless predicates are ignored.
3911 then
3920 then
3923 -- Do not consider controlled objects found in a case statement which
3924 -- actually models a case expression because their early finalization
3925 -- will affect the result of the expression.
3931 -- Move statements from this alternative after the case statement.
3932 -- They are already analyzed, so will be skipped by the analyzer.
3936 -- That leaves the case statement as a shell. So now we can kill all
3937 -- other alternatives in the case statement.
3941 declare
3944 begin
3945 -- Loop through case alternatives, skipping pragmas, and skipping
3946 -- the one alternative that we select (and therefore retain).
3952 then
3964 -- Here if the choice is not determined at compile time
3966 declare
3975 begin
3979 else
3983 -- First step is to worry about possible invalid argument. The RM
3984 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
3985 -- outside the base range), then Constraint_Error must be raised.
3987 -- Case of validity check required (validity checks are on, the
3988 -- expression is not known to be valid, and the case statement
3989 -- comes from source -- no need to validity check internally
3990 -- generated case statements).
3992 if Validity_Check_Default
3994 then
3995 -- Recognize the simple case where Expr is an object reference
3996 -- and the case statement is directly preceded by an
3997 -- "if Obj'Valid then": in this case, do not emit another validity
3998 -- check.
4000 declare
4003 begin
4007 = N_Attribute_Reference
4009 then
4015 then
4026 -- If there is only a single alternative, just replace it with the
4027 -- sequence of statements since obviously that is what is going to
4028 -- be executed in all cases.
4034 -- We still need to evaluate the expression if it has any side
4035 -- effects.
4040 -- Do not consider controlled objects found in a case statement
4041 -- which actually models a case expression because their early
4042 -- finalization will affect the result of the expression.
4050 -- That leaves the case statement as a shell. The alternative that
4051 -- will be executed is reset to a null list. So now we can kill
4052 -- the entire case statement.
4058 -- An optimization. If there are only two alternatives, and only
4059 -- a single choice, then rewrite the whole case statement as an
4060 -- if statement, since this can result in subsequent optimizations.
4061 -- This helps not only with case statements in the source of a
4062 -- simple form, but also with generated code (discriminant check
4063 -- functions in particular).
4065 -- Note: it is OK to do this before expanding out choices for any
4066 -- static predicates, since the if statement processing will handle
4067 -- the static predicate case fine.
4078 -- For TRUE, generate "expression", not expression = true
4082 then
4085 -- For FALSE, generate "expression" and switch then/else
4089 then
4094 -- For a range, generate "expression in range"
4101 then
4102 Cond :=
4107 -- A subtype indication is not a legal operator in a membership
4108 -- test, so retrieve its range.
4111 Cond :=
4114 Right_Opnd =>
4115 Relocate_Node
4118 -- For any other subexpression "expression = value"
4120 else
4121 Cond :=
4127 -- Now rewrite the case as an IF
4135 -- The rewritten if statement needs to inherit whether the
4136 -- case statement was expanded from a conditional expression,
4137 -- for proper handling of nested controlled objects.
4147 -- If the last alternative is not an Others choice, replace it with
4148 -- an N_Others_Choice. Note that we do not bother to call Analyze on
4149 -- the modified case statement, since it's only effect would be to
4150 -- compute the contents of the Others_Discrete_Choices which is not
4151 -- needed by the back end anyway.
4153 -- The reason for this is that the back end always needs some default
4154 -- for a switch, so if we have not supplied one in the processing
4155 -- above for validity checking, then we need to supply one here.
4160 -- If Predicates_Ignored is true the value does not satisfy the
4161 -- predicate, and there is no Others choice, Constraint_Error
4162 -- must be raised (4.5.7 (21/3)).
4165 declare
4175 begin
4180 else
4181 Set_Others_Discrete_Choices
4188 -- Deal with possible declarations of controlled objects, and also
4189 -- with rewriting choice sequences for static predicate references.
4194 -- Do not consider controlled objects found in a case statement
4195 -- which actually models a case expression because their early
4196 -- finalization will affect the result of the expression.
4211 -----------------------------
4212 -- Expand_N_Exit_Statement --
4213 -----------------------------
4215 -- The only processing required is to deal with a possible C/Fortran
4216 -- boolean value used as the condition for the exit statement.
4219 begin
4223 ----------------------------------
4224 -- Expand_Formal_Container_Loop --
4225 ----------------------------------
4240 begin
4241 -- The expansion of a formal container loop resembles the one for Ada
4242 -- containers. The only difference is that the primitives mention the
4243 -- domain of iteration explicitly, and function First applied to the
4244 -- container yields a cursor directly.
4246 -- Cursor : Cursor_type := First (Container);
4247 -- while Has_Element (Cursor, Container) loop
4248 -- <original loop statements>
4249 -- Cursor := Next (Container, Cursor);
4250 -- end loop;
4252 Build_Formal_Container_Iteration
4257 -- Build a block to capture declaration of the cursor
4262 Handled_Statement_Sequence =>
4266 -- The loop parameter is declared by an object declaration, but within
4267 -- the loop we must prevent user assignments to it, so we analyze the
4268 -- declaration and reset the entity kind, before analyzing the rest of
4269 -- the loop.
4275 -- The cursor was marked as a loop parameter to prevent user assignments
4276 -- to it, however this renders the advancement step illegal as it is not
4277 -- possible to change the value of a constant. Flag the advancement step
4278 -- as a legal form of assignment to remedy this side effect.
4283 -- Because we have to analyze the initial declaration of the loop
4284 -- parameter multiple times its scope is incorrectly set at this point
4285 -- to the one surrounding the block statement - so set the scope
4286 -- manually to be the actual block statement, and indicate that it is
4287 -- not visible after the block has been analyzed.
4293 ------------------------------------------
4294 -- Expand_Formal_Container_Element_Loop --
4295 ------------------------------------------
4318 begin
4319 -- For an element iterator, the Element aspect must be present,
4320 -- (this is checked during analysis).
4322 -- We create a block to hold a variable declaration initialized with
4323 -- a call to Element, and generate:
4325 -- Cursor : Cursor_Type := First (Container);
4326 -- while Has_Element (Cursor, Container) loop
4327 -- declare
4328 -- Elmt : Element_Type := Element (Container, Cursor);
4329 -- begin
4330 -- <original loop statements>
4331 -- Cursor := Next (Container, Cursor);
4332 -- end;
4333 -- end loop;
4335 Build_Formal_Container_Iteration
4342 -- The loop parameter is declared by an object declaration, but within
4343 -- the loop we must prevent user assignments to it; the following flag
4344 -- accomplishes that.
4348 -- Declaration for Element
4350 Elmt_Decl :=
4363 New_List
4366 Handled_Statement_Sequence =>
4370 -- The element is only modified in expanded code, so it appears as
4371 -- unassigned to the warning machinery. We must suppress this spurious
4372 -- warning explicitly.
4380 ----------------------------------
4381 -- Expand_N_Goto_When_Statement --
4382 ----------------------------------
4386 begin
4397 ---------------------------
4398 -- Expand_N_If_Statement --
4399 ---------------------------
4401 -- First we deal with the case of C and Fortran convention boolean values,
4402 -- with zero/nonzero semantics.
4404 -- Second, we deal with the obvious rewriting for the cases where the
4405 -- condition of the IF is known at compile time to be True or False.
4407 -- Third, we remove elsif parts which have non-empty Condition_Actions and
4408 -- rewrite as independent if statements. For example:
4410 -- if x then xs
4411 -- elsif y then ys
4412 -- ...
4413 -- end if;
4415 -- becomes
4416 --
4417 -- if x then xs
4418 -- else
4419 -- <<condition actions of y>>
4420 -- if y then ys
4421 -- ...
4422 -- end if;
4423 -- end if;
4425 -- This rewriting is needed if at least one elsif part has a non-empty
4426 -- Condition_Actions list. We also do the same processing if there is a
4427 -- constant condition in an elsif part (in conjunction with the first
4428 -- processing step mentioned above, for the recursive call made to deal
4429 -- with the created inner if, this deals with properly optimizing the
4430 -- cases of constant elsif conditions).
4440 -- Indicates whether we want warnings when we delete branches of the
4441 -- if statement based on constant condition analysis. We never want
4442 -- these warnings for expander generated code.
4444 begin
4445 -- Do not consider controlled objects found in an if statement which
4446 -- actually models an if expression because their early finalization
4447 -- will affect the result of the expression.
4455 -- The following loop deals with constant conditions for the IF. We
4456 -- need a loop because as we eliminate False conditions, we grab the
4457 -- first elsif condition and use it as the primary condition.
4461 -- If condition is True, we can simply rewrite the if statement now
4462 -- by replacing it by the series of then statements.
4466 -- All the else parts can be killed
4476 -- If condition is False, then we can delete the condition and
4477 -- the Then statements
4479 else
4480 -- We do not delete the condition if constant condition warnings
4481 -- are enabled, since otherwise we end up deleting the desired
4482 -- warning. Of course the backend will get rid of this True/False
4483 -- test anyway, so nothing is lost here.
4491 -- If there are no elsif statements, then we simply replace the
4492 -- entire if statement by the sequence of else statements.
4498 else
4506 -- If there are elsif statements, the first of them becomes the
4507 -- if/then section of the rebuilt if statement This is the case
4508 -- where we loop to reprocess this copied condition.
4510 else
4516 -- Hed might have been captured as the condition determining
4517 -- the current value for an entity. Now it is detached from
4518 -- the tree, so a Current_Value pointer in the condition might
4519 -- need to be updated.
4530 -- Loop through elsif parts, dealing with constant conditions and
4531 -- possible condition actions that are present.
4536 -- Do not consider controlled objects found in an if statement which
4537 -- actually models an if expression because their early finalization
4538 -- will affect the result of the expression.
4546 -- If there are condition actions, then rewrite the if statement as
4547 -- indicated above. We also do the same rewrite for a True or False
4548 -- condition. The further processing of this constant condition is
4549 -- then done by the recursive call to expand the newly created if
4550 -- statement
4554 then
4555 New_If :=
4562 -- Elsif parts for new if come from remaining elsif's of parent
4584 -- Note this is not an implicit if statement, since it is part of
4585 -- an explicit if statement in the source (or of an implicit if
4586 -- statement that has already been tested). We set the flag after
4587 -- calling Analyze to avoid generating extra warnings specific to
4588 -- pure if statements, however (see Sem_Ch5.Analyze_If_Statement).
4593 -- No special processing for that elsif part, move to next
4595 else
4600 -- Some more optimizations applicable if we still have an IF statement
4606 -- Another optimization, special cases that can be simplified
4608 -- if expression then
4609 -- return [standard.]true;
4610 -- else
4611 -- return [standard.]false;
4612 -- end if;
4614 -- can be changed to:
4616 -- return expression;
4618 -- and
4620 -- if expression then
4621 -- return [standard.]false;
4622 -- else
4623 -- return [standard.]true;
4624 -- end if;
4626 -- can be changed to:
4628 -- return not (expression);
4630 -- Do these optimizations only for internally generated code and only
4631 -- when -fpreserve-control-flow isn't set, to preserve the original
4632 -- source control flow.
4641 then
4642 declare
4649 begin
4651 and then
4653 then
4658 and then
4660 then
4663 then
4671 then
4674 Expression =>
4685 --------------------------
4686 -- Expand_Iterator_Loop --
4687 --------------------------
4696 begin
4697 -- Processing for arrays
4706 else
4710 -- Processing for containers
4712 else
4713 Expand_Iterator_Loop_Over_Container
4718 -------------------------------------
4719 -- Expand_Iterator_Loop_Over_Array --
4720 -------------------------------------
4736 begin
4744 -- for Element of Array loop
4746 -- It requires an internally generated cursor to iterate over the array
4752 -- Generate:
4753 -- Element : Component_Type renames Array (Iterator);
4754 -- Iterator is the index value, or a list of index values
4755 -- in the case of a multidimensional array.
4757 Ind_Comp :=
4762 -- Propagate the original node to the copy since the analysis of the
4763 -- following object renaming declaration relies on the original node.
4770 Subtype_Mark =>
4774 -- Mark the loop variable as needing debug info, so that expansion
4775 -- of the renaming will result in Materialize_Entity getting set via
4776 -- Debug_Renaming_Declaration. (This setting is needed here because
4777 -- the setting in Freeze_Entity comes after the expansion, which is
4778 -- too late. ???)
4782 -- Generate:
4784 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
4785 -- Element : Component_Type renames Array (Iterator);
4786 -- <original loop statements>
4787 -- end loop;
4789 -- If this is an iteration over a multidimensional array, the
4790 -- innermost loop is over the last dimension in Ada, and over
4791 -- the first dimension in Fortran.
4795 else
4799 Core_Loop :=
4801 Iteration_Scheme =>
4803 Loop_Parameter_Specification =>
4806 Discrete_Subtype_Definition =>
4816 -- Processing for multidimensional array. The body of each loop is
4817 -- a loop over a previous dimension, going in decreasing order in Ada
4818 -- and in increasing order in Fortran.
4824 else
4830 -- Generate the dimension loops starting from the innermost one
4832 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
4833 -- <core loop>
4834 -- end loop;
4836 Core_Loop :=
4838 Iteration_Scheme =>
4840 Loop_Parameter_Specification =>
4843 Discrete_Subtype_Definition =>
4853 -- Update the previously created object renaming declaration with
4854 -- the new iterator, by adding the index of the next loop to the
4855 -- indexed component, in the order that corresponds to the
4856 -- convention.
4861 else
4868 -- Inherit the loop identifier from the original loop. This ensures that
4869 -- the scope stack is consistent after the rewriting.
4879 -----------------------------------------
4880 -- Expand_Iterator_Loop_Over_Container --
4881 -----------------------------------------
4883 -- For a 'for ... in' loop, such as:
4885 -- for Cursor in Iterator_Function (...) loop
4886 -- ...
4887 -- end loop;
4889 -- we generate:
4891 -- Iter : Iterator_Type := Iterator_Function (...);
4892 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
4893 -- while Has_Element (Cursor) loop
4894 -- ...
4895 --
4896 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
4897 -- end loop;
4899 -- For a 'for ... of' loop, such as:
4901 -- for X of Container loop
4902 -- ...
4903 -- end loop;
4905 -- the RM implies the generation of:
4907 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
4908 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
4909 -- while Has_Element (Cursor) loop
4910 -- declare
4911 -- X : Element_Type renames Element (Cursor).Element.all;
4912 -- -- or Constant_Element
4913 -- begin
4914 -- ...
4915 -- end;
4916 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
4917 -- end loop;
4919 -- In the general case, we do what the RM says. However, the operations
4920 -- Element and Iter.Next are slow, which is bad inside a loop, because they
4921 -- involve dispatching via interfaces, secondary stack manipulation,
4922 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
4923 -- predefined containers, we use an equivalent but optimized expansion.
4925 -- In the optimized case, we make use of these:
4927 -- procedure Next (Position : in out Cursor); -- instead of Iter.Next
4929 -- function Pseudo_Reference
4930 -- (Container : aliased Vector'Class) return Reference_Control_Type;
4932 -- type Element_Access is access all Element_Type;
4934 -- function Get_Element_Access
4935 -- (Position : Cursor) return not null Element_Access;
4937 -- Next is declared in the visible part of the container packages.
4938 -- The other three are added in the private part. (We're not supposed to
4939 -- pollute the namespace for clients. The compiler has no trouble breaking
4940 -- privacy to call things in the private part of an instance.)
4942 -- Source:
4944 -- for X of My_Vector loop
4945 -- X.Count := X.Count + 1;
4946 -- ...
4947 -- end loop;
4949 -- The compiler will generate:
4951 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector);
4952 -- -- Reversible_Iterator is an interface. Iterate is the
4953 -- -- Default_Iterator aspect of Vector. This increments Lock,
4954 -- -- disallowing tampering with cursors. Unfortunately, it does not
4955 -- -- increment Busy. The result of Iterate is Limited_Controlled;
4956 -- -- finalization will decrement Lock. This is a build-in-place
4957 -- -- dispatching call to Iterate.
4959 -- Cur : Cursor := First (Iter); -- or Last
4960 -- -- Dispatching call via interface.
4962 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
4963 -- -- Pseudo_Reference increments Busy, to detect tampering with
4964 -- -- elements, as required by RM. Also redundantly increment
4965 -- -- Lock. Finalization of Control will decrement both Busy and
4966 -- -- Lock. Pseudo_Reference returns a record containing a pointer to
4967 -- -- My_Vector, used by Finalize.
4968 -- --
4969 -- -- Control is not used below, except to finalize it -- it's purely
4970 -- -- an RAII thing. This is needed because we are eliminating the
4971 -- -- call to Reference within the loop.
4973 -- while Has_Element (Cur) loop
4974 -- declare
4975 -- X : My_Element renames Get_Element_Access (Cur).all;
4976 -- -- Get_Element_Access returns a pointer to the element
4977 -- -- designated by Cur. No dispatching here, and no horsing
4978 -- -- around with access discriminants. This is instead of the
4979 -- -- existing
4980 -- --
4981 -- -- X : My_Element renames Reference (Cur).Element.all;
4982 -- --
4983 -- -- which creates a controlled object.
4984 -- begin
4985 -- -- Any attempt to tamper with My_Vector here in the loop
4986 -- -- will correctly raise Program_Error, because of the
4987 -- -- Control.
4988 --
4989 -- X.Count := X.Count + 1;
4990 -- ...
4991 --
4992 -- Next (Cur); -- or Prev
4993 -- -- This is instead of "Cur := Next (Iter, Cur);"
4994 -- end;
4995 -- -- No finalization here
4996 -- end loop;
4997 -- Finalize Iter and Control here, decrementing Lock twice and Busy
4998 -- once.
5000 -- This optimization makes "for ... of" loops over 30 times faster in cases
5001 -- measured.
5003 procedure Expand_Iterator_Loop_Over_Container
5009 is
5016 -- Maybe wrapped in a conditional if a filter is present
5028 -- Only for optimized version of "for ... of"
5031 -- The package in which the iterator interface is instantiated. This is
5032 -- typically an instance within the container package.
5035 -- The package in which the container type is declared
5037 begin
5045 -- Determine the advancement and initialization steps for the cursor.
5046 -- Analysis of the expanded loop will verify that the container has a
5047 -- reverse iterator.
5052 else
5057 -- The type of the iterator is the return type of the Iterate function
5058 -- used. For the "of" form this is the default iterator for the type,
5059 -- otherwise it is the type of the explicit function used in the
5060 -- iterator specification. The most common case will be an Iterate
5061 -- function in the container package.
5063 -- The Iterator type is declared in an instance within the container
5064 -- package itself, for example:
5066 -- package Vector_Iterator_Interfaces is new
5067 -- Ada.Iterator_Interfaces (Cursor, Has_Element);
5069 -- If the container type is a derived type, the cursor type is found in
5070 -- the package of the ultimate ancestor type.
5074 else
5082 function Get_Default_Iterator
5084 -- Return the default iterator for a specific type. If the type is
5085 -- derived, we return the inherited or overridden one if
5086 -- appropriate.
5088 --------------------------
5089 -- Get_Default_Iterator --
5090 --------------------------
5092 function Get_Default_Iterator
5094 is
5100 begin
5103 -- A previous version of GNAT allowed indexing aspects to be
5104 -- redefined on derived container types, while the default
5105 -- iterator was inherited from the parent type. This
5106 -- nonstandard extension is preserved for use by the
5107 -- modeling project under debug flag -gnatd.X.
5112 then
5113 Container_Arg :=
5115 Subtype_Mark =>
5116 New_Occurrence_Of
5125 -- The default iterator must be a primitive operation of the
5126 -- type, at the same dispatch slot position. The DT position
5127 -- may not be established if type is not frozen yet.
5134 or else
5138 then
5145 -- If we didn't find it, then our parent type is not
5146 -- iterable, so we return the Default_Iterator aspect of
5147 -- this type.
5151 -- Otherwise not a derived type
5153 else
5158 -- Local variables
5166 -- Start of processing for Handle_Of
5168 begin
5170 Default_Iter :=
5172 else
5178 -- For a container element iterator, the iterator type is obtained
5179 -- from the corresponding aspect, whose return type is descended
5180 -- from the corresponding interface type in some instance of
5181 -- Ada.Iterator_Interfaces. The actuals of that instantiation
5182 -- are Cursor and Has_Element.
5186 -- The iterator type, which is a class-wide type, may itself be
5187 -- derived locally, so the desired instantiation is the scope of
5188 -- the root type of the iterator type.
5192 -- Find declarations needed for "for ... of" optimization
5193 -- These declarations come from GNAT sources or sources
5194 -- derived from them. User code may include additional
5195 -- overloadings with similar names, and we need to perforn
5196 -- some reasonable resolution to find the needed primitives.
5197 -- It is unclear whether this mechanism is fragile if a user
5198 -- makes arbitrary changes to the private part of a package
5199 -- that supports iterators.
5203 -- Get_Element_Access function with one parameter called
5204 -- Position.
5211 then
5215 -- Next or Prev procedure with one parameter called
5216 -- Position.
5223 then
5241 then
5245 Object_Definition =>
5247 Expression =>
5249 Name =>
5251 Parameter_Associations =>
5255 -- Rewrite domain of iteration as a call to the default iterator
5256 -- for the container type. The formal may be an access parameter
5257 -- in which case we must build a reference to the container.
5259 declare
5261 begin
5263 Arg :=
5267 else
5273 Name =>
5280 -- Find cursor type in proper iterator package, which is an
5281 -- instantiation of Iterator_Interfaces.
5294 Decl :=
5297 Subtype_Mark =>
5299 Name =>
5301 Prefix =>
5303 Name =>
5305 Parameter_Associations =>
5308 else
5309 Decl :=
5312 Subtype_Mark =>
5314 Name =>
5317 Expressions =>
5321 -- The defining identifier in the iterator is user-visible and
5322 -- must be visible in the debugger.
5326 -- If the container does not have a variable indexing aspect,
5327 -- the element is a constant in the loop. The container itself
5328 -- may be constant, in which case the element is a constant as
5329 -- well. The container has been rewritten as a call to Iterate,
5330 -- so examine original node.
5335 then
5342 -- X in Iterate (S) : type of iterator is type of explicitly given
5343 -- Iterate function, and the loop variable is the cursor. It will be
5344 -- assigned in the loop and must be a variable.
5346 else
5349 -- The iterator type, which is a class-wide type, may itself be
5350 -- derived locally, so the desired instantiation is the scope of
5351 -- the root type of the iterator type, as in the "of" case.
5359 -- For both iterator forms, add a call to the step operation to advance
5360 -- the cursor. Generate:
5362 -- Cursor := Iterator.Next (Cursor);
5364 -- or else
5366 -- Cursor := Next (Cursor);
5369 declare
5373 begin
5374 Step_Call :=
5376 Name =>
5384 else
5385 declare
5388 begin
5389 Rhs :=
5391 Name =>
5406 -- Generate:
5407 -- while Has_Element (Cursor) loop
5408 -- <Stats>
5409 -- end loop;
5411 -- Has_Element is the second actual in the iterator package
5413 New_Loop :=
5415 Iteration_Scheme =>
5417 Condition =>
5419 Name =>
5420 New_Occurrence_Of
5428 -- If present, preserve identifier of loop, which can be used in an exit
5429 -- statement in the body.
5435 -- Create the declarations for Iterator and cursor and insert them
5436 -- before the source loop. Given that the domain of iteration is already
5437 -- an entity, the iterator is just a renaming of that entity. Possible
5438 -- optimization ???
5446 -- Create declaration for cursor
5448 declare
5452 Object_Definition =>
5454 Expression =>
5456 Prefix =>
5458 Selector_Name =>
5461 begin
5462 -- The cursor is only modified in expanded code, so it appears
5463 -- as unassigned to the warning machinery. We must suppress this
5464 -- spurious warning explicitly. The cursor's kind is that of the
5465 -- original loop parameter (it is a constant if the domain of
5466 -- iteration is constant).
5475 -- If the range of iteration is given by a function call that returns
5476 -- a container, the finalization actions have been saved in the
5477 -- Condition_Actions of the iterator. Insert them now at the head of
5478 -- the loop.
5486 -----------------------------
5487 -- Expand_N_Loop_Statement --
5488 -----------------------------
5490 -- 1. Remove null loop entirely
5491 -- 2. Deal with while condition for C/Fortran boolean
5492 -- 3. Deal with loops with a non-standard enumeration type range
5493 -- 4. Deal with while loops where Condition_Actions is set
5494 -- 5. Deal with loops over predicated subtypes
5495 -- 6. Deal with loops with iterators over arrays and containers
5502 begin
5503 -- Delete null loop
5510 -- Deal with condition for C/Fortran Boolean
5516 -- Nothing more to do for plain loop with no iteration scheme
5521 -- Case of for loop (Loop_Parameter_Specification present)
5523 -- Note: we do not have to worry about validity checking of the for loop
5524 -- range bounds here, since they were frozen with constant declarations
5525 -- and it is during that process that the validity checking is done.
5528 declare
5539 begin
5540 -- If Discrete_Subtype_Definition has been rewritten as an
5541 -- N_Raise_xxx_Error, rewrite the whole loop as a raise node to
5542 -- avoid confusing the code generator down the line.
5545 then
5558 -- Deal with loop over predicates
5562 then
5565 -- Handle the case where we have a for loop with the range type
5566 -- being an enumeration type with non-standard representation.
5567 -- In this case we expand:
5569 -- for x in [reverse] a .. b loop
5570 -- ...
5571 -- end loop;
5573 -- to
5575 -- for xP in [reverse] integer
5576 -- range etype'Pos (a) .. etype'Pos (b)
5577 -- loop
5578 -- declare
5579 -- x : constant etype := Pos_To_Rep (xP);
5580 -- begin
5581 -- ...
5582 -- end;
5583 -- end loop;
5587 then
5588 New_Id :=
5592 -- If the type has a contiguous representation, successive
5593 -- values can be generated as offsets from the first literal.
5596 Expr :=
5599 Left_Opnd =>
5603 else
5604 -- Use the constructed array Enum_Pos_To_Rep
5606 Expr :=
5608 Prefix =>
5610 Expressions =>
5614 -- Build declaration for loop identifier
5616 Decls :=
5617 New_List (
5628 Iteration_Scheme =>
5630 Loop_Parameter_Specification =>
5635 Discrete_Subtype_Definition =>
5638 Subtype_Mark =>
5641 Constraint =>
5643 Range_Expression =>
5646 Low_Bound =>
5648 Prefix =>
5654 Relocate_Node
5657 High_Bound =>
5659 Prefix =>
5665 Relocate_Node
5666 (Type_High_Bound
5672 Handled_Statement_Sequence =>
5678 -- The loop parameter's entity must be removed from the loop
5679 -- scope's entity list and rendered invisible, since it will
5680 -- now be located in the new block scope. Any other entities
5681 -- already associated with the loop scope, such as the loop
5682 -- parameter's subtype, will remain there.
5684 -- In an element loop, the loop will contain a declaration for
5685 -- a cursor variable; otherwise the loop id is the first entity
5686 -- in the scope constructed for the loop.
5702 -- Nothing to do with other cases of for loops
5704 else
5709 -- Second case, if we have a while loop with Condition_Actions set, then
5710 -- we change it into a plain loop:
5712 -- while C loop
5713 -- ...
5714 -- end loop;
5716 -- changed to:
5718 -- loop
5719 -- <<condition actions>>
5720 -- exit when not C;
5721 -- ...
5722 -- end loop
5727 then
5728 declare
5731 begin
5732 ES :=
5734 Condition =>
5741 -- This is not an implicit loop, since it is generated in response
5742 -- to the loop statement being processed. If this is itself
5743 -- implicit, the restriction has already been checked. If not,
5744 -- it is an explicit loop.
5755 -- Here to deal with iterator case
5759 then
5762 -- An iterator loop may generate renaming declarations for elements
5763 -- that require debug information. This is the case in particular
5764 -- with element iterators, where debug information must be generated
5765 -- for the temporary that holds the element value. These temporaries
5766 -- are created within a transient block whose local declarations are
5767 -- transferred to the loop, which now has nontrivial local objects.
5771 then
5776 -- When the iteration scheme mentions attribute 'Loop_Entry, the loop
5777 -- is transformed into a conditional block where the original loop is
5778 -- the sole statement. Inspect the statements of the nested loop for
5779 -- controlled objects.
5790 ----------------------------
5791 -- Expand_Predicated_Loop --
5792 ----------------------------
5794 -- Note: the expander can handle generation of loops over predicated
5795 -- subtypes for both the dynamic and static cases. Depending on what
5796 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
5797 -- mode, the semantic analyzer may disallow one or both forms.
5809 begin
5810 -- Case of iteration over non-static predicate, should not be possible
5811 -- since this is not allowed by the semantics and should have been
5812 -- caught during analysis of the loop statement.
5817 -- If the predicate list is empty, that corresponds to a predicate of
5818 -- False, in which case the loop won't run at all, and we rewrite the
5819 -- entire loop as a null statement.
5825 -- For expansion over a static predicate we generate the following
5827 -- declare
5828 -- J : Ltype := min-val;
5829 -- begin
5830 -- loop
5831 -- body
5832 -- case J is
5833 -- when endpoint => J := startpoint;
5834 -- when endpoint => J := startpoint;
5835 -- ...
5836 -- when max-val => exit;
5837 -- when others => J := Lval'Succ (J);
5838 -- end case;
5839 -- end loop;
5840 -- end;
5842 -- with min-val replaced by max-val and Succ replaced by Pred if the
5843 -- loop parameter specification carries a Reverse indicator.
5845 -- To make this a little clearer, let's take a specific example:
5847 -- type Int is range 1 .. 10;
5848 -- subtype StaticP is Int with
5849 -- predicate => StaticP in 3 | 10 | 5 .. 7;
5850 -- ...
5851 -- for L in StaticP loop
5852 -- Put_Line ("static:" & J'Img);
5853 -- end loop;
5855 -- In this case, the loop is transformed into
5857 -- begin
5858 -- J : L := 3;
5859 -- loop
5860 -- body
5861 -- case J is
5862 -- when 3 => J := 5;
5863 -- when 7 => J := 10;
5864 -- when 10 => exit;
5865 -- when others => J := L'Succ (J);
5866 -- end case;
5867 -- end loop;
5868 -- end;
5870 -- In addition, if the loop specification is given by a subtype
5871 -- indication that constrains a predicated type, the bounds of
5872 -- iteration are given by those of the subtype indication.
5874 else
5882 -- If the domain is an itype, note the bounds of its range.
5888 -- Given static expression or static range, returns an identifier
5889 -- whose value is the low bound of the expression value or range.
5892 -- Given static expression or static range, returns an identifier
5893 -- whose value is the high bound of the expression value or range.
5895 ------------
5896 -- Hi_Val --
5897 ------------
5900 begin
5903 else
5909 ------------
5910 -- Lo_Val --
5911 ------------
5914 begin
5917 else
5923 -- Start of processing for Static_Predicate
5925 begin
5926 -- Convert loop identifier to normal variable and reanalyze it so
5927 -- that this conversion works. We have to use the same defining
5928 -- identifier, since there may be references in the loop body.
5933 -- In most loops the loop variable is assigned in various
5934 -- alternatives in the body. However, in the rare case when
5935 -- the range specifies a single element, the loop variable
5936 -- may trigger a spurious warning that is could be constant.
5937 -- This warning might as well be suppressed.
5946 -- Loop to create branches of case statement
5952 -- Initial value is largest value in predicate.
5955 D :=
5961 else
5962 D :=
5973 else
5974 S :=
5991 and then
5993 then
6000 else
6001 -- Initial value is smallest value in predicate
6004 D :=
6009 else
6010 D :=
6021 else
6022 S :=
6039 and then
6041 then
6049 -- Add others choice
6051 declare
6054 begin
6057 else
6061 S :=
6064 Expression =>
6078 -- Construct case statement and append to body statements
6080 Cstm :=
6086 -- Rewrite the loop preserving the loop identifier in case there
6087 -- are exit statements referencing it.
6090 Orig_Loop_Id := New_Occurrence_Of
6099 Handled_Statement_Sequence =>
6112 ------------------------------
6113 -- Make_Tag_Ctrl_Assignment --
6114 ------------------------------
6127 and then not Comp_Asn
6134 begin
6135 -- Finalize the target of the assignment when controlled
6137 -- We have two exceptions here:
6139 -- 1. If we are in an init proc since it is an initialization more
6140 -- than an assignment.
6142 -- 2. If the left-hand side is a temporary that was not initialized
6143 -- (or the parent part of a temporary since it is the case in
6144 -- extension aggregates). Such a temporary does not come from
6145 -- source. We must examine the original node for the prefix, because
6146 -- it may be a component of an entry formal, in which case it has
6147 -- been rewritten and does not appear to come from source either.
6149 -- Case of init proc
6154 -- The left-hand side is an uninitialized temporary object
6159 N_Object_Declaration
6161 then
6164 else
6165 Fin_Call :=
6166 Make_Final_Call
6175 -- Save the Tag in a local variable Tag_Id
6184 Expression =>
6187 Selector_Name =>
6190 -- Otherwise Tag_Id is not used
6192 else
6196 -- If the tagged type has a full rep clause, expand the assignment into
6197 -- component-wise assignments. Mark the node as unanalyzed in order to
6198 -- generate the proper code and propagate this scenario by setting a
6199 -- flag to avoid infinite recursion.
6208 -- Restore the tag
6213 Name =>
6216 Selector_Name =>
6221 -- Adjust the target after the assignment when controlled (not in the
6222 -- init proc since it is an initialization more than an assignment).
6225 Adj_Call :=
6226 Make_Adjust_Call
6237 exception
6239 -- Could use comment here ???