| blob | bc6124305cb9178c7ace9ce302e0536a447511bc |
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-2023, 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 ------------------------------------------------------------------------------
74 procedure Build_Formal_Container_Iteration
81 -- Utility to create declarations and loop statement for both forms
82 -- of formal container iterators.
84 function Convert_To_Iterable_Type
87 -- Returns New_Occurrence_Of (Container), possibly converted to an ancestor
88 -- type, if the type of Container inherited the Iterable aspect from that
89 -- ancestor.
92 -- Determine if the right-hand side of assignment N is a type conversion
93 -- which requires a change of representation. Called only for the array
94 -- and record cases.
97 -- N is an assignment which assigns an array value. This routine process
98 -- the various special cases and checks required for such assignments,
99 -- including change of representation. Rhs is normally simply the right-
100 -- hand side of the assignment, except that if the right-hand side is a
101 -- type conversion or a qualified expression, then the RHS is the actual
102 -- expression inside any such type conversions or qualifications.
104 function Expand_Assign_Array_Loop
112 -- N is an assignment statement which assigns an array value. This routine
113 -- expands the assignment into a loop (or nested loops for the case of a
114 -- multi-dimensional array) to do the assignment component by component.
115 -- Larray and Rarray are the entities of the actual arrays on the left-hand
116 -- and right-hand sides. L_Type and R_Type are the types of these arrays
117 -- (which may not be the same, due to either sliding, or to a change of
118 -- representation case). Ndim is the number of dimensions and the parameter
119 -- Rev indicates if the loops run normally (Rev = False), or reversed
120 -- (Rev = True). The value returned is the constructed loop statement.
121 -- Auxiliary declarations are inserted before node N using the standard
122 -- Insert_Actions mechanism.
124 function Expand_Assign_Array_Bitfield
131 -- Alternative to Expand_Assign_Array_Loop for packed bitfields. Generates
132 -- a call to System.Bitfields.Copy_Bitfield, which is more efficient than
133 -- copying component-by-component.
135 function Expand_Assign_Array_Bitfield_Fast
139 -- Alternative to Expand_Assign_Array_Bitfield. Generates a call to
140 -- System.Bitfields.Fast_Copy_Bitfield, which is more efficient than
141 -- Copy_Bitfield, but only works in restricted situations.
143 function Expand_Assign_Array_Loop_Or_Bitfield
151 -- Calls either Expand_Assign_Array_Loop, Expand_Assign_Array_Bitfield, or
152 -- Expand_Assign_Array_Bitfield_Fast as appropriate.
155 -- N is an assignment of an untagged record value. This routine handles
156 -- the case where the assignment must be made component by component,
157 -- either because the target is not byte aligned, or there is a change
158 -- of representation, or when we have a tagged type with a representation
159 -- clause (this last case is required because holes in the tagged type
160 -- might be filled with components from child types).
163 -- (AI12-0125): N is an assignment statement whose RHS contains occurrences
164 -- of @ that designate the value of the LHS of the assignment. If the LHS
165 -- is side-effect-free the target names can be replaced with a copy of the
166 -- LHS; otherwise the semantics of the assignment is described in terms of
167 -- a procedure with an in-out parameter, and expanded as such.
170 -- Use the primitives specified in an Iterable aspect to expand a loop
171 -- over a so-called formal container, primarily for SPARK usage.
174 -- Same, for an iterator of the form " For E of C". In this case the
175 -- iterator provides the name of the element, and the cursor is generated
176 -- internally.
179 -- Expand loop over arrays and containers that uses the form "for X of C"
180 -- with an optional subtype mark, or "for Y in C".
182 procedure Expand_Iterator_Loop_Over_Container
187 -- Expand loop over containers that uses the form "for X of C" with an
188 -- optional subtype mark, or "for Y in C". I_Spec is the iterator
189 -- specification and Container is either the Container (for OF) or the
190 -- iterator (for IN).
193 -- Expand for loop over predicated subtype
196 -- Generate the necessary code for controlled and tagged assignment, that
197 -- is to say, finalization of the target before, adjustment of the target
198 -- after and save and restore of the tag and finalization pointers which
199 -- are not 'part of the value' and must not be changed upon assignment. N
200 -- is the original Assignment node.
202 --------------------------------------
203 -- Build_Formal_Container_Iteration --
204 --------------------------------------
206 procedure Build_Formal_Container_Iteration
213 is
224 begin
225 -- Use the proper set of primitives depending on the direction of
226 -- iteration. The legality of a reverse iteration has been checked
227 -- during analysis.
233 else
238 -- Declaration for Cursor
240 Init :=
244 Expression =>
250 -- Statement that advances (in the right direction) cursor in loop
252 Advance :=
255 Expression =>
262 -- Iterator is rewritten as a while_loop
264 New_Loop :=
266 Iteration_Scheme =>
268 Condition =>
277 -- If the contruct has a specified loop name, preserve it in the new
278 -- loop, for possible use in exit statements.
282 then
287 ------------------------------
288 -- Change_Of_Representation --
289 ------------------------------
293 begin
294 return
296 and then not Has_Compatible_Representation
301 ------------------------------
302 -- Convert_To_Iterable_Type --
303 ------------------------------
305 function Convert_To_Iterable_Type
308 is
313 begin
317 Result :=
326 -------------------------
327 -- Expand_Assign_Array --
328 -------------------------
330 -- There are two issues here. First, do we let Gigi do a block move, or
331 -- do we expand out into a loop? Second, we need to set the two flags
332 -- Forwards_OK and Backwards_OK which show whether the block move (or
333 -- corresponding loops) can be legitimately done in a forwards (low to
334 -- high) or backwards (high to low) manner.
354 pragma Assert
355 (Crep
364 -- This switch is set to True if the array move must be done using
365 -- an explicit front end generated loop.
368 -- If the argument is an access to an array, and the assignment is
369 -- converted into a procedure call, apply explicit dereference.
372 -- Test if Exp is a reference to an array whose declaration has
373 -- an address clause, or it is a slice of such an array.
376 -- Test if Exp is a reference to an array which is either a formal
377 -- parameter or a slice of a formal parameter. These are the cases
378 -- where hidden aliasing can occur.
381 -- Determine if Exp is a reference to an array variable which is other
382 -- than an object defined in the current scope, or a component or a
383 -- slice of such an object. Such objects can be aliased to parameters
384 -- (unlike local array references).
386 -----------------------
387 -- Apply_Dereference --
388 -----------------------
392 begin
400 ------------------------
401 -- Has_Address_Clause --
402 ------------------------
405 begin
406 return
409 or else
413 ---------------------
414 -- Is_Formal_Array --
415 ---------------------
418 begin
419 return
421 or else
425 ------------------------
426 -- Is_Non_Local_Array --
427 ------------------------
430 begin
432 when N_Indexed_Component
433 | N_Selected_Component
434 | N_Slice
435 =>
439 return
445 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
453 -- Start of processing for Expand_Assign_Array
455 begin
456 -- Deal with length check. Note that the length check is done with
457 -- respect to the right-hand side as given, not a possible underlying
458 -- renamed object, since this would generate incorrect extra checks.
462 -- We start by assuming that the move can be done in either direction,
463 -- i.e. that the two sides are completely disjoint.
468 -- Normally it is only the slice case that can lead to overlap, and
469 -- explicit checks for slices are made below. But there is one case
470 -- where the slice can be implicit and invisible to us: when we have a
471 -- one dimensional array, and either both operands are parameters, or
472 -- one is a parameter (which can be a slice passed by reference) and the
473 -- other is a non-local variable. In this case the parameter could be a
474 -- slice that overlaps with the other operand.
476 -- However, if the array subtype is a constrained first subtype in the
477 -- parameter case, then we don't have to worry about overlap, since
478 -- slice assignments aren't possible (other than for a slice denoting
479 -- the whole array).
481 -- Note: No overlap is possible if there is a change of representation,
482 -- so we can exclude this case.
485 and then not Crep
486 and then
488 or else
490 or else
492 and then
495 then
499 -- Note: the bit-packed case is not worrisome here, since if we have
500 -- a slice passed as a parameter, it is always aligned on a byte
501 -- boundary, and if there are no explicit slices, the assignment
502 -- can be performed directly.
505 -- If either operand has an address clause clear Backwards_OK and
506 -- Forwards_OK, since we cannot tell if the operands overlap. We
507 -- exclude this treatment when Rhs is an aggregate, since we know
508 -- that overlap can't occur.
512 then
517 -- We certainly must use a loop for change of representation and also
518 -- we use the operand of the conversion on the right-hand side as the
519 -- effective right-hand side (the component types must match in this
520 -- situation).
527 -- We require a loop if either side is possibly bit aligned
530 or else
532 then
535 -- Arrays with controlled components are expanded into a loop to force
536 -- calls to Adjust at the component level.
541 -- If object is full access, we cannot tolerate a loop
544 or else
546 then
549 -- Loop is required if we have atomic components since we have to
550 -- be sure to do any accesses on an element by element basis.
556 then
559 -- Case where no slice is involved
563 -- The following code deals with the case of unconstrained bit packed
564 -- arrays. The problem is that the template for such arrays contains
565 -- the bounds of the actual source level array, but the copy of an
566 -- entire array requires the bounds of the underlying array. It would
567 -- be nice if the back end could take care of this, but right now it
568 -- does not know how, so if we have such a type, then we expand out
569 -- into a loop, which is inefficient but works correctly. If we don't
570 -- do this, we get the wrong length computed for the array to be
571 -- moved. The two cases we need to worry about are:
573 -- Explicit dereference of an unconstrained packed array type as in
574 -- the following example:
576 -- procedure C52 is
577 -- type BITS is array(INTEGER range <>) of BOOLEAN;
578 -- pragma PACK(BITS);
579 -- type A is access BITS;
580 -- P1,P2 : A;
581 -- begin
582 -- P1 := new BITS (1 .. 65_535);
583 -- P2 := new BITS (1 .. 65_535);
584 -- P2.ALL := P1.ALL;
585 -- end C52;
587 -- A formal parameter reference with an unconstrained bit array type
588 -- is the other case we need to worry about (here we assume the same
589 -- BITS type declared above):
591 -- procedure Write_All (File : out BITS; Contents : BITS);
592 -- begin
593 -- File.Storage := Contents;
594 -- end Write_All;
596 -- We expand to a loop in either of these two cases
598 -- Question for future thought. Another potentially more efficient
599 -- approach would be to create the actual subtype, and then do an
600 -- unchecked conversion to this actual subtype ???
605 -- Function to perform required test for the first case, above
606 -- (dereference of an unconstrained bit packed array).
608 -----------------------
609 -- Is_UBPA_Reference --
610 -----------------------
617 begin
621 then
630 else
632 return
637 else
642 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
644 begin
646 or else
648 then
651 -- Here if we do not have the case of a reference to a bit packed
652 -- unconstrained array case. In this case gigi can most certainly
653 -- handle the assignment if a forwards move is allowed.
655 -- (could it handle the backwards case also???)
662 -- The back end can always handle the assignment if the right side is a
663 -- string literal (note that overlap is definitely impossible in this
664 -- case). If the type is packed, a string literal is always converted
665 -- into an aggregate, except in the case of a null slice, for which no
666 -- aggregate can be written. In that case, rewrite the assignment as a
667 -- null statement, a length check has already been emitted to verify
668 -- that the range of the left-hand side is empty.
670 -- Note that this code is not executed if we have an assignment of a
671 -- string literal to a non-bit aligned component of a record, a case
672 -- which cannot be handled by the backend.
677 then
684 -- If either operand is bit packed, then we need a loop, since we can't
685 -- be sure that the slice is byte aligned.
689 then
692 -- If we are not bit-packed, and we have only one slice, then no overlap
693 -- is possible except in the parameter case, so we can let the back end
694 -- handle things.
702 -- If the right-hand side is a string literal, introduce a temporary for
703 -- it, for use in the generated loop that will follow.
706 declare
710 begin
711 Decl :=
723 -- Come here to complete the analysis
725 -- Loop_Required: Set to True if we know that a loop is required
726 -- regardless of overlap considerations.
728 -- Forwards_OK: Set to False if we already know that a forwards
729 -- move is not safe, else set to True.
731 -- Backwards_OK: Set to False if we already know that a backwards
732 -- move is not safe, else set to True
734 -- Our task at this stage is to complete the overlap analysis, which can
735 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
736 -- then generating the final code, either by deciding that it is OK
737 -- after all to let Gigi handle it, or by generating appropriate code
738 -- in the front end.
740 declare
758 begin
759 -- Get the expressions for the arrays. If we are dealing with a
760 -- private type, then convert to the underlying type. We can do
761 -- direct assignments to an array that is a private type, but we
762 -- cannot assign to elements of the array without this extra
763 -- unchecked conversion.
765 -- Note: We propagate Parent to the conversion nodes to generate
766 -- a well-formed subtree.
770 else
774 declare
776 begin
777 Larray :=
778 Unchecked_Convert_To
787 else
791 declare
793 begin
794 Rarray :=
795 Unchecked_Convert_To
802 -- If both sides are slices, we must figure out whether it is safe
803 -- to do the move in one direction or the other. It is always safe
804 -- if there is a change of representation since obviously two arrays
805 -- with different representations cannot possibly overlap.
811 -- If both left- and right-hand arrays are entity names, and refer
812 -- to different entities, then we know that the move is safe (the
813 -- two storage areas are completely disjoint).
818 then
821 -- Otherwise, we assume the worst, which is that the two arrays
822 -- are the same array. There is no need to check if we know that
823 -- is the case, because if we don't know it, we still have to
824 -- assume it.
826 -- Generally if the same array is involved, then we have an
827 -- overlapping case. We will have to really assume the worst (i.e.
828 -- set neither of the OK flags) unless we can determine the lower
829 -- or upper bounds at compile time and compare them.
831 else
832 Cresult :=
833 Compile_Time_Compare
837 Cresult :=
838 Compile_Time_Compare
856 -- If after that analysis Loop_Required is False, meaning that we
857 -- have not discovered some non-overlap reason for requiring a loop,
858 -- then the outcome depends on the capabilities of the back end.
861 -- Assume the back end can deal with all cases of overlap by
862 -- falling back to memmove if it cannot use a more efficient
863 -- approach.
868 -- At this stage we have to generate an explicit loop, and we have
869 -- the following cases:
871 -- Forwards_OK = True
873 -- Rnn : right_index := right_index'First;
874 -- for Lnn in left-index loop
875 -- left (Lnn) := right (Rnn);
876 -- Rnn := right_index'Succ (Rnn);
877 -- end loop;
879 -- Note: the above code MUST be analyzed with checks off, because
880 -- otherwise the Succ could overflow. But in any case this is more
881 -- efficient.
883 -- Forwards_OK = False, Backwards_OK = True
885 -- Rnn : right_index := right_index'Last;
886 -- for Lnn in reverse left-index loop
887 -- left (Lnn) := right (Rnn);
888 -- Rnn := right_index'Pred (Rnn);
889 -- end loop;
891 -- Note: the above code MUST be analyzed with checks off, because
892 -- otherwise the Pred could overflow. But in any case this is more
893 -- efficient.
895 -- Forwards_OK = Backwards_OK = False
897 -- This only happens if we have the same array on each side. It is
898 -- possible to create situations using overlays that violate this,
899 -- but we simply do not promise to get this "right" in this case.
901 -- There are two possible subcases. If the No_Implicit_Conditionals
902 -- restriction is set, then we generate the following code:
904 -- declare
905 -- T : constant <operand-type> := rhs;
906 -- begin
907 -- lhs := T;
908 -- end;
910 -- If implicit conditionals are permitted, then we generate:
912 -- if Left_Lo <= Right_Lo then
913 -- <code for Forwards_OK = True above>
914 -- else
915 -- <code for Backwards_OK = True above>
916 -- end if;
918 -- In order to detect possible aliasing, we examine the renamed
919 -- expression when the source or target is a renaming. However,
920 -- the renaming may be intended to capture an address that may be
921 -- affected by subsequent code, and therefore we must recover
922 -- the actual entity for the expansion that follows, not the
923 -- object it renames. In particular, if source or target designate
924 -- a portion of a dynamically allocated object, the pointer to it
925 -- may be reassigned but the renaming preserves the proper location.
928 and then
931 then
936 and then
939 then
943 -- Cases where either Forwards_OK or Backwards_OK is true
951 then
952 declare
957 begin
969 New_Occurrence_Of (
978 else
980 Expand_Assign_Array_Loop_Or_Bitfield
985 -- Case of both are false with No_Implicit_Conditionals
988 declare
992 begin
999 Object_Definition =>
1003 Handled_Statement_Sequence =>
1011 -- Case of both are false with implicit conditionals allowed
1013 else
1014 -- Before we generate this code, we must ensure that the left and
1015 -- right side array types are defined. They may be itypes, and we
1016 -- cannot let them be defined inside the if, since the first use
1017 -- in the then may not be executed.
1022 -- We normally compare addresses to find out which way round to
1023 -- do the loop, since this is reliable, and handles the cases of
1024 -- parameters, conversions etc. But we can't do that in the bit
1025 -- packed case, because addresses don't work there.
1028 Condition :=
1030 Left_Opnd =>
1033 Prefix =>
1035 Prefix =>
1039 Prefix =>
1040 New_Occurrence_Of
1045 Right_Opnd =>
1048 Prefix =>
1050 Prefix =>
1054 Prefix =>
1055 New_Occurrence_Of
1060 -- For the bit packed and VM cases we use the bounds. That's OK,
1061 -- because we don't have to worry about parameters, since they
1062 -- cannot cause overlap. Perhaps we should worry about weird slice
1063 -- conversions ???
1065 else
1066 -- Copy the bounds
1071 -- If the types do not match we add an implicit conversion
1072 -- here to ensure proper match
1075 Cright_Lo :=
1079 -- Reset the Analyzed flag, because the bounds of the index
1080 -- type itself may be universal, and must be reanalyzed to
1081 -- acquire the proper type for the back end.
1086 Condition :=
1097 then
1098 -- Call TSS procedure for array assignment, passing the
1099 -- explicit bounds of right- and left-hand sides.
1101 declare
1106 begin
1127 else
1133 Expand_Assign_Array_Loop_Or_Bitfield
1138 Expand_Assign_Array_Loop_Or_Bitfield
1147 exception
1152 ------------------------------
1153 -- Expand_Assign_Array_Loop --
1154 ------------------------------
1156 -- The following is an example of the loop generated for the case of a
1157 -- two-dimensional array:
1159 -- declare
1160 -- R2b : Tm1X1 := 1;
1161 -- begin
1162 -- for L1b in 1 .. 100 loop
1163 -- declare
1164 -- R4b : Tm1X2 := 1;
1165 -- begin
1166 -- for L3b in 1 .. 100 loop
1167 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
1168 -- R4b := Tm1X2'succ(R4b);
1169 -- end loop;
1170 -- end;
1171 -- R2b := Tm1X1'succ(R2b);
1172 -- end loop;
1173 -- end;
1175 -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand
1176 -- side. The declarations of R2b and R4b are inserted before the original
1177 -- assignment statement.
1179 function Expand_Assign_Array_Loop
1187 is
1192 -- Entities used as subscripts on left and right sides
1196 -- Left and right index types
1204 -- The increment step for the index of the right-hand side is written
1205 -- as an attribute reference (Succ or Pred). This function returns
1206 -- the corresponding node, which is placed at the end of the loop body.
1208 ----------------
1209 -- Build_Step --
1210 ----------------
1216 begin
1219 else
1223 Step :=
1226 Expression =>
1228 Prefix =>
1234 -- Note that on the last iteration of the loop, the index is increased
1235 -- (or decreased) past the corresponding bound. This is consistent with
1236 -- the C semantics of the back-end, where such an off-by-one value on a
1237 -- dead index variable is OK. However, in CodePeer mode this leads to
1238 -- spurious warnings, and thus we place a guard around the attribute
1239 -- reference. For obvious reasons we only do this for CodePeer.
1242 Step :=
1244 Condition =>
1247 Right_Opnd =>
1257 -- Start of processing for Expand_Assign_Array_Loop
1259 begin
1263 else
1268 -- Setup index types and subscript entities
1270 declare
1274 begin
1290 -- Now construct the assignment statement
1292 declare
1296 begin
1302 Assign :=
1304 Name =>
1308 Expression =>
1313 -- We set assignment OK, since there are some cases, e.g. in object
1314 -- declarations, where we are actually assigning into a constant.
1315 -- If there really is an illegality, it was caught long before now,
1316 -- and was flagged when the original assignment was analyzed.
1320 -- Propagate the No_{Ctrl,Finalize}_Actions flags to 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
1597 function Volatile_Or_Independent
1599 -- Exp is an expression of type Typ, or if there is no expression
1600 -- involved, Exp is Empty. True if there are any volatile or independent
1601 -- objects that should disable the optimization. We check the object
1602 -- itself, all subcomponents, and if Exp is a slice of a component or
1603 -- slice, we check the prefix and its type.
1604 --
1605 -- We disable the optimization when there are relevant volatile or
1606 -- independent objects, because Copy_Bitfield can read and write bits
1607 -- that are not part of the objects being copied.
1609 -----------------------------
1610 -- Volatile_Or_Independent --
1611 -----------------------------
1613 function Volatile_Or_Independent
1615 is
1616 begin
1617 -- Initially, Exp is the left- or right-hand side. In recursive
1618 -- calls, Exp is Empty if we're just checking a component type, and
1619 -- Exp is the prefix if we're checking the prefix of a slice.
1624 then
1630 then
1640 declare
1642 begin
1655 N_Selected_Component | N_Indexed_Component | N_Slice
1656 then
1658 then
1670 -- L is the left-hand side Name. Returns True if L is a slice of a
1671 -- component of a bit-packed array. The optimization is disabled in
1672 -- that case, because Expand_Assign_Array_Bitfield_Fast cannot
1673 -- currently handle that case correctly.
1677 -- Left- and right-hand sides of the assignment statement
1682 -- Start of processing for Expand_Assign_Array_Loop_Or_Bitfield
1684 begin
1685 -- Determine whether Copy_Bitfield or Fast_Copy_Bitfield is appropriate
1686 -- (will work, and will be more efficient than component-by-component
1687 -- copy). Copy_Bitfield doesn't work for reversed storage orders. It is
1688 -- efficient for slices of bit-packed arrays.
1694 and then Slices
1698 then
1699 -- Here if Copy_Bitfield can work (except for the Rev test below).
1700 -- Determine whether to call Fast_Copy_Bitfield instead. If we
1701 -- are assigning slices, and all the relevant bounds are known at
1702 -- compile time, and the maximum object size is no greater than
1703 -- System.Bitfields.Val_Bits (i.e. Long_Long_Integer'Size / 2), and
1704 -- we don't have enumeration representation clauses, we can use
1705 -- Fast_Copy_Bitfield. The max size test is to ensure that the slices
1706 -- cannot overlap boundaries not supported by Fast_Copy_Bitfield.
1711 -- Note that L_Type and R_Type do not necessarily have the same base
1712 -- type, because of array type conversions. Hence the need to check
1713 -- various properties of both.
1717 then
1718 declare
1731 then Compile_Time_Known_Value
1735 then Compile_Time_Known_Value
1740 begin
1743 Val_Bits
1746 and then Known_Left_Slice_Low
1747 and then Known_Right_Slice_Low
1748 and then Compile_Time_Known_Value
1750 and then Compile_Time_Known_Value
1752 and then
1754 and then Has_Enumeration_Rep_Clause
1757 then
1766 -- Fast_Copy_Bitfield can work if Rev is True, because the data is
1767 -- passed and returned by copy. Copy_Bitfield cannot.
1770 return Expand_Assign_Array_Bitfield
1775 -- Here if we did not return above, with Fast_Copy_Bitfield or
1776 -- Copy_Bitfield.
1778 return Expand_Assign_Array_Loop
1782 --------------------------
1783 -- Expand_Assign_Record --
1784 --------------------------
1791 begin
1792 -- If change of representation, then extract the real right-hand side
1793 -- from the type conversion, and proceed with component-wise assignment,
1794 -- since the two types are not the same as far as the back end is
1795 -- concerned.
1800 -- If this may be a case of a large bit aligned component, then proceed
1801 -- with component-wise assignment, to avoid possible clobbering of other
1802 -- components sharing bits in the first or last byte of the component to
1803 -- be assigned.
1806 or else
1808 then
1811 -- If we have a tagged type that has a complete record representation
1812 -- clause, we must do we must do component-wise assignments, since child
1813 -- types may have used gaps for their components, and we might be
1814 -- dealing with a view conversion.
1819 -- If neither condition met, then nothing special to do, the back end
1820 -- can handle assignment of the entire component as a single entity.
1822 else
1826 -- At this stage we know that we must do a component wise assignment
1828 declare
1835 function Find_Component
1838 -- Find the component with the given name in the underlying record
1839 -- declaration for Typ. We need to use the actual entity because the
1840 -- type may be private and resolution by identifier alone would fail.
1842 function Make_Component_List_Assign
1845 -- Returns a sequence of statements to assign the components that
1846 -- are referenced in the given component list. The flag U_U is
1847 -- used to force the usage of the inferred value of the variant
1848 -- part expression as the switch for the generated case statement.
1850 function Make_Field_Assign
1853 -- Given C, the entity for a discriminant or component, build an
1854 -- assignment for the corresponding field values. The flag U_U
1855 -- signals the presence of an Unchecked_Union and forces the usage
1856 -- of the inferred discriminant value of C as the right-hand side
1857 -- of the assignment.
1860 -- Given CI, a component items list, construct series of statements
1861 -- for fieldwise assignment of the corresponding components.
1863 --------------------
1864 -- Find_Component --
1865 --------------------
1867 function Find_Component
1870 is
1874 begin
1880 -- The component may be a renamed discriminant, in
1881 -- which case check against the name of the original
1882 -- discriminant of the parent type.
1887 and then
1889 then
1899 --------------------------------
1900 -- Make_Component_List_Assign --
1901 --------------------------------
1903 function Make_Component_List_Assign
1906 is
1917 begin
1934 Statements =>
1939 -- Try to find a constrained type or a derived type to extract
1940 -- discriminant values from, so that the case statement built
1941 -- below can be folded by Expand_N_Case_Statement.
1944 Expr :=
1951 Expr :=
1959 then
1960 Expr :=
1966 else
1971 Expr :=
1974 Selector_Name =>
1987 -----------------------
1988 -- Make_Field_Assign --
1989 -----------------------
1991 function Make_Field_Assign
1994 is
1999 begin
2000 -- The discriminant entity to be used in the retrieval below must
2001 -- be one in the corresponding type, given that the assignment may
2002 -- be between derived and parent types.
2006 else
2010 -- In the case of an Unchecked_Union, use the discriminant
2011 -- constraint value as on the right-hand side of the assignment.
2014 Expr :=
2018 else
2019 Expr :=
2025 -- Generate the assignment statement. When the left-hand side
2026 -- is an object with an address clause present, force generated
2027 -- temporaries to be renamings so as to correctly assign to any
2028 -- overlaid objects.
2030 A :=
2032 Name =>
2034 Prefix =>
2035 Duplicate_Subexpr
2038 Renaming_Req =>
2041 Selector_Name =>
2045 -- Set Assignment_OK, so discriminants can be assigned
2052 then
2059 ------------------------
2060 -- Make_Field_Assigns --
2061 ------------------------
2067 begin
2073 -- Look for components, but exclude _tag field assignment if
2074 -- the special Componentwise_Assignment flag is set.
2079 then
2080 Append_To
2090 -- Start of processing for Expand_Assign_Record
2092 begin
2093 -- Note that we need to use the base types for this processing in
2094 -- order to retrieve the Type_Definition. In the constrained case,
2095 -- we filter out the non relevant fields in
2096 -- Make_Component_List_Assign.
2098 -- First copy the discriminants. This is done unconditionally. It
2099 -- is required in the unconstrained left side case, and also in the
2100 -- case where this assignment was constructed during the expansion
2101 -- of a type conversion (since initialization of discriminants is
2102 -- suppressed in this case). It is unnecessary but harmless in
2103 -- other cases.
2105 -- Special case: no copy if the target has no discriminants
2109 then
2116 -- If we are expanding the initialization of a derived record
2117 -- that constrains or renames discriminants of the parent, we
2118 -- must use the corresponding discriminant in the parent.
2120 declare
2123 begin
2124 if Inside_Init_Proc
2126 then
2128 else
2134 -- Within an initialization procedure this is the
2135 -- assignment to an unchecked union component, in which
2136 -- case there is no discriminant to initialize.
2141 else
2142 -- The assignment is part of a conversion from a
2143 -- derived unchecked union type with an inferable
2144 -- discriminant, to a parent type.
2149 else
2157 -- If the derived type has a stored constraint, assign the value
2158 -- of the corresponding discriminants explicitly, skipping those
2159 -- that are renamed discriminants. We cannot just retrieve them
2160 -- from the Rhs by selected component because they are invisible
2161 -- in the type of the right-hand side.
2164 declare
2168 begin
2175 and then
2178 E_Discriminant)
2179 then
2180 Assign :=
2182 Name =>
2185 Selector_Name =>
2186 New_Occurrence_Of
2201 -- We know the underlying type is a record, but its current view
2202 -- may be private. We must retrieve the usable record declaration.
2205 | N_Private_Extension_Declaration
2207 then
2209 else
2219 then
2223 else
2233 -------------------------------------
2234 -- Expand_Assign_With_Target_Names --
2235 -------------------------------------
2244 -- The entity of the left-hand side
2247 -- Replace occurrences of the target name by the proper entity: either
2248 -- the entity of the LHS in simple cases, or the formal of the
2249 -- constructed procedure otherwise.
2251 --------------------
2252 -- Replace_Target --
2253 --------------------
2256 begin
2260 -- The expression will be reanalyzed when the enclosing assignment
2261 -- is reanalyzed, so reset the entity, which may be a temporary
2262 -- created during analysis, e.g. a loop variable for an iterated
2263 -- component association. However, if entity is callable then
2264 -- resolution has established its proper identity (including in
2265 -- rewritten prefixed calls) so we must preserve it.
2270 then
2281 -- Local variables
2286 -- Start of processing for Expand_Assign_With_Target_Names
2288 begin
2291 -- The left-hand side is a direct name
2295 then
2299 -- Generate:
2300 -- LHS := ... LHS ...;
2307 -- The left-hand side is not a direct name, but is side-effect-free.
2308 -- Capture its value in a temporary to avoid generating a procedure.
2309 -- We don't do this optimization if the target object's type may need
2310 -- finalization actions, because we don't want extra finalizations to
2311 -- be done for the temp object, and instead we use the more general
2312 -- procedure-based approach below.
2316 then
2320 -- Generate:
2321 -- T : LHS_Typ := LHS;
2329 -- Generate:
2330 -- LHS := ... T ...;
2337 -- Otherwise wrap the whole assignment statement in a procedure with an
2338 -- IN OUT parameter. The original assignment then becomes a call to the
2339 -- procedure with the left-hand side as an actual.
2341 else
2345 -- Generate:
2346 -- procedure P (T : in out LHS_Typ) is
2347 -- begin
2348 -- T := ... T ...;
2349 -- end P;
2355 Specification =>
2363 Parameter_Type =>
2368 Handled_Statement_Sequence =>
2375 -- Generate:
2376 -- P (LHS);
2384 -- Analyze rewritten node, either as assignment or procedure call
2389 -----------------------------------
2390 -- Expand_N_Assignment_Statement --
2391 -----------------------------------
2393 -- This procedure implements various cases where an assignment statement
2394 -- cannot just be passed on to the back end in untransformed state.
2404 begin
2405 -- Special case to check right away, if the Componentwise_Assignment
2406 -- flag is set, this is a reanalysis from the expansion of the primitive
2407 -- assignment procedure for a tagged type, and all we need to do is to
2408 -- expand to assignment of components, because otherwise, we would get
2409 -- infinite recursion (since this looks like a tagged assignment which
2410 -- would normally try to *call* the primitive assignment procedure).
2417 -- Defend against invalid subscripts on left side if we are in standard
2418 -- validity checking mode. No need to do this if we are checking all
2419 -- subscripts.
2421 -- Note that we do this right away, because there are some early return
2422 -- paths in this procedure, and this is required on all paths.
2424 if Validity_Checks_On
2425 and then Validity_Check_Default
2426 and then not Validity_Check_Subscripts
2427 then
2431 -- Separate expansion if RHS contain target names. Note that assignment
2432 -- may already have been expanded if RHS is aggregate.
2439 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
2441 -- Rewrite an assignment to X'Priority into a run-time call
2443 -- For example: X'Priority := New_Prio_Expr;
2444 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
2446 -- Note that although X'Priority is notionally an object, it is quite
2447 -- deliberately not defined as an aliased object in the RM. This means
2448 -- that it works fine to rewrite it as a call, without having to worry
2449 -- about complications that would other arise from X'Priority'Access,
2450 -- which is illegal, because of the lack of aliasing.
2453 declare
2459 begin
2460 -- Handle chains of renamings
2467 loop
2471 -- The attribute Priority applied to protected objects has been
2472 -- previously expanded into a call to the Get_Ceiling run-time
2473 -- subprogram. In restricted profiles this is not available.
2477 -- Look for the enclosing protected type
2486 -- Select the appropriate run-time call
2490 else
2494 Call :=
2496 Name =>
2510 -- Deal with assignment checks unless suppressed
2514 -- First deal with generation of range check if required,
2515 -- and then predicate checks if the type carries a predicate.
2516 -- If the Rhs is an expression these tests may have been applied
2517 -- already. This is the case if the RHS is a type conversion.
2518 -- Other such redundant checks could be removed ???
2522 then
2531 -- Check for a special case where a high level transformation is
2532 -- required. If we have either of:
2534 -- P.field := rhs;
2535 -- P (sub) := rhs;
2537 -- where P is a reference to a bit packed array, then we have to unwind
2538 -- the assignment. The exact meaning of being a reference to a bit
2539 -- packed array is as follows:
2541 -- An indexed component whose prefix is a bit packed array is a
2542 -- reference to a bit packed array.
2544 -- An indexed component or selected component whose prefix is a
2545 -- reference to a bit packed array is itself a reference ot a
2546 -- bit packed array.
2548 -- The required transformation is
2550 -- Tnn : prefix_type := P;
2551 -- Tnn.field := rhs;
2552 -- P := Tnn;
2554 -- or
2556 -- Tnn : prefix_type := P;
2557 -- Tnn (subscr) := rhs;
2558 -- P := Tnn;
2560 -- Since P is going to be evaluated more than once, any subscripts
2561 -- in P must have their evaluation forced.
2565 then
2566 declare
2572 begin
2573 -- Insert the post assignment first, because we want to copy the
2574 -- BPAR_Expr tree before it gets analyzed in the context of the
2575 -- pre assignment. Note that we do not analyze the post assignment
2576 -- yet (we cannot till we have completed the analysis of the pre
2577 -- assignment). As usual, the analysis of this post assignment
2578 -- will happen on its own when we "run into" it after finishing
2579 -- the current assignment.
2586 -- At this stage BPAR_Expr is a reference to a bit packed array
2587 -- where the reference was not expanded in the original tree,
2588 -- since it was on the left side of an assignment. But in the
2589 -- pre-assignment statement (the object definition), BPAR_Expr
2590 -- will end up on the right-hand side, and must be reexpanded. To
2591 -- achieve this, we reset the analyzed flag of all selected and
2592 -- indexed components down to the actual indexed component for
2593 -- the packed array.
2596 loop
2600 then
2602 else
2607 -- Now we can insert and analyze the pre-assignment
2609 -- If the right-hand side requires a transient scope, it has
2610 -- already been placed on the stack. However, the declaration is
2611 -- inserted in the tree outside of this scope, and must reflect
2612 -- the proper scope for its variable. This awkward bit is forced
2613 -- by the stricter scope discipline imposed by GCC 2.97.
2615 declare
2617 Scope_Is_Transient
2620 begin
2632 Pop_Scope;
2636 -- Now fix up the original assignment and continue processing
2641 -- We do not need to reanalyze that assignment, and we do not need
2642 -- to worry about references to the temporary, but we do need to
2643 -- make sure that the temporary is not marked as a true constant
2644 -- since we now have a generated assignment to it.
2650 -- When we have the appropriate type of aggregate in the expression (it
2651 -- has been determined during analysis of the aggregate by setting the
2652 -- delay flag), let's perform in place assignment and thus avoid
2653 -- creating a temporary.
2662 -- An assignment between nonnative storage models requires creating an
2663 -- intermediate temporary on the host, which can potentially be large.
2673 then
2674 declare
2678 begin
2685 Name =>
2693 Expression =>
2703 -- Apply discriminant check if required. If Lhs is an access type to a
2704 -- designated type with discriminants, we must always check. If the
2705 -- type has unknown discriminants, more elaborate processing below.
2709 then
2710 -- Skip discriminant check if change of representation. Will be
2711 -- done when the change of representation is expanded out.
2717 -- If the type is private without discriminants, and the full type
2718 -- has discriminants (necessarily with defaults) a check may still be
2719 -- necessary if the Lhs is aliased. The private discriminants must be
2720 -- visible to build the discriminant constraints.
2722 -- Only an explicit dereference that comes from source indicates
2723 -- aliasing. Access to formals of protected operations and entries
2724 -- create dereferences but are not semantic aliasings.
2730 then
2731 declare
2735 begin
2736 -- In the case of an expander-generated record subtype whose base
2737 -- type still appears private, Typ will have been set to that
2738 -- private type rather than the underlying record type (because
2739 -- Underlying type will have returned the record subtype), so it's
2740 -- necessary to apply Underlying_Type again to the base type to
2741 -- get the record type we need for the discriminant check. Such
2742 -- subtypes can be created for assignments in certain cases, such
2743 -- as within an instantiation passed this kind of private type.
2744 -- It would be good to avoid this special test, but making changes
2745 -- to prevent this odd form of record subtype seems difficult. ???
2759 -- If the Lhs has a private type with unknown discriminants, it may
2760 -- have a full view with discriminants, but those are nameable only
2761 -- in the underlying type, so convert the Rhs to it before potential
2762 -- checking. Convert Lhs as well, otherwise the actual subtype might
2763 -- not be constructible. If the discriminants have defaults the type
2764 -- is unconstrained and there is nothing to check.
2765 -- Ditto if a private type with unknown discriminants has a full view
2766 -- that is an unconstrained array, in which case a length check is
2767 -- needed.
2772 then
2787 -- In the access type case, we need the same discriminant check, and
2788 -- also range checks if we have an access to constrained array.
2793 then
2796 -- Skip discriminant check if change of representation. Will be
2797 -- done when the change of representation is expanded out.
2812 -- Ada 2005 (AI-231): Generate the run-time check
2818 -- If an actual is an out parameter of a null-excluding access
2819 -- type, there is access check on entry, so we set the flag
2820 -- Suppress_Assignment_Checks on the generated statement to
2821 -- assign the actual to the parameter block, and we do not want
2822 -- to generate an additional check at this point.
2825 then
2829 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2830 -- stand-alone obj of an anonymous access type. Do not install the check
2831 -- when the Lhs denotes a container cursor and the Next function employs
2832 -- an access type, because this can never result in a dangling pointer.
2838 then
2839 declare
2841 -- Look through renames to find the underlying entity.
2842 -- For assignment to a rename, we don't care about the
2843 -- Enclosing_Dynamic_Scope of the rename declaration.
2845 ----------------
2846 -- Lhs_Entity --
2847 ----------------
2852 begin
2855 -- Renamed_Object must return an Entity_Name here
2856 -- because of preceding "Present (E_E_A (...))" test.
2864 -- Local Declarations
2868 Condition =>
2870 Left_Opnd =>
2872 Right_Opnd =>
2874 Intval =>
2875 Scope_Depth
2876 (Enclosing_Dynamic_Scope
2882 Name =>
2883 New_Occurrence_Of
2884 (Effective_Extra_Accessibility
2886 Expression =>
2887 Accessibility_Level
2892 begin
2901 -- Case of assignment to a bit packed array element. If there is a
2902 -- change of representation this must be expanded into components,
2903 -- otherwise this is a bit-field assignment.
2907 then
2908 -- Normal case, no change of representation
2914 -- Change of representation case
2916 else
2917 -- Generate the following, to force component-by-component
2918 -- assignments in an efficient way. Otherwise each component
2919 -- will require a temporary and two bit-field manipulations.
2921 -- T1 : Elmt_Type;
2922 -- T1 := RhS;
2923 -- Lhs := T1;
2925 declare
2929 begin
2930 Stats :=
2931 New_List (
2934 Object_Definition =>
2949 -- Build-in-place function call case. This is for assignment statements
2950 -- that come from aggregate component associations or from init procs.
2951 -- User-written assignment statements with b-i-p calls are handled
2952 -- elsewhere.
2960 then
2967 begin
2968 -- In the controlled case, we ensure that function calls are
2969 -- evaluated before finalizing the target. In all cases, it makes
2970 -- the expansion easier if the side effects are removed first.
2975 -- Avoid recursion in the mechanism
2979 -- If dispatching assignment, we need to dispatch to _assign
2983 -- If the type is tagged, we may as well use the predefined
2984 -- primitive assignment. This avoids inlining a lot of code
2985 -- and in the class-wide case, the assignment is replaced
2986 -- by a dispatching call to _assign. It is suppressed in the
2987 -- case of assignments created by the expander that correspond
2988 -- to initializations, where we do want to copy the tag
2989 -- (Expand_Ctrl_Actions flag is set False in this case). It is
2990 -- also suppressed if restriction No_Dispatching_Calls is in
2991 -- force because in that case predefined primitives are not
2992 -- generated.
2996 and then Expand_Ctrl_Actions
2997 and then
2999 then
3000 -- We should normally not encounter any limited type here,
3001 -- except in the corner case where an assignment was not
3002 -- intended like the pathological case of a raise expression
3003 -- within a return statement.
3010 -- Fetch the primitive op _assign and proper type to call it.
3011 -- Because of possible conflicts between private and full view,
3012 -- fetch the proper type directly from the operation profile.
3014 declare
3019 begin
3020 -- If the assignment is dispatching, make sure to use the
3021 -- proper type.
3029 -- In case of assignment to a class-wide tagged type, before
3030 -- the assignment we generate run-time check to ensure that
3031 -- the tags of source and target match.
3037 then
3038 declare
3042 begin
3044 Lhs_Tag :=
3047 Selector_Name =>
3049 Rhs_Tag :=
3052 Selector_Name =>
3054 else
3055 -- Displace the pointer to the base of the objects
3056 -- applying 'Address, which is later expanded into
3057 -- a call to RE_Base_Address.
3059 Lhs_Tag :=
3061 Prefix =>
3066 Rhs_Tag :=
3068 Prefix =>
3077 Condition =>
3085 declare
3089 begin
3090 -- In order to dispatch the call to _assign the type of
3091 -- the actuals must match. Add conversion (if required).
3110 else
3113 -- We can't afford to have destructive Finalization Actions in
3114 -- the Self assignment case, so if the target and the source
3115 -- are not obviously different, code is generated to avoid the
3116 -- self assignment case:
3118 -- if lhs'address /= rhs'address then
3119 -- <code for controlled and/or tagged assignment>
3120 -- end if;
3122 -- Skip this if Restriction (No_Finalization) is active
3125 and then Expand_Ctrl_Actions
3127 then
3130 Condition =>
3132 Left_Opnd =>
3137 Right_Opnd =>
3145 -- We need to set up an exception handler for implementing
3146 -- 7.6.1(18). The remaining adjustments are tackled by the
3147 -- implementation of adjust for record_controllers (see
3148 -- s-finimp.adb).
3150 -- This is skipped if we have no finalization
3152 if Expand_Ctrl_Actions
3154 then
3157 Handled_Statement_Sequence =>
3165 -- We will analyze the block statement with all checks suppressed
3166 -- below, but we need elaboration checks for the primitives in the
3167 -- case of an assignment created by the expansion of an aggregate.
3173 else
3176 Handled_Statement_Sequence =>
3180 -- If no restrictions on aborts, protect the whole assignment
3181 -- for controlled objects as per 9.8(11).
3184 and then Expand_Ctrl_Actions
3185 and then Abort_Allowed
3186 then
3187 declare
3189 New_Internal_Entity
3193 begin
3204 -- Present the Abort_Undefer_Direct function to the backend
3205 -- so that it can inline the call to the function.
3209 Expand_At_End_Handler
3214 -- N has been rewritten to a block statement for which it is
3215 -- known by construction that no checks are necessary: analyze
3216 -- it with all checks suppressed.
3222 -- Array types
3225 declare
3228 begin
3230 N_Type_Conversion | N_Qualified_Expression
3231 loop
3239 -- Record types
3245 -- Scalar types. This is where we perform the processing related to the
3246 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
3247 -- scalar values.
3251 -- Case where right side is known valid
3255 -- Here the right side is valid, so it is fine. The case to deal
3256 -- with is when the left side is a local variable reference whose
3257 -- value is not currently known to be valid. If this is the case,
3258 -- and the assignment appears in an unconditional context, then
3259 -- we can mark the left side as now being valid if one of these
3260 -- conditions holds:
3262 -- The expression of the right side has Do_Range_Check set so
3263 -- that we know a range check will be performed. Note that it
3264 -- can be the case that a range check is omitted because we
3265 -- make the assumption that we can assume validity for operands
3266 -- appearing in the right side in determining whether a range
3267 -- check is required
3269 -- The subtype of the right side matches the subtype of the
3270 -- left side. In this case, even though we have not checked
3271 -- the range of the right side, we know it is in range of its
3272 -- subtype if the expression is valid.
3277 then
3280 then
3285 -- Case where right side may be invalid in the sense of the RM
3286 -- reference above. The RM does not require that we check for the
3287 -- validity on an assignment, but it does require that the assignment
3288 -- of an invalid value not cause erroneous behavior.
3290 -- The general approach in GNAT is to use the Is_Known_Valid flag
3291 -- to avoid the need for validity checking on assignments. However
3292 -- in some cases, we have to do validity checking in order to make
3293 -- sure that the setting of this flag is correct.
3295 else
3296 -- Validate right side if we are validating copies
3298 if Validity_Checks_On
3299 and then Validity_Check_Copies
3300 then
3301 -- Skip this if left-hand side is an array or record component
3302 -- and elementary component validity checks are suppressed.
3305 and then not Validity_Check_Components
3306 then
3308 else
3312 -- We can propagate this to the left side where appropriate
3317 then
3321 -- Otherwise check to see what should be done
3323 -- If left side is a local variable, then we just set its flag to
3324 -- indicate that its value may no longer be valid, since we are
3325 -- copying a potentially invalid value.
3330 -- Check for case of a nonlocal variable on the left side which
3331 -- is currently known to be valid. In this case, we simply ensure
3332 -- that the right side is valid. We only play the game of copying
3333 -- validity status for local variables, since we are doing this
3334 -- statically, not by tracing the full flow graph.
3338 then
3339 -- Note: If Validity_Checking mode is set to none, we ignore
3340 -- the Ensure_Valid call so don't worry about that case here.
3344 -- In all other cases, we can safely copy an invalid value without
3345 -- worrying about the status of the left side. Since it is not a
3346 -- variable reference it will not be considered
3347 -- as being known to be valid in any case.
3349 else
3355 exception
3360 ------------------------------
3361 -- Expand_N_Block_Statement --
3362 ------------------------------
3364 -- Encode entity names defined in block statement
3367 begin
3371 -----------------------------
3372 -- Expand_N_Case_Statement --
3373 -----------------------------
3386 -- Expand a case statement whose selecting expression is not discrete
3388 -----------------------------------
3389 -- Expand_General_Case_Statement --
3390 -----------------------------------
3393 -- expand into a block statement
3403 then Expr
3417 -- If we are going to need a choice index object (that is, if
3418 -- Multidefined_Bindings is true for at least one of the case
3419 -- alternatives), then create and return that object's declaration.
3420 -- Otherwise, return Empty; no need for a decl in that case because
3421 -- it would never be referenced.
3423 ---------------------------------
3424 -- Choice_Index_Decl_If_Needed --
3425 ---------------------------------
3429 begin
3432 return Make_Object_Declaration
3434 Defining_Identifier =>
3436 Object_Definition =>
3447 function Pattern_Match
3453 -- Returns a Boolean-valued expression indicating a pattern match
3454 -- for a given pattern and object. If Choice_Index is nonzero,
3455 -- then Choice_Index is assigned to Choice_Index_Decl (unless
3456 -- Suppress_Choice_Index_Update is specified, which should only
3457 -- be the case for a recursive call where the caller has already
3458 -- taken care of the update). Pattern occurs as a choice (or as a
3459 -- subexpression of a choice) of the case statement alternative Alt.
3461 function Top_Level_Pattern_Match_Condition
3463 -- Returns a Boolean-valued expression indicating a pattern match
3464 -- for the given alternative's list of choices.
3466 -------------------
3467 -- Pattern_Match --
3468 -------------------
3470 function Pattern_Match
3476 is
3477 procedure Finish_Binding_Object_Declaration
3479 -- Finish the work that was started during analysis to
3480 -- declare a binding object. If we are generating a copy,
3481 -- then initialize it. If we are generating a renaming, then
3482 -- initialize the access value designating the renamed object.
3486 Name =>
3487 New_Occurrence_Of
3491 function PM
3499 -- convenient rename for recursive calls
3502 -- Returns the Nth (well, ok, the Idxth) element of Object
3504 ---------------------------------------
3505 -- Finish_Binding_Object_Declaration --
3506 ---------------------------------------
3508 procedure Finish_Binding_Object_Declaration
3510 is
3523 -- Declare_Copy indicates which of the two approaches
3524 -- was chosen during analysis: declare (and initialize)
3525 -- a new variable, or use access values to declare a renaming
3526 -- of the appropriate subcomponent of the selector value.
3529 -- If there is only one choice for this alternative, then
3530 -- simply return the argument. If there is more than one
3531 -- choice, then wrap an if-statement around the argument
3532 -- so that it is only executed if the current choice matches.
3534 ----------------------
3535 -- Make_Conditional --
3536 ----------------------
3539 is
3541 begin
3543 Condition :=
3545 New_Occurrence_Of
3552 else
3553 -- execute Stmt unconditionally
3558 begin
3559 -- find the variable to be modified (and its declaration)
3560 loop
3562 | N_Object_Renaming_Declaration
3563 then
3571 -- For a binding object, we sometimes make a copy and
3572 -- sometimes introduce a renaming. That decision is made
3573 -- elsewhere. The renaming case involves dereferencing an
3574 -- access value because of the possibility of multiple
3575 -- choices (with multiple binding definitions) for a single
3576 -- alternative. In the copy case, we initialize the copy
3577 -- here (conditionally if there are multiple choices); in the
3578 -- renaming case, we initialize (again, maybe conditionally)
3579 -- the access value.
3582 declare
3590 begin
3595 else
3598 declare
3606 Expression =>
3610 begin
3611 Insert_After
3616 -- Delete bogus initial value built during analysis.
3617 -- Look for "5432" in sem_case.adb.
3619 N_Unchecked_Type_Conversion);
3628 ---------------------
3629 -- Indexed_Element --
3630 ---------------------
3635 Left_Opnd =>
3639 Right_Opnd =>
3641 begin
3647 -- Start of processing for Pattern_Match
3649 begin
3653 -- Add Choice_Index update as a side effect of evaluating
3654 -- this condition and try again, this time suppressing
3655 -- Choice_Index update.
3659 Expression =>
3667 then
3668 declare
3670 begin
3672 Val := Get_Enum_Lit_From_Pos
3674 else
3683 declare
3685 begin
3688 -- Nonpositional aggregates currently unimplemented.
3689 -- We flag that case during analysis, so an assertion
3690 -- is ok here.
3691 --
3692 pragma Assert
3695 declare
3704 begin
3710 declare
3713 begin
3715 Result :=
3718 Right_Opnd =>
3729 -- positional notation should have been normalized
3732 declare
3733 Component_Assoc : Node_Id
3740 Selector_Name => New_Occurrence_Of
3742 begin
3748 pragma Assert
3754 -- Box matches anything
3756 pragma Assert
3758 else
3761 Right_Opnd =>
3763 Expression
3768 -- If this component association defines
3769 -- (in the case where the pattern matches)
3770 -- the value of a binding object, then
3771 -- prepend to the statement list for this
3772 -- alternative an assignment to the binding
3773 -- object. This assignment will be conditional
3774 -- if there is more than one choice.
3777 then
3778 Finish_Binding_Object_Declaration
3794 declare
3798 -- If the component type is not a standard character
3799 -- type then this string lit should have already been
3800 -- transformed into an aggregate in
3801 -- Resolve_String_Literal.
3802 --
3815 begin
3821 declare
3827 begin
3829 Char_Lit :=
3834 Result :=
3837 Right_Opnd =>
3851 Right_Opnd =>
3859 Right_Opnd => New_Occurrence_Of
3871 -- aggregate expansion sometimes introduces conversions
3875 then
3883 -- Avoid cascading errors
3888 ---------------------------------------
3889 -- Top_Level_Pattern_Match_Condition --
3890 ---------------------------------------
3892 function Top_Level_Pattern_Match_Condition
3894 is
3904 begin
3914 do
3922 Right_Opnd => Pattern_Match
3933 -- Process subsequent alternatives
3935 -----------------
3936 -- Elsif_Parts --
3937 -----------------
3942 begin
3943 loop
3950 Result);
3956 -- Returns a "raise Constraint_Error" statement if
3957 -- exception propagate is permitted and No_List otherwise.
3959 ---------------------
3960 -- Else_Statements --
3961 ---------------------
3964 begin
3967 else
3973 -- Local constants
3984 -- Start of processing for Expand_General_Case_Statement
3986 begin
3993 Handled_Statement_Sequence =>
3998 -- Start of processing for Expand_N_Case_Statement
4000 begin
4001 if Core_Extensions_Allowed
4003 then
4009 -- Check for the situation where we know at compile time which branch
4010 -- will be taken.
4012 -- If the value is static but its subtype is predicated and the value
4013 -- does not obey the predicate, the value is marked non-static, and
4014 -- there can be no corresponding static alternative. In that case we
4015 -- replace the case statement with an exception, regardless of whether
4016 -- assertions are enabled or not, unless predicates are ignored.
4022 then
4031 then
4034 -- Do not consider controlled objects found in a case statement which
4035 -- actually models a case expression because their early finalization
4036 -- will affect the result of the expression.
4042 -- Move statements from this alternative after the case statement.
4043 -- They are already analyzed, so will be skipped by the analyzer.
4047 -- That leaves the case statement as a shell. So now we can kill all
4048 -- other alternatives in the case statement.
4052 declare
4055 begin
4056 -- Loop through case alternatives, skipping pragmas, and skipping
4057 -- the one alternative that we select (and therefore retain).
4063 then
4075 -- Here if the choice is not determined at compile time
4077 declare
4086 begin
4090 else
4094 -- First step is to worry about possible invalid argument. The RM
4095 -- requires (RM 4.5.7 (21/3) and 5.4 (13)) that if the result is
4096 -- invalid (e.g. it is outside the base range), then Constraint_Error
4097 -- must be raised.
4099 -- Case of validity check required (validity checks are on, the
4100 -- expression is not known to be valid, and the case statement
4101 -- comes from source -- no need to validity check internally
4102 -- generated case statements).
4104 if Validity_Check_Default
4106 then
4107 -- Recognize the simple case where Expr is an object reference
4108 -- and the case statement is directly preceded by an
4109 -- "if Obj'Valid then": in this case, do not emit another validity
4110 -- check.
4112 declare
4115 begin
4119 = N_Attribute_Reference
4121 then
4127 then
4138 -- If there is only a single alternative, just replace it with the
4139 -- sequence of statements since obviously that is what is going to
4140 -- be executed in all cases, except if it is the node to be wrapped
4141 -- by a transient scope, because this would cause the sequence of
4142 -- statements to be leaked out of the transient scope.
4148 then
4150 -- We still need to evaluate the expression if it has any side
4151 -- effects.
4156 -- Do not consider controlled objects found in a case statement
4157 -- which actually models a case expression because their early
4158 -- finalization will affect the result of the expression.
4166 -- That leaves the case statement as a shell. The alternative that
4167 -- will be executed is reset to a null list. So now we can kill
4168 -- the entire case statement.
4174 -- An optimization. If there are only two alternatives, and only
4175 -- a single choice, then rewrite the whole case statement as an
4176 -- if statement, since this can result in subsequent optimizations.
4177 -- This helps not only with case statements in the source of a
4178 -- simple form, but also with generated code (discriminant check
4179 -- functions in particular).
4181 -- Note: it is OK to do this before expanding out choices for any
4182 -- static predicates, since the if statement processing will handle
4183 -- the static predicate case fine.
4194 -- For TRUE, generate "expression", not expression = true
4198 then
4201 -- For FALSE, generate "expression" and switch then/else
4205 then
4210 -- For a range, generate "expression in range"
4217 then
4218 Cond :=
4223 -- A subtype indication is not a legal operator in a membership
4224 -- test, so retrieve its range.
4227 Cond :=
4230 Right_Opnd =>
4231 Relocate_Node
4234 -- For any other subexpression "expression = value"
4236 else
4237 Cond :=
4243 -- Now rewrite the case as an IF
4251 -- The rewritten if statement needs to inherit whether the
4252 -- case statement was expanded from a conditional expression,
4253 -- for proper handling of nested controlled objects.
4263 -- If the last alternative is not an Others choice, replace it with
4264 -- an N_Others_Choice. Note that we do not bother to call Analyze on
4265 -- the modified case statement, since it's only effect would be to
4266 -- compute the contents of the Others_Discrete_Choices which is not
4267 -- needed by the back end anyway.
4269 -- The reason for this is that the back end always needs some default
4270 -- for a switch, so if we have not supplied one in the processing
4271 -- above for validity checking, then we need to supply one here.
4276 -- If Predicates_Ignored is true the value does not satisfy the
4277 -- predicate, and there is no Others choice, Constraint_Error
4278 -- must be raised (RM 4.5.7 (21/3) and 5.4 (13)).
4281 declare
4291 begin
4296 else
4297 Set_Others_Discrete_Choices
4304 -- Deal with possible declarations of controlled objects, and also
4305 -- with rewriting choice sequences for static predicate references.
4310 -- Do not consider controlled objects found in a case statement
4311 -- which actually models a case expression because their early
4312 -- finalization will affect the result of the expression.
4327 -----------------------------
4328 -- Expand_N_Exit_Statement --
4329 -----------------------------
4331 -- The only processing required is to deal with a possible C/Fortran
4332 -- boolean value used as the condition for the exit statement.
4335 begin
4339 ----------------------------------
4340 -- Expand_Formal_Container_Loop --
4341 ----------------------------------
4356 begin
4357 -- The expansion of a formal container loop resembles the one for Ada
4358 -- containers. The only difference is that the primitives mention the
4359 -- domain of iteration explicitly, and function First applied to the
4360 -- container yields a cursor directly.
4362 -- Cursor : Cursor_type := First (Container);
4363 -- while Has_Element (Cursor, Container) loop
4364 -- <original loop statements>
4365 -- Cursor := Next (Container, Cursor);
4366 -- end loop;
4368 Build_Formal_Container_Iteration
4373 -- Build a block to capture declaration of the cursor
4378 Handled_Statement_Sequence =>
4382 -- The loop parameter is declared by an object declaration, but within
4383 -- the loop we must prevent user assignments to it, so we analyze the
4384 -- declaration and reset the entity kind, before analyzing the rest of
4385 -- the loop.
4397 -- The cursor was marked as a loop parameter to prevent user assignments
4398 -- to it, however this renders the advancement step illegal as it is not
4399 -- possible to change the value of a constant. Flag the advancement step
4400 -- as a legal form of assignment to remedy this side effect.
4405 -- Because we have to analyze the initial declaration of the loop
4406 -- parameter multiple times its scope is incorrectly set at this point
4407 -- to the one surrounding the block statement - so set the scope
4408 -- manually to be the actual block statement, and indicate that it is
4409 -- not visible after the block has been analyzed.
4415 ------------------------------------------
4416 -- Expand_Formal_Container_Element_Loop --
4417 ------------------------------------------
4440 begin
4441 -- For an element iterator, the Element aspect must be present,
4442 -- (this is checked during analysis).
4444 -- We create a block to hold a variable declaration initialized with
4445 -- a call to Element, and generate:
4447 -- Cursor : Cursor_Type := First (Container);
4448 -- while Has_Element (Cursor, Container) loop
4449 -- declare
4450 -- Elmt : Element_Type := Element (Container, Cursor);
4451 -- begin
4452 -- <original loop statements>
4453 -- Cursor := Next (Container, Cursor);
4454 -- end;
4455 -- end loop;
4457 Build_Formal_Container_Iteration
4464 -- The loop parameter is declared by an object declaration, but within
4465 -- the loop we must prevent user assignments to it; the following flag
4466 -- accomplishes that.
4470 -- Declaration for Element
4472 Elmt_Decl :=
4485 New_List
4488 Handled_Statement_Sequence =>
4492 -- The element is only modified in expanded code, so it appears as
4493 -- unassigned to the warning machinery. We must suppress this spurious
4494 -- warning explicitly.
4502 ----------------------------------
4503 -- Expand_N_Goto_When_Statement --
4504 ----------------------------------
4508 begin
4519 ---------------------------
4520 -- Expand_N_If_Statement --
4521 ---------------------------
4523 -- First we deal with the case of C and Fortran convention boolean values,
4524 -- with zero/nonzero semantics.
4526 -- Second, we deal with the obvious rewriting for the cases where the
4527 -- condition of the IF is known at compile time to be True or False.
4529 -- Third, we remove elsif parts which have non-empty Condition_Actions and
4530 -- rewrite as independent if statements. For example:
4532 -- if x then xs
4533 -- elsif y then ys
4534 -- ...
4535 -- end if;
4537 -- becomes
4538 --
4539 -- if x then xs
4540 -- else
4541 -- <<condition actions of y>>
4542 -- if y then ys
4543 -- ...
4544 -- end if;
4545 -- end if;
4547 -- This rewriting is needed if at least one elsif part has a non-empty
4548 -- Condition_Actions list. We also do the same processing if there is a
4549 -- constant condition in an elsif part (in conjunction with the first
4550 -- processing step mentioned above, for the recursive call made to deal
4551 -- with the created inner if, this deals with properly optimizing the
4552 -- cases of constant elsif conditions).
4562 -- Indicates whether we want warnings when we delete branches of the
4563 -- if statement based on constant condition analysis. We never want
4564 -- these warnings for expander generated code.
4566 begin
4567 -- Do not consider controlled objects found in an if statement which
4568 -- actually models an if expression because their early finalization
4569 -- will affect the result of the expression.
4577 -- The following loop deals with constant conditions for the IF. We
4578 -- need a loop because as we eliminate False conditions, we grab the
4579 -- first elsif condition and use it as the primary condition.
4583 -- If condition is True, we can simply rewrite the if statement now
4584 -- by replacing it by the series of then statements.
4588 -- All the else parts can be killed
4598 -- If condition is False, then we can delete the condition and
4599 -- the Then statements
4601 else
4602 -- We do not delete the condition if constant condition warnings
4603 -- are enabled, since otherwise we end up deleting the desired
4604 -- warning. Of course the backend will get rid of this True/False
4605 -- test anyway, so nothing is lost here.
4613 -- If there are no elsif statements, then we simply replace the
4614 -- entire if statement by the sequence of else statements.
4620 else
4628 -- If there are elsif statements, the first of them becomes the
4629 -- if/then section of the rebuilt if statement This is the case
4630 -- where we loop to reprocess this copied condition.
4632 else
4638 -- Hed might have been captured as the condition determining
4639 -- the current value for an entity. Now it is detached from
4640 -- the tree, so a Current_Value pointer in the condition might
4641 -- need to be updated.
4652 -- Loop through elsif parts, dealing with constant conditions and
4653 -- possible condition actions that are present.
4658 -- Do not consider controlled objects found in an if statement which
4659 -- actually models an if expression because their early finalization
4660 -- will affect the result of the expression.
4668 -- If there are condition actions, then rewrite the if statement as
4669 -- indicated above. We also do the same rewrite for a True or False
4670 -- condition. The further processing of this constant condition is
4671 -- then done by the recursive call to expand the newly created if
4672 -- statement
4676 then
4677 New_If :=
4684 -- Elsif parts for new if come from remaining elsif's of parent
4706 -- Note this is not an implicit if statement, since it is part of
4707 -- an explicit if statement in the source (or of an implicit if
4708 -- statement that has already been tested). We set the flag after
4709 -- calling Analyze to avoid generating extra warnings specific to
4710 -- pure if statements, however (see Sem_Ch5.Analyze_If_Statement).
4715 -- No special processing for that elsif part, move to next
4717 else
4722 -- Some more optimizations applicable if we still have an IF statement
4728 -- Another optimization, special cases that can be simplified
4730 -- if expression then
4731 -- return [standard.]true;
4732 -- else
4733 -- return [standard.]false;
4734 -- end if;
4736 -- can be changed to:
4738 -- return expression;
4740 -- and
4742 -- if expression then
4743 -- return [standard.]false;
4744 -- else
4745 -- return [standard.]true;
4746 -- end if;
4748 -- can be changed to:
4750 -- return not (expression);
4752 -- Do these optimizations only for internally generated code and only
4753 -- when -fpreserve-control-flow isn't set, to preserve the original
4754 -- source control flow.
4762 then
4763 declare
4770 begin
4772 and then
4774 then
4779 and then
4781 then
4784 then
4792 then
4795 Expression =>
4806 --------------------------
4807 -- Expand_Iterator_Loop --
4808 --------------------------
4817 begin
4818 -- Processing for arrays
4827 else
4831 -- Processing for containers
4833 else
4834 Expand_Iterator_Loop_Over_Container
4839 -------------------------------------
4840 -- Expand_Iterator_Loop_Over_Array --
4841 -------------------------------------
4857 begin
4865 -- for Element of Array loop
4867 -- It requires an internally generated cursor to iterate over the array
4873 -- Generate:
4874 -- Element : Component_Type renames Array (Iterator);
4875 -- Iterator is the index value, or a list of index values
4876 -- in the case of a multidimensional array.
4878 Ind_Comp :=
4883 -- Propagate the original node to the copy since the analysis of the
4884 -- following object renaming declaration relies on the original node.
4891 Subtype_Mark =>
4895 -- Mark the loop variable as needing debug info, so that expansion
4896 -- of the renaming will result in Materialize_Entity getting set via
4897 -- Debug_Renaming_Declaration. (This setting is needed here because
4898 -- the setting in Freeze_Entity comes after the expansion, which is
4899 -- too late. ???)
4903 -- Generate:
4905 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
4906 -- Element : Component_Type renames Array (Iterator);
4907 -- <original loop statements>
4908 -- end loop;
4910 -- If this is an iteration over a multidimensional array, the
4911 -- innermost loop is over the last dimension in Ada, and over
4912 -- the first dimension in Fortran.
4916 else
4920 Core_Loop :=
4922 Iteration_Scheme =>
4924 Loop_Parameter_Specification =>
4927 Discrete_Subtype_Definition =>
4937 -- Processing for multidimensional array. The body of each loop is
4938 -- a loop over a previous dimension, going in decreasing order in Ada
4939 -- and in increasing order in Fortran.
4945 else
4951 -- Generate the dimension loops starting from the innermost one
4953 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
4954 -- <core loop>
4955 -- end loop;
4957 Core_Loop :=
4959 Iteration_Scheme =>
4961 Loop_Parameter_Specification =>
4964 Discrete_Subtype_Definition =>
4974 -- Update the previously created object renaming declaration with
4975 -- the new iterator, by adding the index of the next loop to the
4976 -- indexed component, in the order that corresponds to the
4977 -- convention.
4982 else
4989 -- Inherit the loop identifier from the original loop. This ensures that
4990 -- the scope stack is consistent after the rewriting.
5000 -----------------------------------------
5001 -- Expand_Iterator_Loop_Over_Container --
5002 -----------------------------------------
5004 -- For a 'for ... in' loop, such as:
5006 -- for Cursor in Iterator_Function (...) loop
5007 -- ...
5008 -- end loop;
5010 -- we generate:
5012 -- Iter : Iterator_Type := Iterator_Function (...);
5013 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
5014 -- while Has_Element (Cursor) loop
5015 -- ...
5016 --
5017 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
5018 -- end loop;
5020 -- For a 'for ... of' loop, such as:
5022 -- for X of Container loop
5023 -- ...
5024 -- end loop;
5026 -- the RM implies the generation of:
5028 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
5029 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
5030 -- while Has_Element (Cursor) loop
5031 -- declare
5032 -- X : Element_Type renames Element (Cursor).Element.all;
5033 -- -- or Constant_Element
5034 -- begin
5035 -- ...
5036 -- end;
5037 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
5038 -- end loop;
5040 -- In the general case, we do what the RM says. However, the operations
5041 -- Element and Iter.Next are slow, which is bad inside a loop, because they
5042 -- involve dispatching via interfaces, secondary stack manipulation,
5043 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
5044 -- predefined containers, we use an equivalent but optimized expansion.
5046 -- In the optimized case, we make use of these:
5048 -- procedure _Next (Position : in out Cursor); -- instead of Iter.Next
5049 -- (or _Previous for reverse loops)
5051 -- function Pseudo_Reference
5052 -- (Container : aliased Vector'Class) return Reference_Control_Type;
5054 -- type Element_Access is access all Element_Type;
5056 -- function Get_Element_Access
5057 -- (Position : Cursor) return not null Element_Access;
5059 -- Next is declared in the visible part of the container packages.
5060 -- The other three are added in the private part. (We're not supposed to
5061 -- pollute the namespace for clients. The compiler has no trouble breaking
5062 -- privacy to call things in the private part of an instance.)
5064 -- Note that Next and Previous are renamed as _Next and _Previous with
5065 -- leading underscores. Leading underscores are illegal in Ada, but we
5066 -- allow them in the run-time library. This allows us to avoid polluting
5067 -- the user-visible namespaces.
5069 -- Source:
5071 -- for X of My_Vector loop
5072 -- X.Count := X.Count + 1;
5073 -- ...
5074 -- end loop;
5076 -- The compiler will generate:
5078 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector);
5079 -- -- Reversible_Iterator is an interface. Iterate is the
5080 -- -- Default_Iterator aspect of Vector. This increments Lock,
5081 -- -- disallowing tampering with cursors. Unfortunately, it does not
5082 -- -- increment Busy. The result of Iterate is Limited_Controlled;
5083 -- -- finalization will decrement Lock. This is a build-in-place
5084 -- -- dispatching call to Iterate.
5086 -- Cur : Cursor := First (Iter); -- or Last
5087 -- -- Dispatching call via interface.
5089 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
5090 -- -- Pseudo_Reference increments Busy, to detect tampering with
5091 -- -- elements, as required by RM. Also redundantly increment
5092 -- -- Lock. Finalization of Control will decrement both Busy and
5093 -- -- Lock. Pseudo_Reference returns a record containing a pointer to
5094 -- -- My_Vector, used by Finalize.
5095 -- --
5096 -- -- Control is not used below, except to finalize it -- it's purely
5097 -- -- an RAII thing. This is needed because we are eliminating the
5098 -- -- call to Reference within the loop.
5100 -- while Has_Element (Cur) loop
5101 -- declare
5102 -- X : My_Element renames Get_Element_Access (Cur).all;
5103 -- -- Get_Element_Access returns a pointer to the element
5104 -- -- designated by Cur. No dispatching here, and no horsing
5105 -- -- around with access discriminants. This is instead of the
5106 -- -- existing
5107 -- --
5108 -- -- X : My_Element renames Reference (Cur).Element.all;
5109 -- --
5110 -- -- which creates a controlled object.
5111 -- begin
5112 -- -- Any attempt to tamper with My_Vector here in the loop
5113 -- -- will correctly raise Program_Error, because of the
5114 -- -- Control.
5115 --
5116 -- X.Count := X.Count + 1;
5117 -- ...
5118 --
5119 -- _Next (Cur); -- or _Previous
5120 -- -- This is instead of "Cur := Next (Iter, Cur);"
5121 -- end;
5122 -- -- No finalization here
5123 -- end loop;
5124 -- Finalize Iter and Control here, decrementing Lock twice and Busy
5125 -- once.
5127 -- This optimization makes "for ... of" loops over 30 times faster in cases
5128 -- measured.
5130 procedure Expand_Iterator_Loop_Over_Container
5135 is
5142 -- Maybe wrapped in a conditional if a filter is present
5155 -- Only for optimized version of "for ... of"
5158 -- The package in which the iterator interface is instantiated. This is
5159 -- typically an instance within the container package.
5161 begin
5169 -- Determine the advancement and initialization steps for the cursor.
5170 -- Analysis of the expanded loop will verify that the container has a
5171 -- reverse iterator.
5177 else
5183 -- The type of the iterator is the return type of the Iterate function
5184 -- used. For the "of" form this is the default iterator for the type,
5185 -- otherwise it is the type of the explicit function used in the
5186 -- iterator specification. The most common case will be an Iterate
5187 -- function in the container package.
5189 -- The Iterator type is declared in an instance within the container
5190 -- package itself, for example:
5192 -- package Vector_Iterator_Interfaces is new
5193 -- Ada.Iterator_Interfaces (Cursor, Has_Element);
5199 function Get_Default_Iterator
5201 -- Return the default iterator for a specific type. If the type is
5202 -- derived, we return the inherited or overridden one if
5203 -- appropriate.
5205 --------------------------
5206 -- Get_Default_Iterator --
5207 --------------------------
5209 function Get_Default_Iterator
5211 is
5217 begin
5220 -- A previous version of GNAT allowed indexing aspects to be
5221 -- redefined on derived container types, while the default
5222 -- iterator was inherited from the parent type. This
5223 -- nonstandard extension is preserved for use by the
5224 -- modeling project under debug flag -gnatd.X.
5229 then
5230 Container_Arg :=
5232 Subtype_Mark =>
5233 New_Occurrence_Of
5242 -- The default iterator must be a primitive operation of the
5243 -- type, at the same dispatch slot position. The DT position
5244 -- may not be established if type is not frozen yet.
5251 or else
5255 then
5262 -- If we didn't find it, then our parent type is not
5263 -- iterable, so we return the Default_Iterator aspect of
5264 -- this type.
5268 -- Otherwise not a derived type
5270 else
5275 -- Local variables
5281 -- The package in which the container type is declared
5286 -- Start of processing for Handle_Of
5288 begin
5290 Default_Iter :=
5292 else
5298 -- For a container element iterator, the iterator type is obtained
5299 -- from the corresponding aspect, whose return type is descended
5300 -- from the corresponding interface type in some instance of
5301 -- Ada.Iterator_Interfaces. The actuals of that instantiation
5302 -- are Cursor and Has_Element.
5306 -- If the container type is a derived type, the cursor type is
5307 -- found in the package of the ultimate ancestor type.
5311 else
5315 -- Find declarations needed for "for ... of" optimization.
5316 -- These declarations come from GNAT sources or sources
5317 -- derived from them. User code may include additional
5318 -- overloadings with similar names, and we need to perforn
5319 -- some reasonable resolution to find the needed primitives.
5320 -- Note that we use _Next or _Previous to avoid picking up
5321 -- some arbitrary user-defined Next or Previous.
5325 -- Get_Element_Access function with one parameter called
5326 -- Position.
5333 then
5337 -- Next or Prev procedure with one parameter called
5338 -- Position.
5358 then
5362 Object_Definition =>
5364 Expression =>
5366 Name =>
5368 Parameter_Associations =>
5372 -- Rewrite domain of iteration as a call to the default iterator
5373 -- for the container type. The formal may be an access parameter
5374 -- in which case we must build a reference to the container.
5376 declare
5378 begin
5380 Arg :=
5384 else
5390 Name =>
5397 -- The desired instantiation is the scope of an iterator interface
5398 -- type that is an ancestor of the iterator type.
5402 -- Find cursor type in proper iterator package, which is an
5403 -- instantiation of Iterator_Interfaces.
5416 Decl :=
5419 Subtype_Mark =>
5421 Name =>
5423 Prefix =>
5425 Name =>
5427 Parameter_Associations =>
5430 else
5431 Decl :=
5434 Subtype_Mark =>
5436 Name =>
5439 Expressions =>
5443 -- The defining identifier in the iterator is user-visible and
5444 -- must be visible in the debugger.
5448 -- If the container does not have a variable indexing aspect,
5449 -- the element is a constant in the loop. The container itself
5450 -- may be constant, in which case the element is a constant as
5451 -- well. The container has been rewritten as a call to Iterate,
5452 -- so examine original node.
5457 then
5464 -- X in Iterate (S) : type of iterator is type of explicitly given
5465 -- Iterate function, and the loop variable is the cursor. It will be
5466 -- assigned in the loop and must be a variable.
5468 else
5471 -- The instantiation in which to locate the Has_Element function
5472 -- is the scope containing an iterator interface type that is
5473 -- an ancestor of the iterator type.
5482 -- For both iterator forms, add a call to the step operation to advance
5483 -- the cursor. Generate:
5485 -- Cursor := Iterator.Next (Cursor);
5487 -- or else
5489 -- Cursor := Next (Cursor);
5492 declare
5496 begin
5497 Step_Call :=
5499 Name =>
5507 else
5508 declare
5511 begin
5512 Rhs :=
5514 Name =>
5529 -- Generate:
5530 -- while Has_Element (Cursor) loop
5531 -- <Stats>
5532 -- end loop;
5534 -- Has_Element is the second actual in the iterator package
5536 New_Loop :=
5538 Iteration_Scheme =>
5540 Condition =>
5542 Name =>
5543 New_Occurrence_Of
5551 -- If present, preserve identifier of loop, which can be used in an exit
5552 -- statement in the body.
5558 -- Create the declarations for Iterator and cursor and insert them
5559 -- before the source loop. Given that the domain of iteration is already
5560 -- an entity, the iterator is just a renaming of that entity. Possible
5561 -- optimization ???
5569 -- Create declaration for cursor
5571 declare
5575 Object_Definition =>
5577 Expression =>
5579 Prefix =>
5581 Selector_Name =>
5584 begin
5585 -- The cursor is only modified in expanded code, so it appears
5586 -- as unassigned to the warning machinery. We must suppress this
5587 -- spurious warning explicitly. The cursor's kind is that of the
5588 -- original loop parameter (it is a constant if the domain of
5589 -- iteration is constant).
5608 -----------------------------
5609 -- Expand_N_Loop_Statement --
5610 -----------------------------
5612 -- 1. Remove null loop entirely
5613 -- 2. Deal with while condition for C/Fortran boolean
5614 -- 3. Deal with loops with a non-standard enumeration type range
5615 -- 4. Deal with while loops where Condition_Actions is set
5616 -- 5. Deal with loops over predicated subtypes
5617 -- 6. Deal with loops with iterators over arrays and containers
5624 begin
5625 -- Delete null loop
5632 -- Deal with condition for C/Fortran Boolean
5638 -- Nothing more to do for plain loop with no iteration scheme
5643 -- Case of for loop (Loop_Parameter_Specification present)
5645 -- Note: we do not have to worry about validity checking of the for loop
5646 -- range bounds here, since they were frozen with constant declarations
5647 -- and it is during that process that the validity checking is done.
5650 declare
5661 begin
5662 -- If Discrete_Subtype_Definition has been rewritten as an
5663 -- N_Raise_xxx_Error, rewrite the whole loop as a raise node to
5664 -- avoid confusing the code generator down the line.
5667 then
5681 -- Deal with loop over predicates
5685 then
5688 -- Handle the case where we have a for loop with the range type
5689 -- being an enumeration type with non-standard representation.
5690 -- In this case we expand:
5692 -- for x in [reverse] a .. b loop
5693 -- ...
5694 -- end loop;
5696 -- to
5698 -- for xP in [reverse] integer
5699 -- range etype'Pos (a) .. etype'Pos (b)
5700 -- loop
5701 -- declare
5702 -- x : constant etype := Pos_To_Rep (xP);
5703 -- begin
5704 -- ...
5705 -- end;
5706 -- end loop;
5710 then
5711 New_Id :=
5715 -- If the type has a contiguous representation, successive
5716 -- values can be generated as offsets from the first literal.
5719 Expr :=
5722 Left_Opnd =>
5726 else
5727 -- Use the constructed array Enum_Pos_To_Rep
5729 Expr :=
5731 Prefix =>
5733 Expressions =>
5737 -- Build declaration for loop identifier
5739 Decls :=
5740 New_List (
5751 Iteration_Scheme =>
5753 Loop_Parameter_Specification =>
5758 Discrete_Subtype_Definition =>
5761 Subtype_Mark =>
5764 Constraint =>
5766 Range_Expression =>
5769 Low_Bound =>
5771 Prefix =>
5777 Relocate_Node
5780 High_Bound =>
5782 Prefix =>
5788 Relocate_Node
5789 (Type_High_Bound
5795 Handled_Statement_Sequence =>
5801 -- The loop parameter's entity must be removed from the loop
5802 -- scope's entity list and rendered invisible, since it will
5803 -- now be located in the new block scope. Any other entities
5804 -- already associated with the loop scope, such as the loop
5805 -- parameter's subtype, will remain there.
5807 -- In an element loop, the loop will contain a declaration for
5808 -- a cursor variable; otherwise the loop id is the first entity
5809 -- in the scope constructed for the loop.
5825 -- Nothing to do with other cases of for loops
5827 else
5832 -- Second case, if we have a while loop with Condition_Actions set, then
5833 -- we change it into a plain loop:
5835 -- while C loop
5836 -- ...
5837 -- end loop;
5839 -- changed to:
5841 -- loop
5842 -- <<condition actions>>
5843 -- exit when not C;
5844 -- ...
5845 -- end loop
5850 then
5851 declare
5854 begin
5855 ES :=
5857 Condition =>
5864 -- This is not an implicit loop, since it is generated in response
5865 -- to the loop statement being processed. If this is itself
5866 -- implicit, the restriction has already been checked. If not,
5867 -- it is an explicit loop.
5878 -- Here to deal with iterator case
5882 then
5885 -- An iterator loop may generate renaming declarations for elements
5886 -- that require debug information. This is the case in particular
5887 -- with element iterators, where debug information must be generated
5888 -- for the temporary that holds the element value. These temporaries
5889 -- are created within a transient block whose local declarations are
5890 -- transferred to the loop, which now has nontrivial local objects.
5894 then
5899 -- When the iteration scheme mentions attribute 'Loop_Entry, the loop
5900 -- is transformed into a conditional block where the original loop is
5901 -- the sole statement. Inspect the statements of the nested loop for
5902 -- controlled objects.
5913 ----------------------------
5914 -- Expand_Predicated_Loop --
5915 ----------------------------
5917 -- Note: the expander can handle generation of loops over predicated
5918 -- subtypes for both the dynamic and static cases. Depending on what
5919 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
5920 -- mode, the semantic analyzer may disallow one or both forms.
5932 begin
5933 -- Case of iteration over non-static predicate, should not be possible
5934 -- since this is not allowed by the semantics and should have been
5935 -- caught during analysis of the loop statement.
5940 -- If the predicate list is empty, that corresponds to a predicate of
5941 -- False, in which case the loop won't run at all, and we rewrite the
5942 -- entire loop as a null statement.
5948 -- For expansion over a static predicate we generate the following
5950 -- declare
5951 -- J : Ltype := min-val;
5952 -- begin
5953 -- loop
5954 -- body
5955 -- case J is
5956 -- when endpoint => J := startpoint;
5957 -- when endpoint => J := startpoint;
5958 -- ...
5959 -- when max-val => exit;
5960 -- when others => J := Lval'Succ (J);
5961 -- end case;
5962 -- end loop;
5963 -- end;
5965 -- with min-val replaced by max-val and Succ replaced by Pred if the
5966 -- loop parameter specification carries a Reverse indicator.
5968 -- To make this a little clearer, let's take a specific example:
5970 -- type Int is range 1 .. 10;
5971 -- subtype StaticP is Int with
5972 -- predicate => StaticP in 3 | 10 | 5 .. 7;
5973 -- ...
5974 -- for L in StaticP loop
5975 -- Put_Line ("static:" & J'Img);
5976 -- end loop;
5978 -- In this case, the loop is transformed into
5980 -- begin
5981 -- J : L := 3;
5982 -- loop
5983 -- body
5984 -- case J is
5985 -- when 3 => J := 5;
5986 -- when 7 => J := 10;
5987 -- when 10 => exit;
5988 -- when others => J := L'Succ (J);
5989 -- end case;
5990 -- end loop;
5991 -- end;
5993 -- In addition, if the loop specification is given by a subtype
5994 -- indication that constrains a predicated type, the bounds of
5995 -- iteration are given by those of the subtype indication.
5997 else
6005 -- If the domain is an itype, note the bounds of its range.
6011 -- Given static expression or static range, returns an identifier
6012 -- whose value is the low bound of the expression value or range.
6015 -- Given static expression or static range, returns an identifier
6016 -- whose value is the high bound of the expression value or range.
6018 ------------
6019 -- Hi_Val --
6020 ------------
6023 begin
6026 else
6032 ------------
6033 -- Lo_Val --
6034 ------------
6037 begin
6040 else
6046 -- Start of processing for Static_Predicate
6048 begin
6049 -- Convert loop identifier to normal variable and reanalyze it so
6050 -- that this conversion works. We have to use the same defining
6051 -- identifier, since there may be references in the loop body.
6056 -- In most loops the loop variable is assigned in various
6057 -- alternatives in the body. However, in the rare case when
6058 -- the range specifies a single element, the loop variable
6059 -- may trigger a spurious warning that is could be constant.
6060 -- This warning might as well be suppressed.
6069 -- Loop to create branches of case statement
6075 -- Initial value is largest value in predicate.
6078 D :=
6084 else
6085 D :=
6096 else
6097 S :=
6114 and then
6116 then
6123 else
6124 -- Initial value is smallest value in predicate
6127 D :=
6132 else
6133 D :=
6144 else
6145 S :=
6162 and then
6164 then
6172 -- Add others choice
6174 declare
6177 begin
6180 else
6184 S :=
6187 Expression =>
6201 -- Construct case statement and append to body statements
6203 Cstm :=
6209 -- Rewrite the loop preserving the loop identifier in case there
6210 -- are exit statements referencing it.
6213 Orig_Loop_Id := New_Occurrence_Of
6222 Handled_Statement_Sequence =>
6235 ------------------------------
6236 -- Make_Tag_Ctrl_Assignment --
6237 ------------------------------
6253 and then not Comp_Asn
6258 and then not Comp_Asn
6265 begin
6266 -- Finalize the target of the assignment when controlled
6268 -- We have two exceptions here:
6270 -- 1. If we are in an init proc or within an aggregate, since it is an
6271 -- initialization more than an assignment.
6273 -- 2. If the left-hand side is a temporary that was not initialized
6274 -- (or the parent part of a temporary since it is the case in
6275 -- extension aggregates). Such a temporary does not come from
6276 -- source. We must examine the original node for the prefix, because
6277 -- it may be a component of an entry formal, in which case it has
6278 -- been rewritten and does not appear to come from source either.
6280 -- Case of init proc or aggregate
6285 -- The left-hand side is an uninitialized temporary object
6290 N_Object_Declaration
6292 then
6295 else
6296 Fin_Call :=
6297 Make_Final_Call
6306 -- Save the Tag in a local variable Tag_Id
6315 Expression =>
6318 Selector_Name =>
6321 -- Otherwise Tag_Id is not used
6323 else
6327 -- If the tagged type has a full rep clause, expand the assignment into
6328 -- component-wise assignments. Mark the node as unanalyzed in order to
6329 -- generate the proper code and propagate this scenario by setting a
6330 -- flag to avoid infinite recursion.
6339 -- Restore the tag
6344 Name =>
6347 Selector_Name =>
6351 -- Or else just initialize it
6355 Make_Tag_Assignment_From_Type
6359 -- Adjust the target after the assignment when controlled (not in the
6360 -- init proc since it is an initialization more than an assignment).
6363 Adj_Call :=
6364 Make_Adjust_Call
6375 exception
6377 -- Could use comment here ???