| blob | 7a373ab883bc6b46d451a0bf752a494189b1492b |
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 =>
241 -- If the contruct has a specified loop name, preserve it in the new
242 -- loop, for possible use in exit statements.
246 then
251 ------------------------------
252 -- Change_Of_Representation --
253 ------------------------------
257 begin
258 return
260 and then
264 ------------------------------
265 -- Convert_To_Iterable_Type --
266 ------------------------------
268 function Convert_To_Iterable_Type
271 is
276 begin
280 Result :=
289 -------------------------
290 -- Expand_Assign_Array --
291 -------------------------
293 -- There are two issues here. First, do we let Gigi do a block move, or
294 -- do we expand out into a loop? Second, we need to set the two flags
295 -- Forwards_OK and Backwards_OK which show whether the block move (or
296 -- corresponding loops) can be legitimately done in a forwards (low to
297 -- high) or backwards (high to low) manner.
323 -- This switch is set to True if the array move must be done using
324 -- an explicit front end generated loop.
327 -- If the argument is an access to an array, and the assignment is
328 -- converted into a procedure call, apply explicit dereference.
331 -- Test if Exp is a reference to an array whose declaration has
332 -- an address clause, or it is a slice of such an array.
335 -- Test if Exp is a reference to an array which is either a formal
336 -- parameter or a slice of a formal parameter. These are the cases
337 -- where hidden aliasing can occur.
340 -- Determine if Exp is a reference to an array variable which is other
341 -- than an object defined in the current scope, or a component or a
342 -- slice of such an object. Such objects can be aliased to parameters
343 -- (unlike local array references).
345 -----------------------
346 -- Apply_Dereference --
347 -----------------------
351 begin
359 ------------------------
360 -- Has_Address_Clause --
361 ------------------------
364 begin
365 return
368 or else
372 ---------------------
373 -- Is_Formal_Array --
374 ---------------------
377 begin
378 return
380 or else
384 ------------------------
385 -- Is_Non_Local_Array --
386 ------------------------
389 begin
391 when N_Indexed_Component
392 | N_Selected_Component
393 | N_Slice
394 =>
398 return
404 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
412 -- Start of processing for Expand_Assign_Array
414 begin
415 -- Deal with length check. Note that the length check is done with
416 -- respect to the right-hand side as given, not a possible underlying
417 -- renamed object, since this would generate incorrect extra checks.
421 -- We start by assuming that the move can be done in either direction,
422 -- i.e. that the two sides are completely disjoint.
427 -- Normally it is only the slice case that can lead to overlap, and
428 -- explicit checks for slices are made below. But there is one case
429 -- where the slice can be implicit and invisible to us: when we have a
430 -- one dimensional array, and either both operands are parameters, or
431 -- one is a parameter (which can be a slice passed by reference) and the
432 -- other is a non-local variable. In this case the parameter could be a
433 -- slice that overlaps with the other operand.
435 -- However, if the array subtype is a constrained first subtype in the
436 -- parameter case, then we don't have to worry about overlap, since
437 -- slice assignments aren't possible (other than for a slice denoting
438 -- the whole array).
440 -- Note: No overlap is possible if there is a change of representation,
441 -- so we can exclude this case.
444 and then not Crep
445 and then
447 or else
449 or else
451 and then
454 then
458 -- Note: the bit-packed case is not worrisome here, since if we have
459 -- a slice passed as a parameter, it is always aligned on a byte
460 -- boundary, and if there are no explicit slices, the assignment
461 -- can be performed directly.
464 -- If either operand has an address clause clear Backwards_OK and
465 -- Forwards_OK, since we cannot tell if the operands overlap. We
466 -- exclude this treatment when Rhs is an aggregate, since we know
467 -- that overlap can't occur.
471 then
476 -- We certainly must use a loop for change of representation and also
477 -- we use the operand of the conversion on the right-hand side as the
478 -- effective right-hand side (the component types must match in this
479 -- situation).
486 -- We require a loop if the left side is possibly bit unaligned
489 or else
491 then
494 -- Arrays with controlled components are expanded into a loop to force
495 -- calls to Adjust at the component level.
500 -- If object is atomic/VFA, we cannot tolerate a loop
503 or else
505 then
508 -- Loop is required if we have atomic components since we have to
509 -- be sure to do any accesses on an element by element basis.
515 then
518 -- Case where no slice is involved
522 -- The following code deals with the case of unconstrained bit packed
523 -- arrays. The problem is that the template for such arrays contains
524 -- the bounds of the actual source level array, but the copy of an
525 -- entire array requires the bounds of the underlying array. It would
526 -- be nice if the back end could take care of this, but right now it
527 -- does not know how, so if we have such a type, then we expand out
528 -- into a loop, which is inefficient but works correctly. If we don't
529 -- do this, we get the wrong length computed for the array to be
530 -- moved. The two cases we need to worry about are:
532 -- Explicit dereference of an unconstrained packed array type as in
533 -- the following example:
535 -- procedure C52 is
536 -- type BITS is array(INTEGER range <>) of BOOLEAN;
537 -- pragma PACK(BITS);
538 -- type A is access BITS;
539 -- P1,P2 : A;
540 -- begin
541 -- P1 := new BITS (1 .. 65_535);
542 -- P2 := new BITS (1 .. 65_535);
543 -- P2.ALL := P1.ALL;
544 -- end C52;
546 -- A formal parameter reference with an unconstrained bit array type
547 -- is the other case we need to worry about (here we assume the same
548 -- BITS type declared above):
550 -- procedure Write_All (File : out BITS; Contents : BITS);
551 -- begin
552 -- File.Storage := Contents;
553 -- end Write_All;
555 -- We expand to a loop in either of these two cases
557 -- Question for future thought. Another potentially more efficient
558 -- approach would be to create the actual subtype, and then do an
559 -- unchecked conversion to this actual subtype ???
564 -- Function to perform required test for the first case, above
565 -- (dereference of an unconstrained bit packed array).
567 -----------------------
568 -- Is_UBPA_Reference --
569 -----------------------
576 begin
580 then
589 else
591 return
596 else
601 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
603 begin
605 or else
607 then
610 -- Here if we do not have the case of a reference to a bit packed
611 -- unconstrained array case. In this case gigi can most certainly
612 -- handle the assignment if a forwards move is allowed.
614 -- (could it handle the backwards case also???)
621 -- The back end can always handle the assignment if the right side is a
622 -- string literal (note that overlap is definitely impossible in this
623 -- case). If the type is packed, a string literal is always converted
624 -- into an aggregate, except in the case of a null slice, for which no
625 -- aggregate can be written. In that case, rewrite the assignment as a
626 -- null statement, a length check has already been emitted to verify
627 -- that the range of the left-hand side is empty.
629 -- Note that this code is not executed if we have an assignment of a
630 -- string literal to a non-bit aligned component of a record, a case
631 -- which cannot be handled by the backend.
636 then
643 -- If either operand is bit packed, then we need a loop, since we can't
644 -- be sure that the slice is byte aligned. Similarly, if either operand
645 -- is a possibly unaligned slice, then we need a loop (since the back
646 -- end cannot handle unaligned slices).
652 then
655 -- If we are not bit-packed, and we have only one slice, then no overlap
656 -- is possible except in the parameter case, so we can let the back end
657 -- handle things.
665 -- If the right-hand side is a string literal, introduce a temporary for
666 -- it, for use in the generated loop that will follow.
669 declare
673 begin
674 Decl :=
686 -- Come here to complete the analysis
688 -- Loop_Required: Set to True if we know that a loop is required
689 -- regardless of overlap considerations.
691 -- Forwards_OK: Set to False if we already know that a forwards
692 -- move is not safe, else set to True.
694 -- Backwards_OK: Set to False if we already know that a backwards
695 -- move is not safe, else set to True
697 -- Our task at this stage is to complete the overlap analysis, which can
698 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
699 -- then generating the final code, either by deciding that it is OK
700 -- after all to let Gigi handle it, or by generating appropriate code
701 -- in the front end.
703 declare
721 begin
722 -- Get the expressions for the arrays. If we are dealing with a
723 -- private type, then convert to the underlying type. We can do
724 -- direct assignments to an array that is a private type, but we
725 -- cannot assign to elements of the array without this extra
726 -- unchecked conversion.
728 -- Note: We propagate Parent to the conversion nodes to generate
729 -- a well-formed subtree.
733 else
737 declare
739 begin
740 Larray :=
741 Unchecked_Convert_To
750 else
754 declare
756 begin
757 Rarray :=
758 Unchecked_Convert_To
765 -- If both sides are slices, we must figure out whether it is safe
766 -- to do the move in one direction or the other. It is always safe
767 -- if there is a change of representation since obviously two arrays
768 -- with different representations cannot possibly overlap.
774 -- If both left- and right-hand arrays are entity names, and refer
775 -- to different entities, then we know that the move is safe (the
776 -- two storage areas are completely disjoint).
781 then
784 -- Otherwise, we assume the worst, which is that the two arrays
785 -- are the same array. There is no need to check if we know that
786 -- is the case, because if we don't know it, we still have to
787 -- assume it.
789 -- Generally if the same array is involved, then we have an
790 -- overlapping case. We will have to really assume the worst (i.e.
791 -- set neither of the OK flags) unless we can determine the lower
792 -- or upper bounds at compile time and compare them.
794 else
795 Cresult :=
796 Compile_Time_Compare
800 Cresult :=
801 Compile_Time_Compare
819 -- If after that analysis Loop_Required is False, meaning that we
820 -- have not discovered some non-overlap reason for requiring a loop,
821 -- then the outcome depends on the capabilities of the back end.
824 -- Assume the back end can deal with all cases of overlap by
825 -- falling back to memmove if it cannot use a more efficient
826 -- approach.
831 -- At this stage we have to generate an explicit loop, and we have
832 -- the following cases:
834 -- Forwards_OK = True
836 -- Rnn : right_index := right_index'First;
837 -- for Lnn in left-index loop
838 -- left (Lnn) := right (Rnn);
839 -- Rnn := right_index'Succ (Rnn);
840 -- end loop;
842 -- Note: the above code MUST be analyzed with checks off, because
843 -- otherwise the Succ could overflow. But in any case this is more
844 -- efficient.
846 -- Forwards_OK = False, Backwards_OK = True
848 -- Rnn : right_index := right_index'Last;
849 -- for Lnn in reverse left-index loop
850 -- left (Lnn) := right (Rnn);
851 -- Rnn := right_index'Pred (Rnn);
852 -- end loop;
854 -- Note: the above code MUST be analyzed with checks off, because
855 -- otherwise the Pred could overflow. But in any case this is more
856 -- efficient.
858 -- Forwards_OK = Backwards_OK = False
860 -- This only happens if we have the same array on each side. It is
861 -- possible to create situations using overlays that violate this,
862 -- but we simply do not promise to get this "right" in this case.
864 -- There are two possible subcases. If the No_Implicit_Conditionals
865 -- restriction is set, then we generate the following code:
867 -- declare
868 -- T : constant <operand-type> := rhs;
869 -- begin
870 -- lhs := T;
871 -- end;
873 -- If implicit conditionals are permitted, then we generate:
875 -- if Left_Lo <= Right_Lo then
876 -- <code for Forwards_OK = True above>
877 -- else
878 -- <code for Backwards_OK = True above>
879 -- end if;
881 -- In order to detect possible aliasing, we examine the renamed
882 -- expression when the source or target is a renaming. However,
883 -- the renaming may be intended to capture an address that may be
884 -- affected by subsequent code, and therefore we must recover
885 -- the actual entity for the expansion that follows, not the
886 -- object it renames. In particular, if source or target designate
887 -- a portion of a dynamically allocated object, the pointer to it
888 -- may be reassigned but the renaming preserves the proper location.
891 and then
894 then
899 and then
902 then
906 -- Cases where either Forwards_OK or Backwards_OK is true
913 then
914 declare
919 begin
931 New_Occurrence_Of (
940 else
942 Expand_Assign_Array_Loop
947 -- Case of both are false with No_Implicit_Conditionals
950 declare
954 begin
961 Object_Definition =>
965 Handled_Statement_Sequence =>
973 -- Case of both are false with implicit conditionals allowed
975 else
976 -- Before we generate this code, we must ensure that the left and
977 -- right side array types are defined. They may be itypes, and we
978 -- cannot let them be defined inside the if, since the first use
979 -- in the then may not be executed.
984 -- We normally compare addresses to find out which way round to
985 -- do the loop, since this is reliable, and handles the cases of
986 -- parameters, conversions etc. But we can't do that in the bit
987 -- packed case, because addresses don't work there.
990 Condition :=
992 Left_Opnd =>
995 Prefix =>
997 Prefix =>
1001 Prefix =>
1002 New_Occurrence_Of
1007 Right_Opnd =>
1010 Prefix =>
1012 Prefix =>
1016 Prefix =>
1017 New_Occurrence_Of
1022 -- For the bit packed and VM cases we use the bounds. That's OK,
1023 -- because we don't have to worry about parameters, since they
1024 -- cannot cause overlap. Perhaps we should worry about weird slice
1025 -- conversions ???
1027 else
1028 -- Copy the bounds
1033 -- If the types do not match we add an implicit conversion
1034 -- here to ensure proper match
1037 Cright_Lo :=
1041 -- Reset the Analyzed flag, because the bounds of the index
1042 -- type itself may be universal, and must must be reanalyzed
1043 -- to acquire the proper type for the back end.
1048 Condition :=
1058 then
1060 -- Call TSS procedure for array assignment, passing the
1061 -- explicit bounds of right- and left-hand sides.
1063 declare
1068 begin
1089 else
1095 Expand_Assign_Array_Loop
1100 Expand_Assign_Array_Loop
1109 exception
1114 ------------------------------
1115 -- Expand_Assign_Array_Loop --
1116 ------------------------------
1118 -- The following is an example of the loop generated for the case of a
1119 -- two-dimensional array:
1121 -- declare
1122 -- R2b : Tm1X1 := 1;
1123 -- begin
1124 -- for L1b in 1 .. 100 loop
1125 -- declare
1126 -- R4b : Tm1X2 := 1;
1127 -- begin
1128 -- for L3b in 1 .. 100 loop
1129 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
1130 -- R4b := Tm1X2'succ(R4b);
1131 -- end loop;
1132 -- end;
1133 -- R2b := Tm1X1'succ(R2b);
1134 -- end loop;
1135 -- end;
1137 -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand
1138 -- side. The declarations of R2b and R4b are inserted before the original
1139 -- assignment statement.
1141 function Expand_Assign_Array_Loop
1149 is
1154 -- Entities used as subscripts on left and right sides
1158 -- Left and right index types
1166 -- The increment step for the index of the right-hand side is written
1167 -- as an attribute reference (Succ or Pred). This function returns
1168 -- the corresponding node, which is placed at the end of the loop body.
1170 ----------------
1171 -- Build_Step --
1172 ----------------
1178 begin
1181 else
1185 Step :=
1188 Expression =>
1190 Prefix =>
1196 -- Note that on the last iteration of the loop, the index is increased
1197 -- (or decreased) past the corresponding bound. This is consistent with
1198 -- the C semantics of the back-end, where such an off-by-one value on a
1199 -- dead index variable is OK. However, in CodePeer mode this leads to
1200 -- spurious warnings, and thus we place a guard around the attribute
1201 -- reference. For obvious reasons we only do this for CodePeer.
1204 Step :=
1206 Condition =>
1209 Right_Opnd =>
1219 -- Start of processing for Expand_Assign_Array_Loop
1221 begin
1225 else
1230 -- Setup index types and subscript entities
1232 declare
1236 begin
1252 -- Now construct the assignment statement
1254 declare
1258 begin
1264 Assign :=
1266 Name =>
1270 Expression =>
1275 -- We set assignment OK, since there are some cases, e.g. in object
1276 -- declarations, where we are actually assigning into a constant.
1277 -- If there really is an illegality, it was caught long before now,
1278 -- and was flagged when the original assignment was analyzed.
1282 -- Propagate the No_Ctrl_Actions flag to individual assignments
1287 -- Now construct the loop from the inside out, with the last subscript
1288 -- varying most rapidly. Note that Assign is first the raw assignment
1289 -- statement, and then subsequently the loop that wraps it up.
1292 Assign :=
1297 Object_Definition =>
1299 Expression =>
1304 Handled_Statement_Sequence =>
1308 Iteration_Scheme =>
1310 Loop_Parameter_Specification =>
1314 Discrete_Subtype_Definition =>
1323 --------------------------
1324 -- Expand_Assign_Record --
1325 --------------------------
1332 begin
1333 -- If change of representation, then extract the real right-hand side
1334 -- from the type conversion, and proceed with component-wise assignment,
1335 -- since the two types are not the same as far as the back end is
1336 -- concerned.
1341 -- If this may be a case of a large bit aligned component, then proceed
1342 -- with component-wise assignment, to avoid possible clobbering of other
1343 -- components sharing bits in the first or last byte of the component to
1344 -- be assigned.
1347 or
1349 then
1352 -- If we have a tagged type that has a complete record representation
1353 -- clause, we must do we must do component-wise assignments, since child
1354 -- types may have used gaps for their components, and we might be
1355 -- dealing with a view conversion.
1360 -- If neither condition met, then nothing special to do, the back end
1361 -- can handle assignment of the entire component as a single entity.
1363 else
1367 -- At this stage we know that we must do a component wise assignment
1369 declare
1376 function Find_Component
1379 -- Find the component with the given name in the underlying record
1380 -- declaration for Typ. We need to use the actual entity because the
1381 -- type may be private and resolution by identifier alone would fail.
1383 function Make_Component_List_Assign
1386 -- Returns a sequence of statements to assign the components that
1387 -- are referenced in the given component list. The flag U_U is
1388 -- used to force the usage of the inferred value of the variant
1389 -- part expression as the switch for the generated case statement.
1391 function Make_Field_Assign
1394 -- Given C, the entity for a discriminant or component, build an
1395 -- assignment for the corresponding field values. The flag U_U
1396 -- signals the presence of an Unchecked_Union and forces the usage
1397 -- of the inferred discriminant value of C as the right-hand side
1398 -- of the assignment.
1401 -- Given CI, a component items list, construct series of statements
1402 -- for fieldwise assignment of the corresponding components.
1404 --------------------
1405 -- Find_Component --
1406 --------------------
1408 function Find_Component
1411 is
1415 begin
1428 --------------------------------
1429 -- Make_Component_List_Assign --
1430 --------------------------------
1432 function Make_Component_List_Assign
1435 is
1446 begin
1463 Statements =>
1468 -- If we have an Unchecked_Union, use the value of the inferred
1469 -- discriminant of the variant part expression as the switch
1470 -- for the case statement. The case statement may later be
1471 -- folded.
1474 Expr :=
1479 else
1480 Expr :=
1483 Selector_Name =>
1496 -----------------------
1497 -- Make_Field_Assign --
1498 -----------------------
1500 function Make_Field_Assign
1503 is
1508 begin
1509 -- The discriminant entity to be used in the retrieval below must
1510 -- be one in the corresponding type, given that the assignment may
1511 -- be between derived and parent types.
1515 else
1519 -- In the case of an Unchecked_Union, use the discriminant
1520 -- constraint value as on the right-hand side of the assignment.
1523 Expr :=
1527 else
1528 Expr :=
1534 -- Generate the assignment statement. When the left-hand side
1535 -- is an object with an address clause present, force generated
1536 -- temporaries to be renamings so as to correctly assign to any
1537 -- overlaid objects.
1539 A :=
1541 Name =>
1543 Prefix =>
1544 Duplicate_Subexpr
1547 Renaming_Req =>
1550 Selector_Name =>
1554 -- Set Assignment_OK, so discriminants can be assigned
1561 then
1568 ------------------------
1569 -- Make_Field_Assigns --
1570 ------------------------
1576 begin
1582 -- Look for components, but exclude _tag field assignment if
1583 -- the special Componentwise_Assignment flag is set.
1588 then
1589 Append_To
1599 -- Start of processing for Expand_Assign_Record
1601 begin
1602 -- Note that we use the base types for this processing. This results
1603 -- in some extra work in the constrained case, but the change of
1604 -- representation case is so unusual that it is not worth the effort.
1606 -- First copy the discriminants. This is done unconditionally. It
1607 -- is required in the unconstrained left side case, and also in the
1608 -- case where this assignment was constructed during the expansion
1609 -- of a type conversion (since initialization of discriminants is
1610 -- suppressed in this case). It is unnecessary but harmless in
1611 -- other cases.
1613 -- Special case: no copy if the target has no discriminants
1617 then
1624 -- If we are expanding the initialization of a derived record
1625 -- that constrains or renames discriminants of the parent, we
1626 -- must use the corresponding discriminant in the parent.
1628 declare
1631 begin
1632 if Inside_Init_Proc
1634 then
1636 else
1642 -- Within an initialization procedure this is the
1643 -- assignment to an unchecked union component, in which
1644 -- case there is no discriminant to initialize.
1649 else
1650 -- The assignment is part of a conversion from a
1651 -- derived unchecked union type with an inferable
1652 -- discriminant, to a parent type.
1657 else
1665 -- If the derived type has a stored constraint, assign the value
1666 -- of the corresponding discriminants explicitly, skipping those
1667 -- that are renamed discriminants. We cannot just retrieve them
1668 -- from the Rhs by selected component because they are invisible
1669 -- in the type of the right-hand side.
1672 declare
1676 begin
1683 and then
1686 E_Discriminant)
1687 then
1688 Assign :=
1690 Name =>
1693 Selector_Name =>
1694 New_Occurrence_Of
1709 -- We know the underlying type is a record, but its current view
1710 -- may be private. We must retrieve the usable record declaration.
1713 N_Private_Extension_Declaration)
1715 then
1717 else
1727 then
1731 else
1732 Insert_Actions
1741 -------------------------------------
1742 -- Expand_Assign_With_Target_Names --
1743 -------------------------------------
1752 -- The entity of the left-hand side
1755 -- Replace occurrences of the target name by the proper entity: either
1756 -- the entity of the LHS in simple cases, or the formal of the
1757 -- constructed procedure otherwise.
1759 --------------------
1760 -- Replace_Target --
1761 --------------------
1764 begin
1768 -- The expression will be reanalyzed when the enclosing assignment
1769 -- is reanalyzed, so reset the entity, which may be a temporary
1770 -- created during analysis, e.g. a loop variable for an iterated
1771 -- component association. However, if entity is callable then
1772 -- resolution has established its proper identity (including in
1773 -- rewritten prefixed calls) so we must preserve it.
1778 then
1789 -- Local variables
1794 -- Start of processing for Expand_Assign_With_Target_Names
1796 begin
1799 -- The left-hand side is a direct name
1803 then
1807 -- Generate:
1808 -- LHS := ... LHS ...;
1815 -- The left-hand side is not a direct name, but is side-effect free.
1816 -- Capture its value in a temporary to avoid multiple evaluations.
1822 -- Generate:
1823 -- T : LHS_Typ := LHS;
1831 -- Generate:
1832 -- LHS := ... T ...;
1839 -- Otherwise wrap the whole assignment statement in a procedure with an
1840 -- IN OUT parameter. The original assignment then becomes a call to the
1841 -- procedure with the left-hand side as an actual.
1843 else
1847 -- Generate:
1848 -- procedure P (T : in out LHS_Typ) is
1849 -- begin
1850 -- T := ... T ...;
1851 -- end P;
1857 Specification =>
1865 Parameter_Type =>
1870 Handled_Statement_Sequence =>
1877 -- Generate:
1878 -- P (LHS);
1886 -- Analyze rewritten node, either as assignment or procedure call
1891 -----------------------------------
1892 -- Expand_N_Assignment_Statement --
1893 -----------------------------------
1895 -- This procedure implements various cases where an assignment statement
1896 -- cannot just be passed on to the back end in untransformed state.
1906 begin
1907 -- Special case to check right away, if the Componentwise_Assignment
1908 -- flag is set, this is a reanalysis from the expansion of the primitive
1909 -- assignment procedure for a tagged type, and all we need to do is to
1910 -- expand to assignment of components, because otherwise, we would get
1911 -- infinite recursion (since this looks like a tagged assignment which
1912 -- would normally try to *call* the primitive assignment procedure).
1919 -- Defend against invalid subscripts on left side if we are in standard
1920 -- validity checking mode. No need to do this if we are checking all
1921 -- subscripts.
1923 -- Note that we do this right away, because there are some early return
1924 -- paths in this procedure, and this is required on all paths.
1926 if Validity_Checks_On
1927 and then Validity_Check_Default
1928 and then not Validity_Check_Subscripts
1929 then
1933 -- Separate expansion if RHS contain target names. Note that assignment
1934 -- may already have been expanded if RHS is aggregate.
1941 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
1943 -- Rewrite an assignment to X'Priority into a run-time call
1945 -- For example: X'Priority := New_Prio_Expr;
1946 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
1948 -- Note that although X'Priority is notionally an object, it is quite
1949 -- deliberately not defined as an aliased object in the RM. This means
1950 -- that it works fine to rewrite it as a call, without having to worry
1951 -- about complications that would other arise from X'Priority'Access,
1952 -- which is illegal, because of the lack of aliasing.
1955 declare
1962 begin
1963 -- Handle chains of renamings
1969 loop
1973 -- The attribute Priority applied to protected objects has been
1974 -- previously expanded into a call to the Get_Ceiling run-time
1975 -- subprogram. In restricted profiles this is not available.
1979 -- Look for the enclosing concurrent type
1988 -- Generate the first actual of the call
1995 -- Select the appropriate run-time call
1998 RT_Subprg_Name :=
2000 else
2001 RT_Subprg_Name :=
2005 Call :=
2020 -- Deal with assignment checks unless suppressed
2024 -- First deal with generation of range check if required
2030 -- Then generate predicate check if required
2035 -- Check for a special case where a high level transformation is
2036 -- required. If we have either of:
2038 -- P.field := rhs;
2039 -- P (sub) := rhs;
2041 -- where P is a reference to a bit packed array, then we have to unwind
2042 -- the assignment. The exact meaning of being a reference to a bit
2043 -- packed array is as follows:
2045 -- An indexed component whose prefix is a bit packed array is a
2046 -- reference to a bit packed array.
2048 -- An indexed component or selected component whose prefix is a
2049 -- reference to a bit packed array is itself a reference ot a
2050 -- bit packed array.
2052 -- The required transformation is
2054 -- Tnn : prefix_type := P;
2055 -- Tnn.field := rhs;
2056 -- P := Tnn;
2058 -- or
2060 -- Tnn : prefix_type := P;
2061 -- Tnn (subscr) := rhs;
2062 -- P := Tnn;
2064 -- Since P is going to be evaluated more than once, any subscripts
2065 -- in P must have their evaluation forced.
2069 then
2070 declare
2076 begin
2077 -- Insert the post assignment first, because we want to copy the
2078 -- BPAR_Expr tree before it gets analyzed in the context of the
2079 -- pre assignment. Note that we do not analyze the post assignment
2080 -- yet (we cannot till we have completed the analysis of the pre
2081 -- assignment). As usual, the analysis of this post assignment
2082 -- will happen on its own when we "run into" it after finishing
2083 -- the current assignment.
2090 -- At this stage BPAR_Expr is a reference to a bit packed array
2091 -- where the reference was not expanded in the original tree,
2092 -- since it was on the left side of an assignment. But in the
2093 -- pre-assignment statement (the object definition), BPAR_Expr
2094 -- will end up on the right-hand side, and must be reexpanded. To
2095 -- achieve this, we reset the analyzed flag of all selected and
2096 -- indexed components down to the actual indexed component for
2097 -- the packed array.
2100 loop
2104 N_Selected_Component)
2105 then
2107 else
2112 -- Now we can insert and analyze the pre-assignment
2114 -- If the right-hand side requires a transient scope, it has
2115 -- already been placed on the stack. However, the declaration is
2116 -- inserted in the tree outside of this scope, and must reflect
2117 -- the proper scope for its variable. This awkward bit is forced
2118 -- by the stricter scope discipline imposed by GCC 2.97.
2120 declare
2122 Scope_Is_Transient
2125 begin
2137 Pop_Scope;
2141 -- Now fix up the original assignment and continue processing
2146 -- We do not need to reanalyze that assignment, and we do not need
2147 -- to worry about references to the temporary, but we do need to
2148 -- make sure that the temporary is not marked as a true constant
2149 -- since we now have a generated assignment to it.
2155 -- When we have the appropriate type of aggregate in the expression (it
2156 -- has been determined during analysis of the aggregate by setting the
2157 -- delay flag), let's perform in place assignment and thus avoid
2158 -- creating a temporary.
2168 -- Apply discriminant check if required. If Lhs is an access type to a
2169 -- designated type with discriminants, we must always check. If the
2170 -- type has unknown discriminants, more elaborate processing below.
2174 then
2175 -- Skip discriminant check if change of representation. Will be
2176 -- done when the change of representation is expanded out.
2182 -- If the type is private without discriminants, and the full type
2183 -- has discriminants (necessarily with defaults) a check may still be
2184 -- necessary if the Lhs is aliased. The private discriminants must be
2185 -- visible to build the discriminant constraints.
2187 -- Only an explicit dereference that comes from source indicates
2188 -- aliasing. Access to formals of protected operations and entries
2189 -- create dereferences but are not semantic aliasings.
2195 then
2196 declare
2200 begin
2201 -- In the case of an expander-generated record subtype whose base
2202 -- type still appears private, Typ will have been set to that
2203 -- private type rather than the underlying record type (because
2204 -- Underlying type will have returned the record subtype), so it's
2205 -- necessary to apply Underlying_Type again to the base type to
2206 -- get the record type we need for the discriminant check. Such
2207 -- subtypes can be created for assignments in certain cases, such
2208 -- as within an instantiation passed this kind of private type.
2209 -- It would be good to avoid this special test, but making changes
2210 -- to prevent this odd form of record subtype seems difficult. ???
2222 -- If the Lhs has a private type with unknown discriminants, it may
2223 -- have a full view with discriminants, but those are nameable only
2224 -- in the underlying type, so convert the Rhs to it before potential
2225 -- checking. Convert Lhs as well, otherwise the actual subtype might
2226 -- not be constructible. If the discriminants have defaults the type
2227 -- is unconstrained and there is nothing to check.
2232 then
2237 -- In the access type case, we need the same discriminant check, and
2238 -- also range checks if we have an access to constrained array.
2242 then
2245 -- Skip discriminant check if change of representation. Will be
2246 -- done when the change of representation is expanded out.
2260 declare
2264 begin
2265 C_Es :=
2266 Get_Range_Checks
2268 Target_Typ,
2271 Insert_Range_Checks
2273 N,
2274 Target_Typ,
2276 Lhs);
2281 -- Apply range check for access type case
2286 then
2288 Apply_Range_Check
2292 -- Ada 2005 (AI-231): Generate the run-time check
2298 -- If an actual is an out parameter of a null-excluding access
2299 -- type, there is access check on entry, so we set the flag
2300 -- Suppress_Assignment_Checks on the generated statement to
2301 -- assign the actual to the parameter block, and we do not want
2302 -- to generate an additional check at this point.
2305 then
2309 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2310 -- stand-alone obj of an anonymous access type. Do not install the check
2311 -- when the Lhs denotes a container cursor and the Next function employs
2312 -- an access type, because this can never result in a dangling pointer.
2318 then
2319 declare
2321 -- Look through renames to find the underlying entity.
2322 -- For assignment to a rename, we don't care about the
2323 -- Enclosing_Dynamic_Scope of the rename declaration.
2325 ----------------
2326 -- Lhs_Entity --
2327 ----------------
2332 begin
2335 -- Renamed_Object must return an Entity_Name here
2336 -- because of preceding "Present (E_E_A (...))" test.
2344 -- Local Declarations
2348 Condition =>
2350 Left_Opnd =>
2352 Right_Opnd =>
2354 Intval =>
2355 Scope_Depth
2356 (Enclosing_Dynamic_Scope
2362 Name =>
2363 New_Occurrence_Of
2364 (Effective_Extra_Accessibility
2366 Expression =>
2369 begin
2378 -- Case of assignment to a bit packed array element. If there is a
2379 -- change of representation this must be expanded into components,
2380 -- otherwise this is a bit-field assignment.
2384 then
2385 -- Normal case, no change of representation
2391 -- Change of representation case
2393 else
2394 -- Generate the following, to force component-by-component
2395 -- assignments in an efficient way. Otherwise each component
2396 -- will require a temporary and two bit-field manipulations.
2398 -- T1 : Elmt_Type;
2399 -- T1 := RhS;
2400 -- Lhs := T1;
2402 declare
2406 begin
2407 Stats :=
2408 New_List (
2411 Object_Definition =>
2426 -- Build-in-place function call case. This is for assignment statements
2427 -- that come from aggregate component associations or from init procs.
2428 -- User-written assignment statements with b-i-p calls are handled
2429 -- elsewhere.
2437 then
2442 begin
2443 -- In the controlled case, we ensure that function calls are
2444 -- evaluated before finalizing the target. In all cases, it makes
2445 -- the expansion easier if the side effects are removed first.
2450 -- Avoid recursion in the mechanism
2454 -- If dispatching assignment, we need to dispatch to _assign
2458 -- If the type is tagged, we may as well use the predefined
2459 -- primitive assignment. This avoids inlining a lot of code
2460 -- and in the class-wide case, the assignment is replaced
2461 -- by a dispatching call to _assign. It is suppressed in the
2462 -- case of assignments created by the expander that correspond
2463 -- to initializations, where we do want to copy the tag
2464 -- (Expand_Ctrl_Actions flag is set False in this case). It is
2465 -- also suppressed if restriction No_Dispatching_Calls is in
2466 -- force because in that case predefined primitives are not
2467 -- generated.
2471 and then Expand_Ctrl_Actions
2472 and then
2474 then
2477 -- This can happen in an instance when the formal is an
2478 -- extension of a limited interface, and the actual is
2479 -- limited. This is an error according to AI05-0087, but
2480 -- is not caught at the point of instantiation in earlier
2481 -- versions. We also must verify that the limited type does
2482 -- not come from source as corner cases may exist where
2483 -- an assignment was not intended like the pathological case
2484 -- of a raise expression within a return statement.
2486 -- This is wrong, error messages cannot be issued during
2487 -- expansion, since they would be missed in -gnatc mode ???
2490 Error_Msg_N
2497 -- Fetch the primitive op _assign and proper type to call it.
2498 -- Because of possible conflicts between private and full view,
2499 -- fetch the proper type directly from the operation profile.
2501 declare
2506 begin
2507 -- If the assignment is dispatching, make sure to use the
2508 -- proper type.
2516 -- In case of assignment to a class-wide tagged type, before
2517 -- the assignment we generate run-time check to ensure that
2518 -- the tags of source and target match.
2524 then
2525 declare
2529 begin
2531 Lhs_Tag :=
2534 Selector_Name =>
2536 Rhs_Tag :=
2539 Selector_Name =>
2541 else
2542 -- Displace the pointer to the base of the objects
2543 -- applying 'Address, which is later expanded into
2544 -- a call to RE_Base_Address.
2546 Lhs_Tag :=
2548 Prefix =>
2553 Rhs_Tag :=
2555 Prefix =>
2564 Condition =>
2572 declare
2576 begin
2577 -- In order to dispatch the call to _assign the type of
2578 -- the actuals must match. Add conversion (if required).
2597 else
2600 -- We can't afford to have destructive Finalization Actions in
2601 -- the Self assignment case, so if the target and the source
2602 -- are not obviously different, code is generated to avoid the
2603 -- self assignment case:
2605 -- if lhs'address /= rhs'address then
2606 -- <code for controlled and/or tagged assignment>
2607 -- end if;
2609 -- Skip this if Restriction (No_Finalization) is active
2612 and then Expand_Ctrl_Actions
2614 then
2617 Condition =>
2619 Left_Opnd =>
2624 Right_Opnd =>
2632 -- We need to set up an exception handler for implementing
2633 -- 7.6.1(18). The remaining adjustments are tackled by the
2634 -- implementation of adjust for record_controllers (see
2635 -- s-finimp.adb).
2637 -- This is skipped if we have no finalization
2639 if Expand_Ctrl_Actions
2641 then
2644 Handled_Statement_Sequence =>
2654 Handled_Statement_Sequence =>
2657 -- If no restrictions on aborts, protect the whole assignment
2658 -- for controlled objects as per 9.8(11).
2661 and then Expand_Ctrl_Actions
2662 and then Abort_Allowed
2663 then
2664 declare
2666 New_Internal_Entity
2670 begin
2681 -- Present the Abort_Undefer_Direct function to the backend
2682 -- so that it can inline the call to the function.
2686 Expand_At_End_Handler
2691 -- N has been rewritten to a block statement for which it is
2692 -- known by construction that no checks are necessary: analyze
2693 -- it with all checks suppressed.
2699 -- Array types
2702 declare
2705 begin
2707 N_Qualified_Expression)
2708 loop
2716 -- Record types
2722 -- Scalar types. This is where we perform the processing related to the
2723 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
2724 -- scalar values.
2728 -- Case where right side is known valid
2732 -- Here the right side is valid, so it is fine. The case to deal
2733 -- with is when the left side is a local variable reference whose
2734 -- value is not currently known to be valid. If this is the case,
2735 -- and the assignment appears in an unconditional context, then
2736 -- we can mark the left side as now being valid if one of these
2737 -- conditions holds:
2739 -- The expression of the right side has Do_Range_Check set so
2740 -- that we know a range check will be performed. Note that it
2741 -- can be the case that a range check is omitted because we
2742 -- make the assumption that we can assume validity for operands
2743 -- appearing in the right side in determining whether a range
2744 -- check is required
2746 -- The subtype of the right side matches the subtype of the
2747 -- left side. In this case, even though we have not checked
2748 -- the range of the right side, we know it is in range of its
2749 -- subtype if the expression is valid.
2754 then
2757 then
2762 -- Case where right side may be invalid in the sense of the RM
2763 -- reference above. The RM does not require that we check for the
2764 -- validity on an assignment, but it does require that the assignment
2765 -- of an invalid value not cause erroneous behavior.
2767 -- The general approach in GNAT is to use the Is_Known_Valid flag
2768 -- to avoid the need for validity checking on assignments. However
2769 -- in some cases, we have to do validity checking in order to make
2770 -- sure that the setting of this flag is correct.
2772 else
2773 -- Validate right side if we are validating copies
2775 if Validity_Checks_On
2776 and then Validity_Check_Copies
2777 then
2778 -- Skip this if left-hand side is an array or record component
2779 -- and elementary component validity checks are suppressed.
2782 and then not Validity_Check_Components
2783 then
2785 else
2789 -- We can propagate this to the left side where appropriate
2794 then
2798 -- Otherwise check to see what should be done
2800 -- If left side is a local variable, then we just set its flag to
2801 -- indicate that its value may no longer be valid, since we are
2802 -- copying a potentially invalid value.
2807 -- Check for case of a nonlocal variable on the left side which
2808 -- is currently known to be valid. In this case, we simply ensure
2809 -- that the right side is valid. We only play the game of copying
2810 -- validity status for local variables, since we are doing this
2811 -- statically, not by tracing the full flow graph.
2815 then
2816 -- Note: If Validity_Checking mode is set to none, we ignore
2817 -- the Ensure_Valid call so don't worry about that case here.
2821 -- In all other cases, we can safely copy an invalid value without
2822 -- worrying about the status of the left side. Since it is not a
2823 -- variable reference it will not be considered
2824 -- as being known to be valid in any case.
2826 else
2832 exception
2837 ------------------------------
2838 -- Expand_N_Block_Statement --
2839 ------------------------------
2841 -- Encode entity names defined in block statement
2844 begin
2848 -----------------------------
2849 -- Expand_N_Case_Statement --
2850 -----------------------------
2861 begin
2862 -- Check for the situation where we know at compile time which branch
2863 -- will be taken.
2865 -- If the value is static but its subtype is predicated and the value
2866 -- does not obey the predicate, the value is marked non-static, and
2867 -- there can be no corresponding static alternative. In that case we
2868 -- replace the case statement with an exception, regardless of whether
2869 -- assertions are enabled or not, unless predicates are ignored.
2875 then
2884 then
2887 -- Do not consider controlled objects found in a case statement which
2888 -- actually models a case expression because their early finalization
2889 -- will affect the result of the expression.
2895 -- Move statements from this alternative after the case statement.
2896 -- They are already analyzed, so will be skipped by the analyzer.
2900 -- That leaves the case statement as a shell. So now we can kill all
2901 -- other alternatives in the case statement.
2905 declare
2908 begin
2909 -- Loop through case alternatives, skipping pragmas, and skipping
2910 -- the one alternative that we select (and therefore retain).
2916 then
2928 -- Here if the choice is not determined at compile time
2930 declare
2939 begin
2943 else
2947 -- First step is to worry about possible invalid argument. The RM
2948 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
2949 -- outside the base range), then Constraint_Error must be raised.
2951 -- Case of validity check required (validity checks are on, the
2952 -- expression is not known to be valid, and the case statement
2953 -- comes from source -- no need to validity check internally
2954 -- generated case statements).
2956 if Validity_Check_Default
2958 then
2962 -- If there is only a single alternative, just replace it with the
2963 -- sequence of statements since obviously that is what is going to
2964 -- be executed in all cases.
2970 -- We still need to evaluate the expression if it has any side
2971 -- effects.
2976 -- Do not consider controlled objects found in a case statement
2977 -- which actually models a case expression because their early
2978 -- finalization will affect the result of the expression.
2986 -- That leaves the case statement as a shell. The alternative that
2987 -- will be executed is reset to a null list. So now we can kill
2988 -- the entire case statement.
2994 -- An optimization. If there are only two alternatives, and only
2995 -- a single choice, then rewrite the whole case statement as an
2996 -- if statement, since this can result in subsequent optimizations.
2997 -- This helps not only with case statements in the source of a
2998 -- simple form, but also with generated code (discriminant check
2999 -- functions in particular).
3001 -- Note: it is OK to do this before expanding out choices for any
3002 -- static predicates, since the if statement processing will handle
3003 -- the static predicate case fine.
3014 -- For TRUE, generate "expression", not expression = true
3018 then
3021 -- For FALSE, generate "expression" and switch then/else
3025 then
3030 -- For a range, generate "expression in range"
3037 then
3038 Cond :=
3043 -- A subtype indication is not a legal operator in a membership
3044 -- test, so retrieve its range.
3047 Cond :=
3050 Right_Opnd =>
3051 Relocate_Node
3054 -- For any other subexpression "expression = value"
3056 else
3057 Cond :=
3063 -- Now rewrite the case as an IF
3075 -- If the last alternative is not an Others choice, replace it with
3076 -- an N_Others_Choice. Note that we do not bother to call Analyze on
3077 -- the modified case statement, since it's only effect would be to
3078 -- compute the contents of the Others_Discrete_Choices which is not
3079 -- needed by the back end anyway.
3081 -- The reason for this is that the back end always needs some default
3082 -- for a switch, so if we have not supplied one in the processing
3083 -- above for validity checking, then we need to supply one here.
3088 -- If Predicates_Ignored is true the value does not satisfy the
3089 -- predicate, and there is no Others choice, Constraint_Error
3090 -- must be raised (4.5.7 (21/3)).
3093 declare
3103 begin
3108 else
3109 Set_Others_Discrete_Choices
3116 -- Deal with possible declarations of controlled objects, and also
3117 -- with rewriting choice sequences for static predicate references.
3122 -- Do not consider controlled objects found in a case statement
3123 -- which actually models a case expression because their early
3124 -- finalization will affect the result of the expression.
3139 -----------------------------
3140 -- Expand_N_Exit_Statement --
3141 -----------------------------
3143 -- The only processing required is to deal with a possible C/Fortran
3144 -- boolean value used as the condition for the exit statement.
3147 begin
3151 ----------------------------------
3152 -- Expand_Formal_Container_Loop --
3153 ----------------------------------
3168 begin
3169 -- The expansion of a formal container loop resembles the one for Ada
3170 -- containers. The only difference is that the primitives mention the
3171 -- domain of iteration explicitly, and function First applied to the
3172 -- container yields a cursor directly.
3174 -- Cursor : Cursor_type := First (Container);
3175 -- while Has_Element (Cursor, Container) loop
3176 -- <original loop statements>
3177 -- Cursor := Next (Container, Cursor);
3178 -- end loop;
3180 Build_Formal_Container_Iteration
3185 -- Build a block to capture declaration of the cursor
3190 Handled_Statement_Sequence =>
3194 -- The loop parameter is declared by an object declaration, but within
3195 -- the loop we must prevent user assignments to it, so we analyze the
3196 -- declaration and reset the entity kind, before analyzing the rest of
3197 -- the loop.
3203 -- The cursor was marked as a loop parameter to prevent user assignments
3204 -- to it, however this renders the advancement step illegal as it is not
3205 -- possible to change the value of a constant. Flag the advancement step
3206 -- as a legal form of assignment to remedy this side effect.
3211 -- Because we have to analyze the initial declaration of the loop
3212 -- parameter multiple times its scope is incorrectly set at this point
3213 -- to the one surrounding the block statement - so set the scope
3214 -- manually to be the actual block statement, and indicate that it is
3215 -- not visible after the block has been analyzed.
3221 ------------------------------------------
3222 -- Expand_Formal_Container_Element_Loop --
3223 ------------------------------------------
3247 begin
3248 -- For an element iterator, the Element aspect must be present,
3249 -- (this is checked during analysis) and the expansion takes the form:
3251 -- Cursor : Cursor_Type := First (Container);
3252 -- Elmt : Element_Type;
3253 -- while Has_Element (Cursor, Container) loop
3254 -- Elmt := Element (Container, Cursor);
3255 -- <original loop statements>
3256 -- Cursor := Next (Container, Cursor);
3257 -- end loop;
3259 -- However this expansion is not legal if the element is indefinite.
3260 -- In that case we create a block to hold a variable declaration
3261 -- initialized with a call to Element, and generate:
3263 -- Cursor : Cursor_Type := First (Container);
3264 -- while Has_Element (Cursor, Container) loop
3265 -- declare
3266 -- Elmt : Element_Type := Element (Container, Cursor);
3267 -- begin
3268 -- <original loop statements>
3269 -- Cursor := Next (Container, Cursor);
3270 -- end;
3271 -- end loop;
3273 Build_Formal_Container_Iteration
3280 -- The loop parameter is declared by an object declaration, but within
3281 -- the loop we must prevent user assignments to it; the following flag
3282 -- accomplishes that.
3286 -- Declaration for Element
3288 Elmt_Decl :=
3302 New_List
3305 Handled_Statement_Sequence =>
3309 else
3310 Elmt_Ref :=
3313 Expression =>
3322 -- The element is assignable in the expanded code
3326 -- The loop is rewritten as a block, to hold the element declaration
3328 New_Loop :=
3331 Handled_Statement_Sequence =>
3336 -- The element is only modified in expanded code, so it appears as
3337 -- unassigned to the warning machinery. We must suppress this spurious
3338 -- warning explicitly.
3346 -----------------------------
3347 -- Expand_N_Goto_Statement --
3348 -----------------------------
3350 -- Add poll before goto if polling active
3353 begin
3357 ---------------------------
3358 -- Expand_N_If_Statement --
3359 ---------------------------
3361 -- First we deal with the case of C and Fortran convention boolean values,
3362 -- with zero/non-zero semantics.
3364 -- Second, we deal with the obvious rewriting for the cases where the
3365 -- condition of the IF is known at compile time to be True or False.
3367 -- Third, we remove elsif parts which have non-empty Condition_Actions and
3368 -- rewrite as independent if statements. For example:
3370 -- if x then xs
3371 -- elsif y then ys
3372 -- ...
3373 -- end if;
3375 -- becomes
3376 --
3377 -- if x then xs
3378 -- else
3379 -- <<condition actions of y>>
3380 -- if y then ys
3381 -- ...
3382 -- end if;
3383 -- end if;
3385 -- This rewriting is needed if at least one elsif part has a non-empty
3386 -- Condition_Actions list. We also do the same processing if there is a
3387 -- constant condition in an elsif part (in conjunction with the first
3388 -- processing step mentioned above, for the recursive call made to deal
3389 -- with the created inner if, this deals with properly optimizing the
3390 -- cases of constant elsif conditions).
3400 -- Indicates whether we want warnings when we delete branches of the
3401 -- if statement based on constant condition analysis. We never want
3402 -- these warnings for expander generated code.
3404 begin
3405 -- Do not consider controlled objects found in an if statement which
3406 -- actually models an if expression because their early finalization
3407 -- will affect the result of the expression.
3415 -- The following loop deals with constant conditions for the IF. We
3416 -- need a loop because as we eliminate False conditions, we grab the
3417 -- first elsif condition and use it as the primary condition.
3421 -- If condition is True, we can simply rewrite the if statement now
3422 -- by replacing it by the series of then statements.
3426 -- All the else parts can be killed
3436 -- If condition is False, then we can delete the condition and
3437 -- the Then statements
3439 else
3440 -- We do not delete the condition if constant condition warnings
3441 -- are enabled, since otherwise we end up deleting the desired
3442 -- warning. Of course the backend will get rid of this True/False
3443 -- test anyway, so nothing is lost here.
3451 -- If there are no elsif statements, then we simply replace the
3452 -- entire if statement by the sequence of else statements.
3457 then
3460 else
3468 -- If there are elsif statements, the first of them becomes the
3469 -- if/then section of the rebuilt if statement This is the case
3470 -- where we loop to reprocess this copied condition.
3472 else
3478 -- Hed might have been captured as the condition determining
3479 -- the current value for an entity. Now it is detached from
3480 -- the tree, so a Current_Value pointer in the condition might
3481 -- need to be updated.
3492 -- Loop through elsif parts, dealing with constant conditions and
3493 -- possible condition actions that are present.
3499 -- Do not consider controlled objects found in an if statement
3500 -- which actually models an if expression because their early
3501 -- finalization will affect the result of the expression.
3509 -- If there are condition actions, then rewrite the if statement
3510 -- as indicated above. We also do the same rewrite for a True or
3511 -- False condition. The further processing of this constant
3512 -- condition is then done by the recursive call to expand the
3513 -- newly created if statement
3517 then
3518 New_If :=
3525 -- Elsif parts for new if come from remaining elsif's of parent
3549 -- Note this is not an implicit if statement, since it is part
3550 -- of an explicit if statement in the source (or of an implicit
3551 -- if statement that has already been tested). We set the flag
3552 -- after calling Analyze to avoid generating extra warnings
3553 -- specific to pure if statements, however (see
3554 -- Sem_Ch5.Analyze_If_Statement).
3559 -- No special processing for that elsif part, move to next
3561 else
3567 -- Some more optimizations applicable if we still have an IF statement
3573 -- Another optimization, special cases that can be simplified
3575 -- if expression then
3576 -- return true;
3577 -- else
3578 -- return false;
3579 -- end if;
3581 -- can be changed to:
3583 -- return expression;
3585 -- and
3587 -- if expression then
3588 -- return false;
3589 -- else
3590 -- return true;
3591 -- end if;
3593 -- can be changed to:
3595 -- return not (expression);
3597 -- Only do these optimizations if we are at least at -O1 level and
3598 -- do not do them if control flow optimizations are suppressed.
3602 then
3608 then
3609 declare
3613 begin
3615 and then
3617 then
3618 declare
3622 begin
3624 and then
3626 then
3629 then
3638 then
3641 Expression =>
3643 Right_Opnd =>
3656 --------------------------
3657 -- Expand_Iterator_Loop --
3658 --------------------------
3667 begin
3668 -- Processing for arrays
3677 else
3681 -- Processing for containers
3683 else
3684 Expand_Iterator_Loop_Over_Container
3689 -------------------------------------
3690 -- Expand_Iterator_Loop_Over_Array --
3691 -------------------------------------
3707 -- Start of processing for Expand_Iterator_Loop_Over_Array
3709 begin
3710 -- for Element of Array loop
3712 -- It requires an internally generated cursor to iterate over the array
3718 -- Generate:
3719 -- Element : Component_Type renames Array (Iterator);
3720 -- Iterator is the index value, or a list of index values
3721 -- in the case of a multidimensional array.
3723 Ind_Comp :=
3728 -- Propagate the original node to the copy since the analysis of the
3729 -- following object renaming declaration relies on the original node.
3736 Subtype_Mark =>
3740 -- Mark the loop variable as needing debug info, so that expansion
3741 -- of the renaming will result in Materialize_Entity getting set via
3742 -- Debug_Renaming_Declaration. (This setting is needed here because
3743 -- the setting in Freeze_Entity comes after the expansion, which is
3744 -- too late. ???)
3748 -- Generate:
3750 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
3751 -- Element : Component_Type renames Array (Iterator);
3752 -- <original loop statements>
3753 -- end loop;
3755 -- If this is an iteration over a multidimensional array, the
3756 -- innermost loop is over the last dimension in Ada, and over
3757 -- the first dimension in Fortran.
3761 else
3765 Core_Loop :=
3767 Iteration_Scheme =>
3769 Loop_Parameter_Specification =>
3772 Discrete_Subtype_Definition =>
3782 -- Processing for multidimensional array. The body of each loop is
3783 -- a loop over a previous dimension, going in decreasing order in Ada
3784 -- and in increasing order in Fortran.
3790 else
3796 -- Generate the dimension loops starting from the innermost one
3798 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
3799 -- <core loop>
3800 -- end loop;
3802 Core_Loop :=
3804 Iteration_Scheme =>
3806 Loop_Parameter_Specification =>
3809 Discrete_Subtype_Definition =>
3819 -- Update the previously created object renaming declaration with
3820 -- the new iterator, by adding the index of the next loop to the
3821 -- indexed component, in the order that corresponds to the
3822 -- convention.
3827 else
3834 -- Inherit the loop identifier from the original loop. This ensures that
3835 -- the scope stack is consistent after the rewriting.
3845 -----------------------------------------
3846 -- Expand_Iterator_Loop_Over_Container --
3847 -----------------------------------------
3849 -- For a 'for ... in' loop, such as:
3851 -- for Cursor in Iterator_Function (...) loop
3852 -- ...
3853 -- end loop;
3855 -- we generate:
3857 -- Iter : Iterator_Type := Iterator_Function (...);
3858 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
3859 -- while Has_Element (Cursor) loop
3860 -- ...
3861 --
3862 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3863 -- end loop;
3865 -- For a 'for ... of' loop, such as:
3867 -- for X of Container loop
3868 -- ...
3869 -- end loop;
3871 -- the RM implies the generation of:
3873 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
3874 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
3875 -- while Has_Element (Cursor) loop
3876 -- declare
3877 -- X : Element_Type renames Element (Cursor).Element.all;
3878 -- -- or Constant_Element
3879 -- begin
3880 -- ...
3881 -- end;
3882 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3883 -- end loop;
3885 -- In the general case, we do what the RM says. However, the operations
3886 -- Element and Iter.Next are slow, which is bad inside a loop, because they
3887 -- involve dispatching via interfaces, secondary stack manipulation,
3888 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
3889 -- predefined containers, we use an equivalent but optimized expansion.
3891 -- In the optimized case, we make use of these:
3893 -- procedure Next (Position : in out Cursor); -- instead of Iter.Next
3895 -- function Pseudo_Reference
3896 -- (Container : aliased Vector'Class) return Reference_Control_Type;
3898 -- type Element_Access is access all Element_Type;
3900 -- function Get_Element_Access
3901 -- (Position : Cursor) return not null Element_Access;
3903 -- Next is declared in the visible part of the container packages.
3904 -- The other three are added in the private part. (We're not supposed to
3905 -- pollute the namespace for clients. The compiler has no trouble breaking
3906 -- privacy to call things in the private part of an instance.)
3908 -- Source:
3910 -- for X of My_Vector loop
3911 -- X.Count := X.Count + 1;
3912 -- ...
3913 -- end loop;
3915 -- The compiler will generate:
3917 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector);
3918 -- -- Reversible_Iterator is an interface. Iterate is the
3919 -- -- Default_Iterator aspect of Vector. This increments Lock,
3920 -- -- disallowing tampering with cursors. Unfortunately, it does not
3921 -- -- increment Busy. The result of Iterate is Limited_Controlled;
3922 -- -- finalization will decrement Lock. This is a build-in-place
3923 -- -- dispatching call to Iterate.
3925 -- Cur : Cursor := First (Iter); -- or Last
3926 -- -- Dispatching call via interface.
3928 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
3929 -- -- Pseudo_Reference increments Busy, to detect tampering with
3930 -- -- elements, as required by RM. Also redundantly increment
3931 -- -- Lock. Finalization of Control will decrement both Busy and
3932 -- -- Lock. Pseudo_Reference returns a record containing a pointer to
3933 -- -- My_Vector, used by Finalize.
3934 -- --
3935 -- -- Control is not used below, except to finalize it -- it's purely
3936 -- -- an RAII thing. This is needed because we are eliminating the
3937 -- -- call to Reference within the loop.
3939 -- while Has_Element (Cur) loop
3940 -- declare
3941 -- X : My_Element renames Get_Element_Access (Cur).all;
3942 -- -- Get_Element_Access returns a pointer to the element
3943 -- -- designated by Cur. No dispatching here, and no horsing
3944 -- -- around with access discriminants. This is instead of the
3945 -- -- existing
3946 -- --
3947 -- -- X : My_Element renames Reference (Cur).Element.all;
3948 -- --
3949 -- -- which creates a controlled object.
3950 -- begin
3951 -- -- Any attempt to tamper with My_Vector here in the loop
3952 -- -- will correctly raise Program_Error, because of the
3953 -- -- Control.
3954 --
3955 -- X.Count := X.Count + 1;
3956 -- ...
3957 --
3958 -- Next (Cur); -- or Prev
3959 -- -- This is instead of "Cur := Next (Iter, Cur);"
3960 -- end;
3961 -- -- No finalization here
3962 -- end loop;
3963 -- Finalize Iter and Control here, decrementing Lock twice and Busy
3964 -- once.
3966 -- This optimization makes "for ... of" loops over 30 times faster in cases
3967 -- measured.
3969 procedure Expand_Iterator_Loop_Over_Container
3975 is
3992 -- Only for optimized version of "for ... of"
3995 -- The package in which the iterator interface is instantiated. This is
3996 -- typically an instance within the container package.
3999 -- The package in which the container type is declared
4001 begin
4002 -- Determine the advancement and initialization steps for the cursor.
4003 -- Analysis of the expanded loop will verify that the container has a
4004 -- reverse iterator.
4009 else
4014 -- The type of the iterator is the return type of the Iterate function
4015 -- used. For the "of" form this is the default iterator for the type,
4016 -- otherwise it is the type of the explicit function used in the
4017 -- iterator specification. The most common case will be an Iterate
4018 -- function in the container package.
4020 -- The Iterator type is declared in an instance within the container
4021 -- package itself, for example:
4023 -- package Vector_Iterator_Interfaces is new
4024 -- Ada.Iterator_Interfaces (Cursor, Has_Element);
4026 -- If the container type is a derived type, the cursor type is found in
4027 -- the package of the ultimate ancestor type.
4031 else
4039 function Get_Default_Iterator
4041 -- Return the default iterator for a specific type. If the type is
4042 -- derived, we return the inherited or overridden one if
4043 -- appropriate.
4045 --------------------------
4046 -- Get_Default_Iterator --
4047 --------------------------
4049 function Get_Default_Iterator
4051 is
4057 begin
4060 -- A previous version of GNAT allowed indexing aspects to be
4061 -- redefined on derived container types, while the default
4062 -- iterator was inherited from the parent type. This
4063 -- nonstandard extension is preserved for use by the
4064 -- modeling project under debug flag -gnatd.X.
4069 then
4070 Container_Arg :=
4072 Subtype_Mark =>
4073 New_Occurrence_Of
4082 -- The default iterator must be a primitive operation of the
4083 -- type, at the same dispatch slot position. The DT position
4084 -- may not be established if type is not frozen yet.
4091 or else
4095 then
4102 -- If we didn't find it, then our parent type is not
4103 -- iterable, so we return the Default_Iterator aspect of
4104 -- this type.
4108 -- Otherwise not a derived type
4110 else
4115 -- Local variables
4123 -- Start of processing for Handle_Of
4125 begin
4127 Default_Iter :=
4129 else
4135 -- For a container element iterator, the iterator type is obtained
4136 -- from the corresponding aspect, whose return type is descended
4137 -- from the corresponding interface type in some instance of
4138 -- Ada.Iterator_Interfaces. The actuals of that instantiation
4139 -- are Cursor and Has_Element.
4143 -- The iterator type, which is a class-wide type, may itself be
4144 -- derived locally, so the desired instantiation is the scope of
4145 -- the root type of the iterator type.
4149 -- Find declarations needed for "for ... of" optimization
4158 then
4173 then
4177 Object_Definition =>
4179 Expression =>
4181 Name =>
4183 Parameter_Associations =>
4187 -- Rewrite domain of iteration as a call to the default iterator
4188 -- for the container type. The formal may be an access parameter
4189 -- in which case we must build a reference to the container.
4191 declare
4193 begin
4195 Arg :=
4199 else
4205 Name =>
4212 -- Find cursor type in proper iterator package, which is an
4213 -- instantiation of Iterator_Interfaces.
4226 Decl :=
4229 Subtype_Mark =>
4231 Name =>
4233 Prefix =>
4235 Name =>
4237 Parameter_Associations =>
4240 else
4241 Decl :=
4244 Subtype_Mark =>
4246 Name =>
4249 Expressions =>
4253 -- The defining identifier in the iterator is user-visible and
4254 -- must be visible in the debugger.
4258 -- If the container does not have a variable indexing aspect,
4259 -- the element is a constant in the loop. The container itself
4260 -- may be constant, in which case the element is a constant as
4261 -- well. The container has been rewritten as a call to Iterate,
4262 -- so examine original node.
4267 then
4274 -- X in Iterate (S) : type of iterator is type of explicitly given
4275 -- Iterate function, and the loop variable is the cursor. It will be
4276 -- assigned in the loop and must be a variable.
4278 else
4281 -- The iterator type, which is a class-wide type, may itself be
4282 -- derived locally, so the desired instantiation is the scope of
4283 -- the root type of the iterator type, as in the "of" case.
4291 -- For both iterator forms, add a call to the step operation to advance
4292 -- the cursor. Generate:
4294 -- Cursor := Iterator.Next (Cursor);
4296 -- or else
4298 -- Cursor := Next (Cursor);
4301 declare
4305 begin
4306 Step_Call :=
4308 Name =>
4316 else
4317 declare
4320 begin
4321 Rhs :=
4323 Name =>
4338 -- Generate:
4339 -- while Has_Element (Cursor) loop
4340 -- <Stats>
4341 -- end loop;
4343 -- Has_Element is the second actual in the iterator package
4345 New_Loop :=
4347 Iteration_Scheme =>
4349 Condition =>
4351 Name =>
4352 New_Occurrence_Of
4360 -- If present, preserve identifier of loop, which can be used in an exit
4361 -- statement in the body.
4367 -- Create the declarations for Iterator and cursor and insert them
4368 -- before the source loop. Given that the domain of iteration is already
4369 -- an entity, the iterator is just a renaming of that entity. Possible
4370 -- optimization ???
4378 -- Create declaration for cursor
4380 declare
4384 Object_Definition =>
4386 Expression =>
4388 Prefix =>
4390 Selector_Name =>
4393 begin
4394 -- The cursor is only modified in expanded code, so it appears
4395 -- as unassigned to the warning machinery. We must suppress this
4396 -- spurious warning explicitly. The cursor's kind is that of the
4397 -- original loop parameter (it is a constant if the domain of
4398 -- iteration is constant).
4407 -- If the range of iteration is given by a function call that returns
4408 -- a container, the finalization actions have been saved in the
4409 -- Condition_Actions of the iterator. Insert them now at the head of
4410 -- the loop.
4420 -----------------------------
4421 -- Expand_N_Loop_Statement --
4422 -----------------------------
4424 -- 1. Remove null loop entirely
4425 -- 2. Deal with while condition for C/Fortran boolean
4426 -- 3. Deal with loops with a non-standard enumeration type range
4427 -- 4. Deal with while loops where Condition_Actions is set
4428 -- 5. Deal with loops over predicated subtypes
4429 -- 6. Deal with loops with iterators over arrays and containers
4430 -- 7. Insert polling call if required
4437 begin
4438 -- Delete null loop
4445 -- Deal with condition for C/Fortran Boolean
4451 -- Generate polling call
4457 -- Nothing more to do for plain loop with no iteration scheme
4462 -- Case of for loop (Loop_Parameter_Specification present)
4464 -- Note: we do not have to worry about validity checking of the for loop
4465 -- range bounds here, since they were frozen with constant declarations
4466 -- and it is during that process that the validity checking is done.
4469 declare
4479 begin
4480 -- Deal with loop over predicates
4484 then
4487 -- Handle the case where we have a for loop with the range type
4488 -- being an enumeration type with non-standard representation.
4489 -- In this case we expand:
4491 -- for x in [reverse] a .. b loop
4492 -- ...
4493 -- end loop;
4495 -- to
4497 -- for xP in [reverse] integer
4498 -- range etype'Pos (a) .. etype'Pos (b)
4499 -- loop
4500 -- declare
4501 -- x : constant etype := Pos_To_Rep (xP);
4502 -- begin
4503 -- ...
4504 -- end;
4505 -- end loop;
4509 then
4510 New_Id :=
4514 -- If the type has a contiguous representation, successive
4515 -- values can be generated as offsets from the first literal.
4518 Expr :=
4521 Left_Opnd =>
4525 else
4526 -- Use the constructed array Enum_Pos_To_Rep
4528 Expr :=
4530 Prefix =>
4532 Expressions =>
4536 -- Build declaration for loop identifier
4538 Decls :=
4539 New_List (
4550 Iteration_Scheme =>
4552 Loop_Parameter_Specification =>
4557 Discrete_Subtype_Definition =>
4560 Subtype_Mark =>
4563 Constraint =>
4565 Range_Expression =>
4568 Low_Bound =>
4570 Prefix =>
4576 Relocate_Node
4579 High_Bound =>
4581 Prefix =>
4587 Relocate_Node
4588 (Type_High_Bound
4594 Handled_Statement_Sequence =>
4600 -- The loop parameter's entity must be removed from the loop
4601 -- scope's entity list and rendered invisible, since it will
4602 -- now be located in the new block scope. Any other entities
4603 -- already associated with the loop scope, such as the loop
4604 -- parameter's subtype, will remain there.
4606 -- In an element loop, the loop will contain a declaration for
4607 -- a cursor variable; otherwise the loop id is the first entity
4608 -- in the scope constructed for the loop.
4624 -- Nothing to do with other cases of for loops
4626 else
4631 -- Second case, if we have a while loop with Condition_Actions set, then
4632 -- we change it into a plain loop:
4634 -- while C loop
4635 -- ...
4636 -- end loop;
4638 -- changed to:
4640 -- loop
4641 -- <<condition actions>>
4642 -- exit when not C;
4643 -- ...
4644 -- end loop
4649 then
4650 declare
4653 begin
4654 ES :=
4656 Condition =>
4663 -- This is not an implicit loop, since it is generated in response
4664 -- to the loop statement being processed. If this is itself
4665 -- implicit, the restriction has already been checked. If not,
4666 -- it is an explicit loop.
4677 -- Here to deal with iterator case
4681 then
4684 -- An iterator loop may generate renaming declarations for elements
4685 -- that require debug information. This is the case in particular
4686 -- with element iterators, where debug information must be generated
4687 -- for the temporary that holds the element value. These temporaries
4688 -- are created within a transient block whose local declarations are
4689 -- transferred to the loop, which now has nontrivial local objects.
4693 then
4698 -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
4699 -- is transformed into a conditional block where the original loop is
4700 -- the sole statement. Inspect the statements of the nested loop for
4701 -- controlled objects.
4712 ----------------------------
4713 -- Expand_Predicated_Loop --
4714 ----------------------------
4716 -- Note: the expander can handle generation of loops over predicated
4717 -- subtypes for both the dynamic and static cases. Depending on what
4718 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
4719 -- mode, the semantic analyzer may disallow one or both forms.
4730 begin
4731 -- Case of iteration over non-static predicate, should not be possible
4732 -- since this is not allowed by the semantics and should have been
4733 -- caught during analysis of the loop statement.
4738 -- If the predicate list is empty, that corresponds to a predicate of
4739 -- False, in which case the loop won't run at all, and we rewrite the
4740 -- entire loop as a null statement.
4746 -- For expansion over a static predicate we generate the following
4748 -- declare
4749 -- J : Ltype := min-val;
4750 -- begin
4751 -- loop
4752 -- body
4753 -- case J is
4754 -- when endpoint => J := startpoint;
4755 -- when endpoint => J := startpoint;
4756 -- ...
4757 -- when max-val => exit;
4758 -- when others => J := Lval'Succ (J);
4759 -- end case;
4760 -- end loop;
4761 -- end;
4763 -- with min-val replaced by max-val and Succ replaced by Pred if the
4764 -- loop parameter specification carries a Reverse indicator.
4766 -- To make this a little clearer, let's take a specific example:
4768 -- type Int is range 1 .. 10;
4769 -- subtype StaticP is Int with
4770 -- predicate => StaticP in 3 | 10 | 5 .. 7;
4771 -- ...
4772 -- for L in StaticP loop
4773 -- Put_Line ("static:" & J'Img);
4774 -- end loop;
4776 -- In this case, the loop is transformed into
4778 -- begin
4779 -- J : L := 3;
4780 -- loop
4781 -- body
4782 -- case J is
4783 -- when 3 => J := 5;
4784 -- when 7 => J := 10;
4785 -- when 10 => exit;
4786 -- when others => J := L'Succ (J);
4787 -- end case;
4788 -- end loop;
4789 -- end;
4791 -- In addition, if the loop specification is given by a subtype
4792 -- indication that constrains a predicated type, the bounds of
4793 -- iteration are given by those of the subtype indication.
4795 else
4803 -- If the domain is an itype, note the bounds of its range.
4809 -- Given static expression or static range, returns an identifier
4810 -- whose value is the low bound of the expression value or range.
4813 -- Given static expression or static range, returns an identifier
4814 -- whose value is the high bound of the expression value or range.
4816 ------------
4817 -- Hi_Val --
4818 ------------
4821 begin
4824 else
4830 ------------
4831 -- Lo_Val --
4832 ------------
4835 begin
4838 else
4844 -- Start of processing for Static_Predicate
4846 begin
4847 -- Convert loop identifier to normal variable and reanalyze it so
4848 -- that this conversion works. We have to use the same defining
4849 -- identifier, since there may be references in the loop body.
4854 -- In most loops the loop variable is assigned in various
4855 -- alternatives in the body. However, in the rare case when
4856 -- the range specifies a single element, the loop variable
4857 -- may trigger a spurious warning that is could be constant.
4858 -- This warning might as well be suppressed.
4867 -- Loop to create branches of case statement
4873 -- Initial value is largest value in predicate.
4876 D :=
4882 else
4883 D :=
4894 else
4895 S :=
4912 and then
4914 then
4921 else
4922 -- Initial value is smallest value in predicate
4925 D :=
4930 else
4931 D :=
4942 else
4943 S :=
4960 and then
4962 then
4970 -- Add others choice
4972 declare
4975 begin
4978 else
4982 S :=
4985 Expression =>
4999 -- Construct case statement and append to body statements
5001 Cstm :=
5007 -- Rewrite the loop
5014 Handled_Statement_Sequence =>
5026 ------------------------------
5027 -- Make_Tag_Ctrl_Assignment --
5028 ------------------------------
5041 and then not Comp_Asn
5048 begin
5049 -- Finalize the target of the assignment when controlled
5051 -- We have two exceptions here:
5053 -- 1. If we are in an init proc since it is an initialization more
5054 -- than an assignment.
5056 -- 2. If the left-hand side is a temporary that was not initialized
5057 -- (or the parent part of a temporary since it is the case in
5058 -- extension aggregates). Such a temporary does not come from
5059 -- source. We must examine the original node for the prefix, because
5060 -- it may be a component of an entry formal, in which case it has
5061 -- been rewritten and does not appear to come from source either.
5063 -- Case of init proc
5068 -- The left-hand side is an uninitialized temporary object
5073 N_Object_Declaration
5075 then
5078 else
5079 Fin_Call :=
5080 Make_Final_Call
5089 -- Save the Tag in a local variable Tag_Id
5098 Expression =>
5101 Selector_Name =>
5104 -- Otherwise Tag_Id is not used
5106 else
5110 -- If the tagged type has a full rep clause, expand the assignment into
5111 -- component-wise assignments. Mark the node as unanalyzed in order to
5112 -- generate the proper code and propagate this scenario by setting a
5113 -- flag to avoid infinite recursion.
5122 -- Restore the tag
5127 Name =>
5130 Selector_Name =>
5135 -- Adjust the target after the assignment when controlled (not in the
5136 -- init proc since it is an initialization more than an assignment).
5139 Adj_Call :=
5140 Make_Adjust_Call
5151 exception
5153 -- Could use comment here ???