| blob | 4552a3b0c6fa98679839c4b85b12f521b5c63e11 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 5 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
67 procedure Build_Formal_Container_Iteration
74 -- Utility to create declarations and loop statement for both forms
75 -- of formal container iterators.
77 function Convert_To_Iterable_Type
80 -- Returns New_Occurrence_Of (Container), possibly converted to an ancestor
81 -- type, if the type of Container inherited the Iterable aspect from that
82 -- ancestor.
85 -- Determine if the right-hand side of assignment N is a type conversion
86 -- which requires a change of representation. Called only for the array
87 -- and record cases.
90 -- N is an assignment which assigns an array value. This routine process
91 -- the various special cases and checks required for such assignments,
92 -- including change of representation. Rhs is normally simply the right-
93 -- hand side of the assignment, except that if the right-hand side is a
94 -- type conversion or a qualified expression, then the RHS is the actual
95 -- expression inside any such type conversions or qualifications.
97 function Expand_Assign_Array_Loop
105 -- N is an assignment statement which assigns an array value. This routine
106 -- expands the assignment into a loop (or nested loops for the case of a
107 -- multi-dimensional array) to do the assignment component by component.
108 -- Larray and Rarray are the entities of the actual arrays on the left-hand
109 -- and right-hand sides. L_Type and R_Type are the types of these arrays
110 -- (which may not be the same, due to either sliding, or to a change of
111 -- representation case). Ndim is the number of dimensions and the parameter
112 -- Rev indicates if the loops run normally (Rev = False), or reversed
113 -- (Rev = True). The value returned is the constructed loop statement.
114 -- Auxiliary declarations are inserted before node N using the standard
115 -- Insert_Actions mechanism.
118 -- N is an assignment of an untagged record value. This routine handles
119 -- the case where the assignment must be made component by component,
120 -- either because the target is not byte aligned, or there is a change
121 -- of representation, or when we have a tagged type with a representation
122 -- clause (this last case is required because holes in the tagged type
123 -- might be filled with components from child types).
126 -- (AI12-0125): N is an assignment statement whose RHS contains occurrences
127 -- of @ that designate the value of the LHS of the assignment. If the LHS
128 -- is side-effect free the target names can be replaced with a copy of the
129 -- LHS; otherwise the semantics of the assignment is described in terms of
130 -- a procedure with an in-out parameter, and expanded as such.
133 -- Use the primitives specified in an Iterable aspect to expand a loop
134 -- over a so-called formal container, primarily for SPARK usage.
137 -- Same, for an iterator of the form " For E of C". In this case the
138 -- iterator provides the name of the element, and the cursor is generated
139 -- internally.
142 -- Expand loop over arrays and containers that uses the form "for X of C"
143 -- with an optional subtype mark, or "for Y in C".
145 procedure Expand_Iterator_Loop_Over_Container
151 -- Expand loop over containers that uses the form "for X of C" with an
152 -- optional subtype mark, or "for Y in C". Isc is the iteration scheme.
153 -- I_Spec is the iterator specification and Container is either the
154 -- Container (for OF) or the iterator (for IN).
157 -- Expand for loop over predicated subtype
160 -- Generate the necessary code for controlled and tagged assignment, that
161 -- is to say, finalization of the target before, adjustment of the target
162 -- after and save and restore of the tag and finalization pointers which
163 -- are not 'part of the value' and must not be changed upon assignment. N
164 -- is the original Assignment node.
166 --------------------------------------
167 -- Build_Formal_Container_iteration --
168 --------------------------------------
170 procedure Build_Formal_Container_Iteration
177 is
188 begin
189 -- Use the proper set of primitives depending on the direction of
190 -- iteration. The legality of a reverse iteration has been checked
191 -- during analysis.
197 else
202 -- Declaration for Cursor
204 Init :=
208 Expression =>
214 -- Statement that advances (in the right direction) cursor in loop
216 Advance :=
219 Expression =>
226 -- Iterator is rewritten as a while_loop
228 New_Loop :=
230 Iteration_Scheme =>
232 Condition =>
242 ------------------------------
243 -- Change_Of_Representation --
244 ------------------------------
248 begin
249 return
251 and then
255 ------------------------------
256 -- Convert_To_Iterable_Type --
257 ------------------------------
259 function Convert_To_Iterable_Type
262 is
267 begin
271 Result :=
280 -------------------------
281 -- Expand_Assign_Array --
282 -------------------------
284 -- There are two issues here. First, do we let Gigi do a block move, or
285 -- do we expand out into a loop? Second, we need to set the two flags
286 -- Forwards_OK and Backwards_OK which show whether the block move (or
287 -- corresponding loops) can be legitimately done in a forwards (low to
288 -- high) or backwards (high to low) manner.
314 -- This switch is set to True if the array move must be done using
315 -- an explicit front end generated loop.
318 -- If the argument is an access to an array, and the assignment is
319 -- converted into a procedure call, apply explicit dereference.
322 -- Test if Exp is a reference to an array whose declaration has
323 -- an address clause, or it is a slice of such an array.
326 -- Test if Exp is a reference to an array which is either a formal
327 -- parameter or a slice of a formal parameter. These are the cases
328 -- where hidden aliasing can occur.
331 -- Determine if Exp is a reference to an array variable which is other
332 -- than an object defined in the current scope, or a component or a
333 -- slice of such an object. Such objects can be aliased to parameters
334 -- (unlike local array references).
336 -----------------------
337 -- Apply_Dereference --
338 -----------------------
342 begin
350 ------------------------
351 -- Has_Address_Clause --
352 ------------------------
355 begin
356 return
359 or else
363 ---------------------
364 -- Is_Formal_Array --
365 ---------------------
368 begin
369 return
371 or else
375 ------------------------
376 -- Is_Non_Local_Array --
377 ------------------------
380 begin
382 when N_Indexed_Component
383 | N_Selected_Component
384 | N_Slice
385 =>
389 return
395 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
403 -- Start of processing for Expand_Assign_Array
405 begin
406 -- Deal with length check. Note that the length check is done with
407 -- respect to the right-hand side as given, not a possible underlying
408 -- renamed object, since this would generate incorrect extra checks.
412 -- We start by assuming that the move can be done in either direction,
413 -- i.e. that the two sides are completely disjoint.
418 -- Normally it is only the slice case that can lead to overlap, and
419 -- explicit checks for slices are made below. But there is one case
420 -- where the slice can be implicit and invisible to us: when we have a
421 -- one dimensional array, and either both operands are parameters, or
422 -- one is a parameter (which can be a slice passed by reference) and the
423 -- other is a non-local variable. In this case the parameter could be a
424 -- slice that overlaps with the other operand.
426 -- However, if the array subtype is a constrained first subtype in the
427 -- parameter case, then we don't have to worry about overlap, since
428 -- slice assignments aren't possible (other than for a slice denoting
429 -- the whole array).
431 -- Note: No overlap is possible if there is a change of representation,
432 -- so we can exclude this case.
435 and then not Crep
436 and then
438 or else
440 or else
442 and then
445 then
449 -- Note: the bit-packed case is not worrisome here, since if we have
450 -- a slice passed as a parameter, it is always aligned on a byte
451 -- boundary, and if there are no explicit slices, the assignment
452 -- can be performed directly.
455 -- If either operand has an address clause clear Backwards_OK and
456 -- Forwards_OK, since we cannot tell if the operands overlap. We
457 -- exclude this treatment when Rhs is an aggregate, since we know
458 -- that overlap can't occur.
462 then
467 -- We certainly must use a loop for change of representation and also
468 -- we use the operand of the conversion on the right-hand side as the
469 -- effective right-hand side (the component types must match in this
470 -- situation).
477 -- We require a loop if the left side is possibly bit unaligned
480 or else
482 then
485 -- Arrays with controlled components are expanded into a loop to force
486 -- calls to Adjust at the component level.
491 -- If object is atomic/VFA, we cannot tolerate a loop
494 or else
496 then
499 -- Loop is required if we have atomic components since we have to
500 -- be sure to do any accesses on an element by element basis.
506 then
509 -- Case where no slice is involved
513 -- The following code deals with the case of unconstrained bit packed
514 -- arrays. The problem is that the template for such arrays contains
515 -- the bounds of the actual source level array, but the copy of an
516 -- entire array requires the bounds of the underlying array. It would
517 -- be nice if the back end could take care of this, but right now it
518 -- does not know how, so if we have such a type, then we expand out
519 -- into a loop, which is inefficient but works correctly. If we don't
520 -- do this, we get the wrong length computed for the array to be
521 -- moved. The two cases we need to worry about are:
523 -- Explicit dereference of an unconstrained packed array type as in
524 -- the following example:
526 -- procedure C52 is
527 -- type BITS is array(INTEGER range <>) of BOOLEAN;
528 -- pragma PACK(BITS);
529 -- type A is access BITS;
530 -- P1,P2 : A;
531 -- begin
532 -- P1 := new BITS (1 .. 65_535);
533 -- P2 := new BITS (1 .. 65_535);
534 -- P2.ALL := P1.ALL;
535 -- end C52;
537 -- A formal parameter reference with an unconstrained bit array type
538 -- is the other case we need to worry about (here we assume the same
539 -- BITS type declared above):
541 -- procedure Write_All (File : out BITS; Contents : BITS);
542 -- begin
543 -- File.Storage := Contents;
544 -- end Write_All;
546 -- We expand to a loop in either of these two cases
548 -- Question for future thought. Another potentially more efficient
549 -- approach would be to create the actual subtype, and then do an
550 -- unchecked conversion to this actual subtype ???
555 -- Function to perform required test for the first case, above
556 -- (dereference of an unconstrained bit packed array).
558 -----------------------
559 -- Is_UBPA_Reference --
560 -----------------------
567 begin
571 then
580 else
582 return
587 else
592 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
594 begin
596 or else
598 then
601 -- Here if we do not have the case of a reference to a bit packed
602 -- unconstrained array case. In this case gigi can most certainly
603 -- handle the assignment if a forwards move is allowed.
605 -- (could it handle the backwards case also???)
612 -- The back end can always handle the assignment if the right side is a
613 -- string literal (note that overlap is definitely impossible in this
614 -- case). If the type is packed, a string literal is always converted
615 -- into an aggregate, except in the case of a null slice, for which no
616 -- aggregate can be written. In that case, rewrite the assignment as a
617 -- null statement, a length check has already been emitted to verify
618 -- that the range of the left-hand side is empty.
620 -- Note that this code is not executed if we have an assignment of a
621 -- string literal to a non-bit aligned component of a record, a case
622 -- which cannot be handled by the backend.
627 then
634 -- If either operand is bit packed, then we need a loop, since we can't
635 -- be sure that the slice is byte aligned. Similarly, if either operand
636 -- is a possibly unaligned slice, then we need a loop (since the back
637 -- end cannot handle unaligned slices).
643 then
646 -- If we are not bit-packed, and we have only one slice, then no overlap
647 -- is possible except in the parameter case, so we can let the back end
648 -- handle things.
656 -- If the right-hand side is a string literal, introduce a temporary for
657 -- it, for use in the generated loop that will follow.
660 declare
664 begin
665 Decl :=
677 -- Come here to complete the analysis
679 -- Loop_Required: Set to True if we know that a loop is required
680 -- regardless of overlap considerations.
682 -- Forwards_OK: Set to False if we already know that a forwards
683 -- move is not safe, else set to True.
685 -- Backwards_OK: Set to False if we already know that a backwards
686 -- move is not safe, else set to True
688 -- Our task at this stage is to complete the overlap analysis, which can
689 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
690 -- then generating the final code, either by deciding that it is OK
691 -- after all to let Gigi handle it, or by generating appropriate code
692 -- in the front end.
694 declare
712 begin
713 -- Get the expressions for the arrays. If we are dealing with a
714 -- private type, then convert to the underlying type. We can do
715 -- direct assignments to an array that is a private type, but we
716 -- cannot assign to elements of the array without this extra
717 -- unchecked conversion.
719 -- Note: We propagate Parent to the conversion nodes to generate
720 -- a well-formed subtree.
724 else
728 declare
730 begin
731 Larray :=
732 Unchecked_Convert_To
741 else
745 declare
747 begin
748 Rarray :=
749 Unchecked_Convert_To
756 -- If both sides are slices, we must figure out whether it is safe
757 -- to do the move in one direction or the other. It is always safe
758 -- if there is a change of representation since obviously two arrays
759 -- with different representations cannot possibly overlap.
765 -- If both left- and right-hand arrays are entity names, and refer
766 -- to different entities, then we know that the move is safe (the
767 -- two storage areas are completely disjoint).
772 then
775 -- Otherwise, we assume the worst, which is that the two arrays
776 -- are the same array. There is no need to check if we know that
777 -- is the case, because if we don't know it, we still have to
778 -- assume it.
780 -- Generally if the same array is involved, then we have an
781 -- overlapping case. We will have to really assume the worst (i.e.
782 -- set neither of the OK flags) unless we can determine the lower
783 -- or upper bounds at compile time and compare them.
785 else
786 Cresult :=
787 Compile_Time_Compare
791 Cresult :=
792 Compile_Time_Compare
810 -- If after that analysis Loop_Required is False, meaning that we
811 -- have not discovered some non-overlap reason for requiring a loop,
812 -- then the outcome depends on the capabilities of the back end.
815 -- Assume the back end can deal with all cases of overlap by
816 -- falling back to memmove if it cannot use a more efficient
817 -- approach.
822 -- At this stage we have to generate an explicit loop, and we have
823 -- the following cases:
825 -- Forwards_OK = True
827 -- Rnn : right_index := right_index'First;
828 -- for Lnn in left-index loop
829 -- left (Lnn) := right (Rnn);
830 -- Rnn := right_index'Succ (Rnn);
831 -- end loop;
833 -- Note: the above code MUST be analyzed with checks off, because
834 -- otherwise the Succ could overflow. But in any case this is more
835 -- efficient.
837 -- Forwards_OK = False, Backwards_OK = True
839 -- Rnn : right_index := right_index'Last;
840 -- for Lnn in reverse left-index loop
841 -- left (Lnn) := right (Rnn);
842 -- Rnn := right_index'Pred (Rnn);
843 -- end loop;
845 -- Note: the above code MUST be analyzed with checks off, because
846 -- otherwise the Pred could overflow. But in any case this is more
847 -- efficient.
849 -- Forwards_OK = Backwards_OK = False
851 -- This only happens if we have the same array on each side. It is
852 -- possible to create situations using overlays that violate this,
853 -- but we simply do not promise to get this "right" in this case.
855 -- There are two possible subcases. If the No_Implicit_Conditionals
856 -- restriction is set, then we generate the following code:
858 -- declare
859 -- T : constant <operand-type> := rhs;
860 -- begin
861 -- lhs := T;
862 -- end;
864 -- If implicit conditionals are permitted, then we generate:
866 -- if Left_Lo <= Right_Lo then
867 -- <code for Forwards_OK = True above>
868 -- else
869 -- <code for Backwards_OK = True above>
870 -- end if;
872 -- In order to detect possible aliasing, we examine the renamed
873 -- expression when the source or target is a renaming. However,
874 -- the renaming may be intended to capture an address that may be
875 -- affected by subsequent code, and therefore we must recover
876 -- the actual entity for the expansion that follows, not the
877 -- object it renames. In particular, if source or target designate
878 -- a portion of a dynamically allocated object, the pointer to it
879 -- may be reassigned but the renaming preserves the proper location.
882 and then
885 then
890 and then
893 then
897 -- Cases where either Forwards_OK or Backwards_OK is true
904 then
905 declare
910 begin
922 New_Occurrence_Of (
931 else
933 Expand_Assign_Array_Loop
938 -- Case of both are false with No_Implicit_Conditionals
941 declare
945 begin
952 Object_Definition =>
956 Handled_Statement_Sequence =>
964 -- Case of both are false with implicit conditionals allowed
966 else
967 -- Before we generate this code, we must ensure that the left and
968 -- right side array types are defined. They may be itypes, and we
969 -- cannot let them be defined inside the if, since the first use
970 -- in the then may not be executed.
975 -- We normally compare addresses to find out which way round to
976 -- do the loop, since this is reliable, and handles the cases of
977 -- parameters, conversions etc. But we can't do that in the bit
978 -- packed case, because addresses don't work there.
981 Condition :=
983 Left_Opnd =>
986 Prefix =>
988 Prefix =>
992 Prefix =>
993 New_Occurrence_Of
998 Right_Opnd =>
1001 Prefix =>
1003 Prefix =>
1007 Prefix =>
1008 New_Occurrence_Of
1013 -- For the bit packed and VM cases we use the bounds. That's OK,
1014 -- because we don't have to worry about parameters, since they
1015 -- cannot cause overlap. Perhaps we should worry about weird slice
1016 -- conversions ???
1018 else
1019 -- Copy the bounds
1024 -- If the types do not match we add an implicit conversion
1025 -- here to ensure proper match
1028 Cright_Lo :=
1032 -- Reset the Analyzed flag, because the bounds of the index
1033 -- type itself may be universal, and must must be reanalyzed
1034 -- to acquire the proper type for the back end.
1039 Condition :=
1049 then
1051 -- Call TSS procedure for array assignment, passing the
1052 -- explicit bounds of right- and left-hand sides.
1054 declare
1059 begin
1080 else
1086 Expand_Assign_Array_Loop
1091 Expand_Assign_Array_Loop
1100 exception
1105 ------------------------------
1106 -- Expand_Assign_Array_Loop --
1107 ------------------------------
1109 -- The following is an example of the loop generated for the case of a
1110 -- two-dimensional array:
1112 -- declare
1113 -- R2b : Tm1X1 := 1;
1114 -- begin
1115 -- for L1b in 1 .. 100 loop
1116 -- declare
1117 -- R4b : Tm1X2 := 1;
1118 -- begin
1119 -- for L3b in 1 .. 100 loop
1120 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
1121 -- R4b := Tm1X2'succ(R4b);
1122 -- end loop;
1123 -- end;
1124 -- R2b := Tm1X1'succ(R2b);
1125 -- end loop;
1126 -- end;
1128 -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand
1129 -- side. The declarations of R2b and R4b are inserted before the original
1130 -- assignment statement.
1132 function Expand_Assign_Array_Loop
1140 is
1145 -- Entities used as subscripts on left and right sides
1149 -- Left and right index types
1157 -- The increment step for the index of the right-hand side is written
1158 -- as an attribute reference (Succ or Pred). This function returns
1159 -- the corresponding node, which is placed at the end of the loop body.
1161 ----------------
1162 -- Build_Step --
1163 ----------------
1169 begin
1172 else
1176 Step :=
1179 Expression =>
1181 Prefix =>
1187 -- Note that on the last iteration of the loop, the index is increased
1188 -- (or decreased) past the corresponding bound. This is consistent with
1189 -- the C semantics of the back-end, where such an off-by-one value on a
1190 -- dead index variable is OK. However, in CodePeer mode this leads to
1191 -- spurious warnings, and thus we place a guard around the attribute
1192 -- reference. For obvious reasons we only do this for CodePeer.
1195 Step :=
1197 Condition =>
1200 Right_Opnd =>
1210 -- Start of processing for Expand_Assign_Array_Loop
1212 begin
1216 else
1221 -- Setup index types and subscript entities
1223 declare
1227 begin
1243 -- Now construct the assignment statement
1245 declare
1249 begin
1255 Assign :=
1257 Name =>
1261 Expression =>
1266 -- We set assignment OK, since there are some cases, e.g. in object
1267 -- declarations, where we are actually assigning into a constant.
1268 -- If there really is an illegality, it was caught long before now,
1269 -- and was flagged when the original assignment was analyzed.
1273 -- Propagate the No_Ctrl_Actions flag to individual assignments
1278 -- Now construct the loop from the inside out, with the last subscript
1279 -- varying most rapidly. Note that Assign is first the raw assignment
1280 -- statement, and then subsequently the loop that wraps it up.
1283 Assign :=
1288 Object_Definition =>
1290 Expression =>
1295 Handled_Statement_Sequence =>
1299 Iteration_Scheme =>
1301 Loop_Parameter_Specification =>
1305 Discrete_Subtype_Definition =>
1314 --------------------------
1315 -- Expand_Assign_Record --
1316 --------------------------
1323 begin
1324 -- If change of representation, then extract the real right-hand side
1325 -- from the type conversion, and proceed with component-wise assignment,
1326 -- since the two types are not the same as far as the back end is
1327 -- concerned.
1332 -- If this may be a case of a large bit aligned component, then proceed
1333 -- with component-wise assignment, to avoid possible clobbering of other
1334 -- components sharing bits in the first or last byte of the component to
1335 -- be assigned.
1338 or
1340 then
1343 -- If we have a tagged type that has a complete record representation
1344 -- clause, we must do we must do component-wise assignments, since child
1345 -- types may have used gaps for their components, and we might be
1346 -- dealing with a view conversion.
1351 -- If neither condition met, then nothing special to do, the back end
1352 -- can handle assignment of the entire component as a single entity.
1354 else
1358 -- At this stage we know that we must do a component wise assignment
1360 declare
1367 function Find_Component
1370 -- Find the component with the given name in the underlying record
1371 -- declaration for Typ. We need to use the actual entity because the
1372 -- type may be private and resolution by identifier alone would fail.
1374 function Make_Component_List_Assign
1377 -- Returns a sequence of statements to assign the components that
1378 -- are referenced in the given component list. The flag U_U is
1379 -- used to force the usage of the inferred value of the variant
1380 -- part expression as the switch for the generated case statement.
1382 function Make_Field_Assign
1385 -- Given C, the entity for a discriminant or component, build an
1386 -- assignment for the corresponding field values. The flag U_U
1387 -- signals the presence of an Unchecked_Union and forces the usage
1388 -- of the inferred discriminant value of C as the right-hand side
1389 -- of the assignment.
1392 -- Given CI, a component items list, construct series of statements
1393 -- for fieldwise assignment of the corresponding components.
1395 --------------------
1396 -- Find_Component --
1397 --------------------
1399 function Find_Component
1402 is
1406 begin
1419 --------------------------------
1420 -- Make_Component_List_Assign --
1421 --------------------------------
1423 function Make_Component_List_Assign
1426 is
1437 begin
1454 Statements =>
1459 -- If we have an Unchecked_Union, use the value of the inferred
1460 -- discriminant of the variant part expression as the switch
1461 -- for the case statement. The case statement may later be
1462 -- folded.
1465 Expr :=
1470 else
1471 Expr :=
1474 Selector_Name =>
1487 -----------------------
1488 -- Make_Field_Assign --
1489 -----------------------
1491 function Make_Field_Assign
1494 is
1499 begin
1500 -- The discriminant entity to be used in the retrieval below must
1501 -- be one in the corresponding type, given that the assignment may
1502 -- be between derived and parent types.
1506 else
1510 -- In the case of an Unchecked_Union, use the discriminant
1511 -- constraint value as on the right-hand side of the assignment.
1514 Expr :=
1518 else
1519 Expr :=
1525 A :=
1527 Name =>
1530 Selector_Name =>
1534 -- Set Assignment_OK, so discriminants can be assigned
1541 then
1548 ------------------------
1549 -- Make_Field_Assigns --
1550 ------------------------
1556 begin
1562 -- Look for components, but exclude _tag field assignment if
1563 -- the special Componentwise_Assignment flag is set.
1568 then
1569 Append_To
1579 -- Start of processing for Expand_Assign_Record
1581 begin
1582 -- Note that we use the base types for this processing. This results
1583 -- in some extra work in the constrained case, but the change of
1584 -- representation case is so unusual that it is not worth the effort.
1586 -- First copy the discriminants. This is done unconditionally. It
1587 -- is required in the unconstrained left side case, and also in the
1588 -- case where this assignment was constructed during the expansion
1589 -- of a type conversion (since initialization of discriminants is
1590 -- suppressed in this case). It is unnecessary but harmless in
1591 -- other cases.
1593 -- Special case: no copy if the target has no discriminants
1597 then
1604 -- If we are expanding the initialization of a derived record
1605 -- that constrains or renames discriminants of the parent, we
1606 -- must use the corresponding discriminant in the parent.
1608 declare
1611 begin
1612 if Inside_Init_Proc
1614 then
1616 else
1622 -- Within an initialization procedure this is the
1623 -- assignment to an unchecked union component, in which
1624 -- case there is no discriminant to initialize.
1629 else
1630 -- The assignment is part of a conversion from a
1631 -- derived unchecked union type with an inferable
1632 -- discriminant, to a parent type.
1637 else
1645 -- If the derived type has a stored constraint, assign the value
1646 -- of the corresponding discriminants explicitly, skipping those
1647 -- that are renamed discriminants. We cannot just retrieve them
1648 -- from the Rhs by selected component because they are invisible
1649 -- in the type of the right-hand side.
1652 declare
1656 begin
1663 and then
1666 E_Discriminant)
1667 then
1668 Assign :=
1670 Name =>
1673 Selector_Name =>
1674 New_Occurrence_Of
1689 -- We know the underlying type is a record, but its current view
1690 -- may be private. We must retrieve the usable record declaration.
1693 N_Private_Extension_Declaration)
1695 then
1697 else
1707 then
1711 else
1712 Insert_Actions
1721 -------------------------------------
1722 -- Expand_Assign_With_Target_Names --
1723 -------------------------------------
1732 -- The entity of the left-hand side
1735 -- Replace occurrences of the target name by the proper entity: either
1736 -- the entity of the LHS in simple cases, or the formal of the
1737 -- constructed procedure otherwise.
1739 --------------------
1740 -- Replace_Target --
1741 --------------------
1744 begin
1748 -- The expression will be reanalyzed when the enclosing assignment
1749 -- is reanalyzed, so reset the entity, which may be a temporary
1750 -- created during analysis, e.g. a loop variable for an iterated
1751 -- component association. However, if entity is callable then
1752 -- resolution has established its proper identity (including in
1753 -- rewritten prefixed calls) so we must preserve it.
1758 then
1769 -- Local variables
1774 -- Start of processing for Expand_Assign_With_Target_Names
1776 begin
1779 -- The left-hand side is a direct name
1783 then
1787 -- Generate:
1788 -- LHS := ... LHS ...;
1795 -- The left-hand side is not a direct name, but is side-effect free.
1796 -- Capture its value in a temporary to avoid multiple evaluations.
1802 -- Generate:
1803 -- T : LHS_Typ := LHS;
1811 -- Generate:
1812 -- LHS := ... T ...;
1819 -- Otherwise wrap the whole assignment statement in a procedure with an
1820 -- IN OUT parameter. The original assignment then becomes a call to the
1821 -- procedure with the left-hand side as an actual.
1823 else
1827 -- Generate:
1828 -- procedure P (T : in out LHS_Typ) is
1829 -- begin
1830 -- T := ... T ...;
1831 -- end P;
1837 Specification =>
1845 Parameter_Type =>
1850 Handled_Statement_Sequence =>
1857 -- Generate:
1858 -- P (LHS);
1866 -- Analyze rewritten node, either as assignment or procedure call
1871 -----------------------------------
1872 -- Expand_N_Assignment_Statement --
1873 -----------------------------------
1875 -- This procedure implements various cases where an assignment statement
1876 -- cannot just be passed on to the back end in untransformed state.
1886 begin
1887 -- Special case to check right away, if the Componentwise_Assignment
1888 -- flag is set, this is a reanalysis from the expansion of the primitive
1889 -- assignment procedure for a tagged type, and all we need to do is to
1890 -- expand to assignment of components, because otherwise, we would get
1891 -- infinite recursion (since this looks like a tagged assignment which
1892 -- would normally try to *call* the primitive assignment procedure).
1899 -- Defend against invalid subscripts on left side if we are in standard
1900 -- validity checking mode. No need to do this if we are checking all
1901 -- subscripts.
1903 -- Note that we do this right away, because there are some early return
1904 -- paths in this procedure, and this is required on all paths.
1906 if Validity_Checks_On
1907 and then Validity_Check_Default
1908 and then not Validity_Check_Subscripts
1909 then
1913 -- Separate expansion if RHS contain target names. Note that assignment
1914 -- may already have been expanded if RHS is aggregate.
1921 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
1923 -- Rewrite an assignment to X'Priority into a run-time call
1925 -- For example: X'Priority := New_Prio_Expr;
1926 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
1928 -- Note that although X'Priority is notionally an object, it is quite
1929 -- deliberately not defined as an aliased object in the RM. This means
1930 -- that it works fine to rewrite it as a call, without having to worry
1931 -- about complications that would other arise from X'Priority'Access,
1932 -- which is illegal, because of the lack of aliasing.
1935 declare
1942 begin
1943 -- Handle chains of renamings
1949 loop
1953 -- The attribute Priority applied to protected objects has been
1954 -- previously expanded into a call to the Get_Ceiling run-time
1955 -- subprogram. In restricted profiles this is not available.
1959 -- Look for the enclosing concurrent type
1968 -- Generate the first actual of the call
1975 -- Select the appropriate run-time call
1978 RT_Subprg_Name :=
1980 else
1981 RT_Subprg_Name :=
1985 Call :=
2000 -- Deal with assignment checks unless suppressed
2004 -- First deal with generation of range check if required
2010 -- Then generate predicate check if required
2015 -- Check for a special case where a high level transformation is
2016 -- required. If we have either of:
2018 -- P.field := rhs;
2019 -- P (sub) := rhs;
2021 -- where P is a reference to a bit packed array, then we have to unwind
2022 -- the assignment. The exact meaning of being a reference to a bit
2023 -- packed array is as follows:
2025 -- An indexed component whose prefix is a bit packed array is a
2026 -- reference to a bit packed array.
2028 -- An indexed component or selected component whose prefix is a
2029 -- reference to a bit packed array is itself a reference ot a
2030 -- bit packed array.
2032 -- The required transformation is
2034 -- Tnn : prefix_type := P;
2035 -- Tnn.field := rhs;
2036 -- P := Tnn;
2038 -- or
2040 -- Tnn : prefix_type := P;
2041 -- Tnn (subscr) := rhs;
2042 -- P := Tnn;
2044 -- Since P is going to be evaluated more than once, any subscripts
2045 -- in P must have their evaluation forced.
2049 then
2050 declare
2056 begin
2057 -- Insert the post assignment first, because we want to copy the
2058 -- BPAR_Expr tree before it gets analyzed in the context of the
2059 -- pre assignment. Note that we do not analyze the post assignment
2060 -- yet (we cannot till we have completed the analysis of the pre
2061 -- assignment). As usual, the analysis of this post assignment
2062 -- will happen on its own when we "run into" it after finishing
2063 -- the current assignment.
2070 -- At this stage BPAR_Expr is a reference to a bit packed array
2071 -- where the reference was not expanded in the original tree,
2072 -- since it was on the left side of an assignment. But in the
2073 -- pre-assignment statement (the object definition), BPAR_Expr
2074 -- will end up on the right-hand side, and must be reexpanded. To
2075 -- achieve this, we reset the analyzed flag of all selected and
2076 -- indexed components down to the actual indexed component for
2077 -- the packed array.
2080 loop
2084 N_Selected_Component)
2085 then
2087 else
2092 -- Now we can insert and analyze the pre-assignment
2094 -- If the right-hand side requires a transient scope, it has
2095 -- already been placed on the stack. However, the declaration is
2096 -- inserted in the tree outside of this scope, and must reflect
2097 -- the proper scope for its variable. This awkward bit is forced
2098 -- by the stricter scope discipline imposed by GCC 2.97.
2100 declare
2102 Scope_Is_Transient
2105 begin
2117 Pop_Scope;
2121 -- Now fix up the original assignment and continue processing
2126 -- We do not need to reanalyze that assignment, and we do not need
2127 -- to worry about references to the temporary, but we do need to
2128 -- make sure that the temporary is not marked as a true constant
2129 -- since we now have a generated assignment to it.
2135 -- When we have the appropriate type of aggregate in the expression (it
2136 -- has been determined during analysis of the aggregate by setting the
2137 -- delay flag), let's perform in place assignment and thus avoid
2138 -- creating a temporary.
2148 -- Apply discriminant check if required. If Lhs is an access type to a
2149 -- designated type with discriminants, we must always check. If the
2150 -- type has unknown discriminants, more elaborate processing below.
2154 then
2155 -- Skip discriminant check if change of representation. Will be
2156 -- done when the change of representation is expanded out.
2162 -- If the type is private without discriminants, and the full type
2163 -- has discriminants (necessarily with defaults) a check may still be
2164 -- necessary if the Lhs is aliased. The private discriminants must be
2165 -- visible to build the discriminant constraints.
2167 -- Only an explicit dereference that comes from source indicates
2168 -- aliasing. Access to formals of protected operations and entries
2169 -- create dereferences but are not semantic aliasings.
2175 then
2176 declare
2180 begin
2181 -- In the case of an expander-generated record subtype whose base
2182 -- type still appears private, Typ will have been set to that
2183 -- private type rather than the underlying record type (because
2184 -- Underlying type will have returned the record subtype), so it's
2185 -- necessary to apply Underlying_Type again to the base type to
2186 -- get the record type we need for the discriminant check. Such
2187 -- subtypes can be created for assignments in certain cases, such
2188 -- as within an instantiation passed this kind of private type.
2189 -- It would be good to avoid this special test, but making changes
2190 -- to prevent this odd form of record subtype seems difficult. ???
2202 -- If the Lhs has a private type with unknown discriminants, it may
2203 -- have a full view with discriminants, but those are nameable only
2204 -- in the underlying type, so convert the Rhs to it before potential
2205 -- checking. Convert Lhs as well, otherwise the actual subtype might
2206 -- not be constructible. If the discriminants have defaults the type
2207 -- is unconstrained and there is nothing to check.
2212 then
2217 -- In the access type case, we need the same discriminant check, and
2218 -- also range checks if we have an access to constrained array.
2222 then
2225 -- Skip discriminant check if change of representation. Will be
2226 -- done when the change of representation is expanded out.
2240 declare
2244 begin
2245 C_Es :=
2246 Get_Range_Checks
2248 Target_Typ,
2251 Insert_Range_Checks
2253 N,
2254 Target_Typ,
2256 Lhs);
2261 -- Apply range check for access type case
2266 then
2268 Apply_Range_Check
2272 -- Ada 2005 (AI-231): Generate the run-time check
2278 -- If an actual is an out parameter of a null-excluding access
2279 -- type, there is access check on entry, so we set the flag
2280 -- Suppress_Assignment_Checks on the generated statement to
2281 -- assign the actual to the parameter block, and we do not want
2282 -- to generate an additional check at this point.
2285 then
2289 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2290 -- stand-alone obj of an anonymous access type. Do not install the check
2291 -- when the Lhs denotes a container cursor and the Next function employs
2292 -- an access type, because this can never result in a dangling pointer.
2298 then
2299 declare
2301 -- Look through renames to find the underlying entity.
2302 -- For assignment to a rename, we don't care about the
2303 -- Enclosing_Dynamic_Scope of the rename declaration.
2305 ----------------
2306 -- Lhs_Entity --
2307 ----------------
2312 begin
2315 -- Renamed_Object must return an Entity_Name here
2316 -- because of preceding "Present (E_E_A (...))" test.
2324 -- Local Declarations
2328 Condition =>
2330 Left_Opnd =>
2332 Right_Opnd =>
2334 Intval =>
2335 Scope_Depth
2336 (Enclosing_Dynamic_Scope
2342 Name =>
2343 New_Occurrence_Of
2344 (Effective_Extra_Accessibility
2346 Expression =>
2349 begin
2358 -- Case of assignment to a bit packed array element. If there is a
2359 -- change of representation this must be expanded into components,
2360 -- otherwise this is a bit-field assignment.
2364 then
2365 -- Normal case, no change of representation
2371 -- Change of representation case
2373 else
2374 -- Generate the following, to force component-by-component
2375 -- assignments in an efficient way. Otherwise each component
2376 -- will require a temporary and two bit-field manipulations.
2378 -- T1 : Elmt_Type;
2379 -- T1 := RhS;
2380 -- Lhs := T1;
2382 declare
2386 begin
2387 Stats :=
2388 New_List (
2391 Object_Definition =>
2406 -- Build-in-place function call case. This is for assignment statements
2407 -- that come from aggregate component associations or from init procs.
2408 -- User-written assignment statements with b-i-p calls are handled
2409 -- elsewhere.
2417 then
2422 begin
2423 -- In the controlled case, we ensure that function calls are
2424 -- evaluated before finalizing the target. In all cases, it makes
2425 -- the expansion easier if the side effects are removed first.
2430 -- Avoid recursion in the mechanism
2434 -- If dispatching assignment, we need to dispatch to _assign
2438 -- If the type is tagged, we may as well use the predefined
2439 -- primitive assignment. This avoids inlining a lot of code
2440 -- and in the class-wide case, the assignment is replaced
2441 -- by a dispatching call to _assign. It is suppressed in the
2442 -- case of assignments created by the expander that correspond
2443 -- to initializations, where we do want to copy the tag
2444 -- (Expand_Ctrl_Actions flag is set False in this case). It is
2445 -- also suppressed if restriction No_Dispatching_Calls is in
2446 -- force because in that case predefined primitives are not
2447 -- generated.
2451 and then Expand_Ctrl_Actions
2452 and then
2454 then
2457 -- This can happen in an instance when the formal is an
2458 -- extension of a limited interface, and the actual is
2459 -- limited. This is an error according to AI05-0087, but
2460 -- is not caught at the point of instantiation in earlier
2461 -- versions.
2463 -- This is wrong, error messages cannot be issued during
2464 -- expansion, since they would be missed in -gnatc mode ???
2470 -- Fetch the primitive op _assign and proper type to call it.
2471 -- Because of possible conflicts between private and full view,
2472 -- fetch the proper type directly from the operation profile.
2474 declare
2479 begin
2480 -- If the assignment is dispatching, make sure to use the
2481 -- proper type.
2489 -- In case of assignment to a class-wide tagged type, before
2490 -- the assignment we generate run-time check to ensure that
2491 -- the tags of source and target match.
2497 then
2498 declare
2502 begin
2504 Lhs_Tag :=
2507 Selector_Name =>
2509 Rhs_Tag :=
2512 Selector_Name =>
2514 else
2515 -- Displace the pointer to the base of the objects
2516 -- applying 'Address, which is later expanded into
2517 -- a call to RE_Base_Address.
2519 Lhs_Tag :=
2521 Prefix =>
2526 Rhs_Tag :=
2528 Prefix =>
2537 Condition =>
2545 declare
2549 begin
2550 -- In order to dispatch the call to _assign the type of
2551 -- the actuals must match. Add conversion (if required).
2570 else
2573 -- We can't afford to have destructive Finalization Actions in
2574 -- the Self assignment case, so if the target and the source
2575 -- are not obviously different, code is generated to avoid the
2576 -- self assignment case:
2578 -- if lhs'address /= rhs'address then
2579 -- <code for controlled and/or tagged assignment>
2580 -- end if;
2582 -- Skip this if Restriction (No_Finalization) is active
2585 and then Expand_Ctrl_Actions
2587 then
2590 Condition =>
2592 Left_Opnd =>
2597 Right_Opnd =>
2605 -- We need to set up an exception handler for implementing
2606 -- 7.6.1(18). The remaining adjustments are tackled by the
2607 -- implementation of adjust for record_controllers (see
2608 -- s-finimp.adb).
2610 -- This is skipped if we have no finalization
2612 if Expand_Ctrl_Actions
2614 then
2617 Handled_Statement_Sequence =>
2627 Handled_Statement_Sequence =>
2630 -- If no restrictions on aborts, protect the whole assignment
2631 -- for controlled objects as per 9.8(11).
2634 and then Expand_Ctrl_Actions
2635 and then Abort_Allowed
2636 then
2637 declare
2639 New_Internal_Entity
2643 begin
2654 -- Present the Abort_Undefer_Direct function to the backend
2655 -- so that it can inline the call to the function.
2659 Expand_At_End_Handler
2664 -- N has been rewritten to a block statement for which it is
2665 -- known by construction that no checks are necessary: analyze
2666 -- it with all checks suppressed.
2672 -- Array types
2675 declare
2678 begin
2680 N_Qualified_Expression)
2681 loop
2689 -- Record types
2695 -- Scalar types. This is where we perform the processing related to the
2696 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
2697 -- scalar values.
2701 -- Case where right side is known valid
2705 -- Here the right side is valid, so it is fine. The case to deal
2706 -- with is when the left side is a local variable reference whose
2707 -- value is not currently known to be valid. If this is the case,
2708 -- and the assignment appears in an unconditional context, then
2709 -- we can mark the left side as now being valid if one of these
2710 -- conditions holds:
2712 -- The expression of the right side has Do_Range_Check set so
2713 -- that we know a range check will be performed. Note that it
2714 -- can be the case that a range check is omitted because we
2715 -- make the assumption that we can assume validity for operands
2716 -- appearing in the right side in determining whether a range
2717 -- check is required
2719 -- The subtype of the right side matches the subtype of the
2720 -- left side. In this case, even though we have not checked
2721 -- the range of the right side, we know it is in range of its
2722 -- subtype if the expression is valid.
2727 then
2730 then
2735 -- Case where right side may be invalid in the sense of the RM
2736 -- reference above. The RM does not require that we check for the
2737 -- validity on an assignment, but it does require that the assignment
2738 -- of an invalid value not cause erroneous behavior.
2740 -- The general approach in GNAT is to use the Is_Known_Valid flag
2741 -- to avoid the need for validity checking on assignments. However
2742 -- in some cases, we have to do validity checking in order to make
2743 -- sure that the setting of this flag is correct.
2745 else
2746 -- Validate right side if we are validating copies
2748 if Validity_Checks_On
2749 and then Validity_Check_Copies
2750 then
2751 -- Skip this if left-hand side is an array or record component
2752 -- and elementary component validity checks are suppressed.
2755 and then not Validity_Check_Components
2756 then
2758 else
2762 -- We can propagate this to the left side where appropriate
2767 then
2771 -- Otherwise check to see what should be done
2773 -- If left side is a local variable, then we just set its flag to
2774 -- indicate that its value may no longer be valid, since we are
2775 -- copying a potentially invalid value.
2780 -- Check for case of a nonlocal variable on the left side which
2781 -- is currently known to be valid. In this case, we simply ensure
2782 -- that the right side is valid. We only play the game of copying
2783 -- validity status for local variables, since we are doing this
2784 -- statically, not by tracing the full flow graph.
2788 then
2789 -- Note: If Validity_Checking mode is set to none, we ignore
2790 -- the Ensure_Valid call so don't worry about that case here.
2794 -- In all other cases, we can safely copy an invalid value without
2795 -- worrying about the status of the left side. Since it is not a
2796 -- variable reference it will not be considered
2797 -- as being known to be valid in any case.
2799 else
2805 exception
2810 ------------------------------
2811 -- Expand_N_Block_Statement --
2812 ------------------------------
2814 -- Encode entity names defined in block statement
2817 begin
2821 -----------------------------
2822 -- Expand_N_Case_Statement --
2823 -----------------------------
2834 begin
2835 -- Check for the situation where we know at compile time which branch
2836 -- will be taken.
2838 -- If the value is static but its subtype is predicated and the value
2839 -- does not obey the predicate, the value is marked non-static, and
2840 -- there can be no corresponding static alternative. In that case we
2841 -- replace the case statement with an exception, regardless of whether
2842 -- assertions are enabled or not, unless predicates are ignored.
2848 then
2857 then
2860 -- Do not consider controlled objects found in a case statement which
2861 -- actually models a case expression because their early finalization
2862 -- will affect the result of the expression.
2868 -- Move statements from this alternative after the case statement.
2869 -- They are already analyzed, so will be skipped by the analyzer.
2873 -- That leaves the case statement as a shell. So now we can kill all
2874 -- other alternatives in the case statement.
2878 declare
2881 begin
2882 -- Loop through case alternatives, skipping pragmas, and skipping
2883 -- the one alternative that we select (and therefore retain).
2889 then
2901 -- Here if the choice is not determined at compile time
2903 declare
2912 begin
2916 else
2920 -- First step is to worry about possible invalid argument. The RM
2921 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
2922 -- outside the base range), then Constraint_Error must be raised.
2924 -- Case of validity check required (validity checks are on, the
2925 -- expression is not known to be valid, and the case statement
2926 -- comes from source -- no need to validity check internally
2927 -- generated case statements).
2929 if Validity_Check_Default
2931 then
2935 -- If there is only a single alternative, just replace it with the
2936 -- sequence of statements since obviously that is what is going to
2937 -- be executed in all cases.
2943 -- We still need to evaluate the expression if it has any side
2944 -- effects.
2949 -- Do not consider controlled objects found in a case statement
2950 -- which actually models a case expression because their early
2951 -- finalization will affect the result of the expression.
2959 -- That leaves the case statement as a shell. The alternative that
2960 -- will be executed is reset to a null list. So now we can kill
2961 -- the entire case statement.
2967 -- An optimization. If there are only two alternatives, and only
2968 -- a single choice, then rewrite the whole case statement as an
2969 -- if statement, since this can result in subsequent optimizations.
2970 -- This helps not only with case statements in the source of a
2971 -- simple form, but also with generated code (discriminant check
2972 -- functions in particular).
2974 -- Note: it is OK to do this before expanding out choices for any
2975 -- static predicates, since the if statement processing will handle
2976 -- the static predicate case fine.
2987 -- For TRUE, generate "expression", not expression = true
2991 then
2994 -- For FALSE, generate "expression" and switch then/else
2998 then
3003 -- For a range, generate "expression in range"
3010 then
3011 Cond :=
3016 -- A subtype indication is not a legal operator in a membership
3017 -- test, so retrieve its range.
3020 Cond :=
3023 Right_Opnd =>
3024 Relocate_Node
3027 -- For any other subexpression "expression = value"
3029 else
3030 Cond :=
3036 -- Now rewrite the case as an IF
3048 -- If the last alternative is not an Others choice, replace it with
3049 -- an N_Others_Choice. Note that we do not bother to call Analyze on
3050 -- the modified case statement, since it's only effect would be to
3051 -- compute the contents of the Others_Discrete_Choices which is not
3052 -- needed by the back end anyway.
3054 -- The reason for this is that the back end always needs some default
3055 -- for a switch, so if we have not supplied one in the processing
3056 -- above for validity checking, then we need to supply one here.
3061 -- If Predicates_Ignored is true the value does not satisfy the
3062 -- predicate, and there is no Others choice, Constraint_Error
3063 -- must be raised (4.5.7 (21/3)).
3066 declare
3076 begin
3081 else
3082 Set_Others_Discrete_Choices
3089 -- Deal with possible declarations of controlled objects, and also
3090 -- with rewriting choice sequences for static predicate references.
3095 -- Do not consider controlled objects found in a case statement
3096 -- which actually models a case expression because their early
3097 -- finalization will affect the result of the expression.
3112 -----------------------------
3113 -- Expand_N_Exit_Statement --
3114 -----------------------------
3116 -- The only processing required is to deal with a possible C/Fortran
3117 -- boolean value used as the condition for the exit statement.
3120 begin
3124 ----------------------------------
3125 -- Expand_Formal_Container_Loop --
3126 ----------------------------------
3141 begin
3142 -- The expansion of a formal container loop resembles the one for Ada
3143 -- containers. The only difference is that the primitives mention the
3144 -- domain of iteration explicitly, and function First applied to the
3145 -- container yields a cursor directly.
3147 -- Cursor : Cursor_type := First (Container);
3148 -- while Has_Element (Cursor, Container) loop
3149 -- <original loop statements>
3150 -- Cursor := Next (Container, Cursor);
3151 -- end loop;
3153 Build_Formal_Container_Iteration
3158 -- Build a block to capture declaration of the cursor
3163 Handled_Statement_Sequence =>
3167 -- The loop parameter is declared by an object declaration, but within
3168 -- the loop we must prevent user assignments to it, so we analyze the
3169 -- declaration and reset the entity kind, before analyzing the rest of
3170 -- the loop.
3176 -- The cursor was marked as a loop parameter to prevent user assignments
3177 -- to it, however this renders the advancement step illegal as it is not
3178 -- possible to change the value of a constant. Flag the advancement step
3179 -- as a legal form of assignment to remedy this side effect.
3184 -- Because we have to analyze the initial declaration of the loop
3185 -- parameter multiple times its scope is incorrectly set at this point
3186 -- to the one surrounding the block statement - so set the scope
3187 -- manually to be the actual block statement, and indicate that it is
3188 -- not visible after the block has been analyzed.
3194 ------------------------------------------
3195 -- Expand_Formal_Container_Element_Loop --
3196 ------------------------------------------
3220 begin
3221 -- For an element iterator, the Element aspect must be present,
3222 -- (this is checked during analysis) and the expansion takes the form:
3224 -- Cursor : Cursor_Type := First (Container);
3225 -- Elmt : Element_Type;
3226 -- while Has_Element (Cursor, Container) loop
3227 -- Elmt := Element (Container, Cursor);
3228 -- <original loop statements>
3229 -- Cursor := Next (Container, Cursor);
3230 -- end loop;
3232 -- However this expansion is not legal if the element is indefinite.
3233 -- In that case we create a block to hold a variable declaration
3234 -- initialized with a call to Element, and generate:
3236 -- Cursor : Cursor_Type := First (Container);
3237 -- while Has_Element (Cursor, Container) loop
3238 -- declare
3239 -- Elmt : Element_Type := Element (Container, Cursor);
3240 -- begin
3241 -- <original loop statements>
3242 -- Cursor := Next (Container, Cursor);
3243 -- end;
3244 -- end loop;
3246 Build_Formal_Container_Iteration
3253 -- Declaration for Element
3255 Elmt_Decl :=
3269 New_List
3272 Handled_Statement_Sequence =>
3276 else
3277 Elmt_Ref :=
3280 Expression =>
3289 -- The element is assignable in the expanded code
3293 -- The loop is rewritten as a block, to hold the element declaration
3295 New_Loop :=
3298 Handled_Statement_Sequence =>
3303 -- The element is only modified in expanded code, so it appears as
3304 -- unassigned to the warning machinery. We must suppress this spurious
3305 -- warning explicitly.
3311 -- The loop parameter is declared by an object declaration, but within
3312 -- the loop we must prevent user assignments to it, so we analyze the
3313 -- declaration and reset the entity kind, before analyzing the rest of
3314 -- the loop.
3322 -----------------------------
3323 -- Expand_N_Goto_Statement --
3324 -----------------------------
3326 -- Add poll before goto if polling active
3329 begin
3333 ---------------------------
3334 -- Expand_N_If_Statement --
3335 ---------------------------
3337 -- First we deal with the case of C and Fortran convention boolean values,
3338 -- with zero/non-zero semantics.
3340 -- Second, we deal with the obvious rewriting for the cases where the
3341 -- condition of the IF is known at compile time to be True or False.
3343 -- Third, we remove elsif parts which have non-empty Condition_Actions and
3344 -- rewrite as independent if statements. For example:
3346 -- if x then xs
3347 -- elsif y then ys
3348 -- ...
3349 -- end if;
3351 -- becomes
3352 --
3353 -- if x then xs
3354 -- else
3355 -- <<condition actions of y>>
3356 -- if y then ys
3357 -- ...
3358 -- end if;
3359 -- end if;
3361 -- This rewriting is needed if at least one elsif part has a non-empty
3362 -- Condition_Actions list. We also do the same processing if there is a
3363 -- constant condition in an elsif part (in conjunction with the first
3364 -- processing step mentioned above, for the recursive call made to deal
3365 -- with the created inner if, this deals with properly optimizing the
3366 -- cases of constant elsif conditions).
3376 -- Indicates whether we want warnings when we delete branches of the
3377 -- if statement based on constant condition analysis. We never want
3378 -- these warnings for expander generated code.
3380 begin
3381 -- Do not consider controlled objects found in an if statement which
3382 -- actually models an if expression because their early finalization
3383 -- will affect the result of the expression.
3391 -- The following loop deals with constant conditions for the IF. We
3392 -- need a loop because as we eliminate False conditions, we grab the
3393 -- first elsif condition and use it as the primary condition.
3397 -- If condition is True, we can simply rewrite the if statement now
3398 -- by replacing it by the series of then statements.
3402 -- All the else parts can be killed
3412 -- If condition is False, then we can delete the condition and
3413 -- the Then statements
3415 else
3416 -- We do not delete the condition if constant condition warnings
3417 -- are enabled, since otherwise we end up deleting the desired
3418 -- warning. Of course the backend will get rid of this True/False
3419 -- test anyway, so nothing is lost here.
3427 -- If there are no elsif statements, then we simply replace the
3428 -- entire if statement by the sequence of else statements.
3433 then
3436 else
3444 -- If there are elsif statements, the first of them becomes the
3445 -- if/then section of the rebuilt if statement This is the case
3446 -- where we loop to reprocess this copied condition.
3448 else
3454 -- Hed might have been captured as the condition determining
3455 -- the current value for an entity. Now it is detached from
3456 -- the tree, so a Current_Value pointer in the condition might
3457 -- need to be updated.
3468 -- Loop through elsif parts, dealing with constant conditions and
3469 -- possible condition actions that are present.
3475 -- Do not consider controlled objects found in an if statement
3476 -- which actually models an if expression because their early
3477 -- finalization will affect the result of the expression.
3485 -- If there are condition actions, then rewrite the if statement
3486 -- as indicated above. We also do the same rewrite for a True or
3487 -- False condition. The further processing of this constant
3488 -- condition is then done by the recursive call to expand the
3489 -- newly created if statement
3493 then
3494 New_If :=
3501 -- Elsif parts for new if come from remaining elsif's of parent
3525 -- Note this is not an implicit if statement, since it is part
3526 -- of an explicit if statement in the source (or of an implicit
3527 -- if statement that has already been tested). We set the flag
3528 -- after calling Analyze to avoid generating extra warnings
3529 -- specific to pure if statements, however (see
3530 -- Sem_Ch5.Analyze_If_Statement).
3535 -- No special processing for that elsif part, move to next
3537 else
3543 -- Some more optimizations applicable if we still have an IF statement
3549 -- Another optimization, special cases that can be simplified
3551 -- if expression then
3552 -- return true;
3553 -- else
3554 -- return false;
3555 -- end if;
3557 -- can be changed to:
3559 -- return expression;
3561 -- and
3563 -- if expression then
3564 -- return false;
3565 -- else
3566 -- return true;
3567 -- end if;
3569 -- can be changed to:
3571 -- return not (expression);
3573 -- Only do these optimizations if we are at least at -O1 level and
3574 -- do not do them if control flow optimizations are suppressed.
3578 then
3584 then
3585 declare
3589 begin
3591 and then
3593 then
3594 declare
3598 begin
3600 and then
3602 then
3605 then
3614 then
3617 Expression =>
3619 Right_Opnd =>
3632 --------------------------
3633 -- Expand_Iterator_Loop --
3634 --------------------------
3643 begin
3644 -- Processing for arrays
3653 else
3657 -- Processing for containers
3659 else
3660 Expand_Iterator_Loop_Over_Container
3665 -------------------------------------
3666 -- Expand_Iterator_Loop_Over_Array --
3667 -------------------------------------
3683 -- Start of processing for Expand_Iterator_Loop_Over_Array
3685 begin
3686 -- for Element of Array loop
3688 -- It requires an internally generated cursor to iterate over the array
3694 -- Generate:
3695 -- Element : Component_Type renames Array (Iterator);
3696 -- Iterator is the index value, or a list of index values
3697 -- in the case of a multidimensional array.
3699 Ind_Comp :=
3707 Subtype_Mark =>
3711 -- Mark the loop variable as needing debug info, so that expansion
3712 -- of the renaming will result in Materialize_Entity getting set via
3713 -- Debug_Renaming_Declaration. (This setting is needed here because
3714 -- the setting in Freeze_Entity comes after the expansion, which is
3715 -- too late. ???)
3719 -- Generate:
3721 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
3722 -- Element : Component_Type renames Array (Iterator);
3723 -- <original loop statements>
3724 -- end loop;
3726 -- If this is an iteration over a multidimensional array, the
3727 -- innermost loop is over the last dimension in Ada, and over
3728 -- the first dimension in Fortran.
3732 else
3736 Core_Loop :=
3738 Iteration_Scheme =>
3740 Loop_Parameter_Specification =>
3743 Discrete_Subtype_Definition =>
3753 -- Processing for multidimensional array. The body of each loop is
3754 -- a loop over a previous dimension, going in decreasing order in Ada
3755 -- and in increasing order in Fortran.
3761 else
3767 -- Generate the dimension loops starting from the innermost one
3769 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
3770 -- <core loop>
3771 -- end loop;
3773 Core_Loop :=
3775 Iteration_Scheme =>
3777 Loop_Parameter_Specification =>
3780 Discrete_Subtype_Definition =>
3790 -- Update the previously created object renaming declaration with
3791 -- the new iterator, by adding the index of the next loop to the
3792 -- indexed component, in the order that corresponds to the
3793 -- convention.
3798 else
3805 -- Inherit the loop identifier from the original loop. This ensures that
3806 -- the scope stack is consistent after the rewriting.
3816 -----------------------------------------
3817 -- Expand_Iterator_Loop_Over_Container --
3818 -----------------------------------------
3820 -- For a 'for ... in' loop, such as:
3822 -- for Cursor in Iterator_Function (...) loop
3823 -- ...
3824 -- end loop;
3826 -- we generate:
3828 -- Iter : Iterator_Type := Iterator_Function (...);
3829 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
3830 -- while Has_Element (Cursor) loop
3831 -- ...
3832 --
3833 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3834 -- end loop;
3836 -- For a 'for ... of' loop, such as:
3838 -- for X of Container loop
3839 -- ...
3840 -- end loop;
3842 -- the RM implies the generation of:
3844 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
3845 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
3846 -- while Has_Element (Cursor) loop
3847 -- declare
3848 -- X : Element_Type renames Element (Cursor).Element.all;
3849 -- -- or Constant_Element
3850 -- begin
3851 -- ...
3852 -- end;
3853 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3854 -- end loop;
3856 -- In the general case, we do what the RM says. However, the operations
3857 -- Element and Iter.Next are slow, which is bad inside a loop, because they
3858 -- involve dispatching via interfaces, secondary stack manipulation,
3859 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
3860 -- predefined containers, we use an equivalent but optimized expansion.
3862 -- In the optimized case, we make use of these:
3864 -- procedure Next (Position : in out Cursor); -- instead of Iter.Next
3866 -- function Pseudo_Reference
3867 -- (Container : aliased Vector'Class) return Reference_Control_Type;
3869 -- type Element_Access is access all Element_Type;
3871 -- function Get_Element_Access
3872 -- (Position : Cursor) return not null Element_Access;
3874 -- Next is declared in the visible part of the container packages.
3875 -- The other three are added in the private part. (We're not supposed to
3876 -- pollute the namespace for clients. The compiler has no trouble breaking
3877 -- privacy to call things in the private part of an instance.)
3879 -- Source:
3881 -- for X of My_Vector loop
3882 -- X.Count := X.Count + 1;
3883 -- ...
3884 -- end loop;
3886 -- The compiler will generate:
3888 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector);
3889 -- -- Reversible_Iterator is an interface. Iterate is the
3890 -- -- Default_Iterator aspect of Vector. This increments Lock,
3891 -- -- disallowing tampering with cursors. Unfortunately, it does not
3892 -- -- increment Busy. The result of Iterate is Limited_Controlled;
3893 -- -- finalization will decrement Lock. This is a build-in-place
3894 -- -- dispatching call to Iterate.
3896 -- Cur : Cursor := First (Iter); -- or Last
3897 -- -- Dispatching call via interface.
3899 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
3900 -- -- Pseudo_Reference increments Busy, to detect tampering with
3901 -- -- elements, as required by RM. Also redundantly increment
3902 -- -- Lock. Finalization of Control will decrement both Busy and
3903 -- -- Lock. Pseudo_Reference returns a record containing a pointer to
3904 -- -- My_Vector, used by Finalize.
3905 -- --
3906 -- -- Control is not used below, except to finalize it -- it's purely
3907 -- -- an RAII thing. This is needed because we are eliminating the
3908 -- -- call to Reference within the loop.
3910 -- while Has_Element (Cur) loop
3911 -- declare
3912 -- X : My_Element renames Get_Element_Access (Cur).all;
3913 -- -- Get_Element_Access returns a pointer to the element
3914 -- -- designated by Cur. No dispatching here, and no horsing
3915 -- -- around with access discriminants. This is instead of the
3916 -- -- existing
3917 -- --
3918 -- -- X : My_Element renames Reference (Cur).Element.all;
3919 -- --
3920 -- -- which creates a controlled object.
3921 -- begin
3922 -- -- Any attempt to tamper with My_Vector here in the loop
3923 -- -- will correctly raise Program_Error, because of the
3924 -- -- Control.
3925 --
3926 -- X.Count := X.Count + 1;
3927 -- ...
3928 --
3929 -- Next (Cur); -- or Prev
3930 -- -- This is instead of "Cur := Next (Iter, Cur);"
3931 -- end;
3932 -- -- No finalization here
3933 -- end loop;
3934 -- Finalize Iter and Control here, decrementing Lock twice and Busy
3935 -- once.
3937 -- This optimization makes "for ... of" loops over 30 times faster in cases
3938 -- measured.
3940 procedure Expand_Iterator_Loop_Over_Container
3946 is
3963 -- Only for optimized version of "for ... of"
3966 -- The package in which the iterator interface is instantiated. This is
3967 -- typically an instance within the container package.
3970 -- The package in which the container type is declared
3972 begin
3973 -- Determine the advancement and initialization steps for the cursor.
3974 -- Analysis of the expanded loop will verify that the container has a
3975 -- reverse iterator.
3980 else
3985 -- The type of the iterator is the return type of the Iterate function
3986 -- used. For the "of" form this is the default iterator for the type,
3987 -- otherwise it is the type of the explicit function used in the
3988 -- iterator specification. The most common case will be an Iterate
3989 -- function in the container package.
3991 -- The Iterator type is declared in an instance within the container
3992 -- package itself, for example:
3994 -- package Vector_Iterator_Interfaces is new
3995 -- Ada.Iterator_Interfaces (Cursor, Has_Element);
3997 -- If the container type is a derived type, the cursor type is found in
3998 -- the package of the ultimate ancestor type.
4002 else
4010 function Get_Default_Iterator
4012 -- Return the default iterator for a specific type. If the type is
4013 -- derived, we return the inherited or overridden one if
4014 -- appropriate.
4016 --------------------------
4017 -- Get_Default_Iterator --
4018 --------------------------
4020 function Get_Default_Iterator
4022 is
4028 begin
4031 -- A previous version of GNAT allowed indexing aspects to be
4032 -- redefined on derived container types, while the default
4033 -- iterator was inherited from the parent type. This
4034 -- nonstandard extension is preserved for use by the
4035 -- modeling project under debug flag -gnatd.X.
4040 then
4041 Container_Arg :=
4043 Subtype_Mark =>
4044 New_Occurrence_Of
4053 -- The default iterator must be a primitive operation of the
4054 -- type, at the same dispatch slot position. The DT position
4055 -- may not be established if type is not frozen yet.
4062 or else
4066 then
4073 -- If we didn't find it, then our parent type is not
4074 -- iterable, so we return the Default_Iterator aspect of
4075 -- this type.
4079 -- Otherwise not a derived type
4081 else
4086 -- Local variables
4094 -- Start of processing for Handle_Of
4096 begin
4098 Default_Iter :=
4100 else
4106 -- For a container element iterator, the iterator type is obtained
4107 -- from the corresponding aspect, whose return type is descended
4108 -- from the corresponding interface type in some instance of
4109 -- Ada.Iterator_Interfaces. The actuals of that instantiation
4110 -- are Cursor and Has_Element.
4114 -- The iterator type, which is a class-wide type, may itself be
4115 -- derived locally, so the desired instantiation is the scope of
4116 -- the root type of the iterator type.
4120 -- Find declarations needed for "for ... of" optimization
4129 then
4144 then
4148 Object_Definition =>
4150 Expression =>
4152 Name =>
4154 Parameter_Associations =>
4158 -- Rewrite domain of iteration as a call to the default iterator
4159 -- for the container type. The formal may be an access parameter
4160 -- in which case we must build a reference to the container.
4162 declare
4164 begin
4166 Arg :=
4170 else
4176 Name =>
4183 -- Find cursor type in proper iterator package, which is an
4184 -- instantiation of Iterator_Interfaces.
4197 Decl :=
4200 Subtype_Mark =>
4202 Name =>
4204 Prefix =>
4206 Name =>
4208 Parameter_Associations =>
4211 else
4212 Decl :=
4215 Subtype_Mark =>
4217 Name =>
4220 Expressions =>
4224 -- The defining identifier in the iterator is user-visible and
4225 -- must be visible in the debugger.
4229 -- If the container does not have a variable indexing aspect,
4230 -- the element is a constant in the loop. The container itself
4231 -- may be constant, in which case the element is a constant as
4232 -- well. The container has been rewritten as a call to Iterate,
4233 -- so examine original node.
4238 then
4245 -- X in Iterate (S) : type of iterator is type of explicitly given
4246 -- Iterate function, and the loop variable is the cursor. It will be
4247 -- assigned in the loop and must be a variable.
4249 else
4252 -- The iterator type, which is a class-wide type, may itself be
4253 -- derived locally, so the desired instantiation is the scope of
4254 -- the root type of the iterator type, as in the "of" case.
4262 -- For both iterator forms, add a call to the step operation to advance
4263 -- the cursor. Generate:
4265 -- Cursor := Iterator.Next (Cursor);
4267 -- or else
4269 -- Cursor := Next (Cursor);
4272 declare
4276 begin
4277 Step_Call :=
4279 Name =>
4287 else
4288 declare
4291 begin
4292 Rhs :=
4294 Name =>
4309 -- Generate:
4310 -- while Has_Element (Cursor) loop
4311 -- <Stats>
4312 -- end loop;
4314 -- Has_Element is the second actual in the iterator package
4316 New_Loop :=
4318 Iteration_Scheme =>
4320 Condition =>
4322 Name =>
4323 New_Occurrence_Of
4331 -- If present, preserve identifier of loop, which can be used in an exit
4332 -- statement in the body.
4338 -- Create the declarations for Iterator and cursor and insert them
4339 -- before the source loop. Given that the domain of iteration is already
4340 -- an entity, the iterator is just a renaming of that entity. Possible
4341 -- optimization ???
4349 -- Create declaration for cursor
4351 declare
4355 Object_Definition =>
4357 Expression =>
4359 Prefix =>
4361 Selector_Name =>
4364 begin
4365 -- The cursor is only modified in expanded code, so it appears
4366 -- as unassigned to the warning machinery. We must suppress this
4367 -- spurious warning explicitly. The cursor's kind is that of the
4368 -- original loop parameter (it is a constant if the domain of
4369 -- iteration is constant).
4378 -- If the range of iteration is given by a function call that returns
4379 -- a container, the finalization actions have been saved in the
4380 -- Condition_Actions of the iterator. Insert them now at the head of
4381 -- the loop.
4391 -----------------------------
4392 -- Expand_N_Loop_Statement --
4393 -----------------------------
4395 -- 1. Remove null loop entirely
4396 -- 2. Deal with while condition for C/Fortran boolean
4397 -- 3. Deal with loops with a non-standard enumeration type range
4398 -- 4. Deal with while loops where Condition_Actions is set
4399 -- 5. Deal with loops over predicated subtypes
4400 -- 6. Deal with loops with iterators over arrays and containers
4401 -- 7. Insert polling call if required
4408 begin
4409 -- Delete null loop
4416 -- Deal with condition for C/Fortran Boolean
4422 -- Generate polling call
4428 -- Nothing more to do for plain loop with no iteration scheme
4433 -- Case of for loop (Loop_Parameter_Specification present)
4435 -- Note: we do not have to worry about validity checking of the for loop
4436 -- range bounds here, since they were frozen with constant declarations
4437 -- and it is during that process that the validity checking is done.
4440 declare
4450 begin
4451 -- Deal with loop over predicates
4455 then
4458 -- Handle the case where we have a for loop with the range type
4459 -- being an enumeration type with non-standard representation.
4460 -- In this case we expand:
4462 -- for x in [reverse] a .. b loop
4463 -- ...
4464 -- end loop;
4466 -- to
4468 -- for xP in [reverse] integer
4469 -- range etype'Pos (a) .. etype'Pos (b)
4470 -- loop
4471 -- declare
4472 -- x : constant etype := Pos_To_Rep (xP);
4473 -- begin
4474 -- ...
4475 -- end;
4476 -- end loop;
4480 then
4481 New_Id :=
4485 -- If the type has a contiguous representation, successive
4486 -- values can be generated as offsets from the first literal.
4489 Expr :=
4492 Left_Opnd =>
4496 else
4497 -- Use the constructed array Enum_Pos_To_Rep
4499 Expr :=
4501 Prefix =>
4503 Expressions =>
4507 -- Build declaration for loop identifier
4509 Decls :=
4510 New_List (
4521 Iteration_Scheme =>
4523 Loop_Parameter_Specification =>
4528 Discrete_Subtype_Definition =>
4531 Subtype_Mark =>
4534 Constraint =>
4536 Range_Expression =>
4539 Low_Bound =>
4541 Prefix =>
4547 Relocate_Node
4550 High_Bound =>
4552 Prefix =>
4558 Relocate_Node
4559 (Type_High_Bound
4565 Handled_Statement_Sequence =>
4571 -- The loop parameter's entity must be removed from the loop
4572 -- scope's entity list and rendered invisible, since it will
4573 -- now be located in the new block scope. Any other entities
4574 -- already associated with the loop scope, such as the loop
4575 -- parameter's subtype, will remain there.
4577 -- In an element loop, the loop will contain a declaration for
4578 -- a cursor variable; otherwise the loop id is the first entity
4579 -- in the scope constructed for the loop.
4595 -- Nothing to do with other cases of for loops
4597 else
4602 -- Second case, if we have a while loop with Condition_Actions set, then
4603 -- we change it into a plain loop:
4605 -- while C loop
4606 -- ...
4607 -- end loop;
4609 -- changed to:
4611 -- loop
4612 -- <<condition actions>>
4613 -- exit when not C;
4614 -- ...
4615 -- end loop
4620 then
4621 declare
4624 begin
4625 ES :=
4627 Condition =>
4634 -- This is not an implicit loop, since it is generated in response
4635 -- to the loop statement being processed. If this is itself
4636 -- implicit, the restriction has already been checked. If not,
4637 -- it is an explicit loop.
4648 -- Here to deal with iterator case
4652 then
4655 -- An iterator loop may generate renaming declarations for elements
4656 -- that require debug information. This is the case in particular
4657 -- with element iterators, where debug information must be generated
4658 -- for the temporary that holds the element value. These temporaries
4659 -- are created within a transient block whose local declarations are
4660 -- transferred to the loop, which now has nontrivial local objects.
4664 then
4669 -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
4670 -- is transformed into a conditional block where the original loop is
4671 -- the sole statement. Inspect the statements of the nested loop for
4672 -- controlled objects.
4683 ----------------------------
4684 -- Expand_Predicated_Loop --
4685 ----------------------------
4687 -- Note: the expander can handle generation of loops over predicated
4688 -- subtypes for both the dynamic and static cases. Depending on what
4689 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
4690 -- mode, the semantic analyzer may disallow one or both forms.
4701 begin
4702 -- Case of iteration over non-static predicate, should not be possible
4703 -- since this is not allowed by the semantics and should have been
4704 -- caught during analysis of the loop statement.
4709 -- If the predicate list is empty, that corresponds to a predicate of
4710 -- False, in which case the loop won't run at all, and we rewrite the
4711 -- entire loop as a null statement.
4717 -- For expansion over a static predicate we generate the following
4719 -- declare
4720 -- J : Ltype := min-val;
4721 -- begin
4722 -- loop
4723 -- body
4724 -- case J is
4725 -- when endpoint => J := startpoint;
4726 -- when endpoint => J := startpoint;
4727 -- ...
4728 -- when max-val => exit;
4729 -- when others => J := Lval'Succ (J);
4730 -- end case;
4731 -- end loop;
4732 -- end;
4734 -- with min-val replaced by max-val and Succ replaced by Pred if the
4735 -- loop parameter specification carries a Reverse indicator.
4737 -- To make this a little clearer, let's take a specific example:
4739 -- type Int is range 1 .. 10;
4740 -- subtype StaticP is Int with
4741 -- predicate => StaticP in 3 | 10 | 5 .. 7;
4742 -- ...
4743 -- for L in StaticP loop
4744 -- Put_Line ("static:" & J'Img);
4745 -- end loop;
4747 -- In this case, the loop is transformed into
4749 -- begin
4750 -- J : L := 3;
4751 -- loop
4752 -- body
4753 -- case J is
4754 -- when 3 => J := 5;
4755 -- when 7 => J := 10;
4756 -- when 10 => exit;
4757 -- when others => J := L'Succ (J);
4758 -- end case;
4759 -- end loop;
4760 -- end;
4762 -- In addition, if the loop specification is given by a subtype
4763 -- indication that constrains a predicated type, the bounds of
4764 -- iteration are given by those of the subtype indication.
4766 else
4774 -- If the domain is an itype, note the bounds of its range.
4780 -- Given static expression or static range, returns an identifier
4781 -- whose value is the low bound of the expression value or range.
4784 -- Given static expression or static range, returns an identifier
4785 -- whose value is the high bound of the expression value or range.
4787 ------------
4788 -- Hi_Val --
4789 ------------
4792 begin
4795 else
4801 ------------
4802 -- Lo_Val --
4803 ------------
4806 begin
4809 else
4815 -- Start of processing for Static_Predicate
4817 begin
4818 -- Convert loop identifier to normal variable and reanalyze it so
4819 -- that this conversion works. We have to use the same defining
4820 -- identifier, since there may be references in the loop body.
4825 -- In most loops the loop variable is assigned in various
4826 -- alternatives in the body. However, in the rare case when
4827 -- the range specifies a single element, the loop variable
4828 -- may trigger a spurious warning that is could be constant.
4829 -- This warning might as well be suppressed.
4838 -- Loop to create branches of case statement
4844 -- Initial value is largest value in predicate.
4847 D :=
4853 else
4854 D :=
4865 else
4866 S :=
4883 and then
4885 then
4892 else
4893 -- Initial value is smallest value in predicate
4896 D :=
4901 else
4902 D :=
4913 else
4914 S :=
4931 and then
4933 then
4941 -- Add others choice
4943 declare
4946 begin
4949 else
4953 S :=
4956 Expression =>
4970 -- Construct case statement and append to body statements
4972 Cstm :=
4978 -- Rewrite the loop
4985 Handled_Statement_Sequence =>
4997 ------------------------------
4998 -- Make_Tag_Ctrl_Assignment --
4999 ------------------------------
5012 and then not Comp_Asn
5019 begin
5020 -- Finalize the target of the assignment when controlled
5022 -- We have two exceptions here:
5024 -- 1. If we are in an init proc since it is an initialization more
5025 -- than an assignment.
5027 -- 2. If the left-hand side is a temporary that was not initialized
5028 -- (or the parent part of a temporary since it is the case in
5029 -- extension aggregates). Such a temporary does not come from
5030 -- source. We must examine the original node for the prefix, because
5031 -- it may be a component of an entry formal, in which case it has
5032 -- been rewritten and does not appear to come from source either.
5034 -- Case of init proc
5039 -- The left-hand side is an uninitialized temporary object
5044 N_Object_Declaration
5046 then
5049 else
5050 Fin_Call :=
5051 Make_Final_Call
5060 -- Save the Tag in a local variable Tag_Id
5069 Expression =>
5072 Selector_Name =>
5075 -- Otherwise Tag_Id is not used
5077 else
5081 -- If the tagged type has a full rep clause, expand the assignment into
5082 -- component-wise assignments. Mark the node as unanalyzed in order to
5083 -- generate the proper code and propagate this scenario by setting a
5084 -- flag to avoid infinite recursion.
5093 -- Restore the tag
5098 Name =>
5101 Selector_Name =>
5106 -- Adjust the target after the assignment when controlled (not in the
5107 -- init proc since it is an initialization more than an assignment).
5110 Adj_Call :=
5111 Make_Adjust_Call
5122 exception
5124 -- Could use comment here ???