| blob | 5267024bc6e8d8050ed2fd11da62e5bec46b4b48 |
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-2016, 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.
78 -- Determine if the right-hand side of assignment N is a type conversion
79 -- which requires a change of representation. Called only for the array
80 -- and record cases.
83 -- N is an assignment which assigns an array value. This routine process
84 -- the various special cases and checks required for such assignments,
85 -- including change of representation. Rhs is normally simply the right-
86 -- hand side of the assignment, except that if the right-hand side is a
87 -- type conversion or a qualified expression, then the RHS is the actual
88 -- expression inside any such type conversions or qualifications.
90 function Expand_Assign_Array_Loop
98 -- N is an assignment statement which assigns an array value. This routine
99 -- expands the assignment into a loop (or nested loops for the case of a
100 -- multi-dimensional array) to do the assignment component by component.
101 -- Larray and Rarray are the entities of the actual arrays on the left-hand
102 -- and right-hand sides. L_Type and R_Type are the types of these arrays
103 -- (which may not be the same, due to either sliding, or to a change of
104 -- representation case). Ndim is the number of dimensions and the parameter
105 -- Rev indicates if the loops run normally (Rev = False), or reversed
106 -- (Rev = True). The value returned is the constructed loop statement.
107 -- Auxiliary declarations are inserted before node N using the standard
108 -- Insert_Actions mechanism.
111 -- N is an assignment of an untagged record value. This routine handles
112 -- the case where the assignment must be made component by component,
113 -- either because the target is not byte aligned, or there is a change
114 -- of representation, or when we have a tagged type with a representation
115 -- clause (this last case is required because holes in the tagged type
116 -- might be filled with components from child types).
119 -- (AI12-0125): N is an assignment statement whose RHS contains occurrences
120 -- of @ that designate the value of the LHS of the assignment. If the LHS
121 -- is side-effect free the target names can be replaced with a copy of the
122 -- LHS; otherwise the semantics of the assignment is described in terms of
123 -- a procedure with an in-out parameter, and expanded as such.
126 -- Use the primitives specified in an Iterable aspect to expand a loop
127 -- over a so-called formal container, primarily for SPARK usage.
130 -- Same, for an iterator of the form " For E of C". In this case the
131 -- iterator provides the name of the element, and the cursor is generated
132 -- internally.
135 -- Expand loop over arrays and containers that uses the form "for X of C"
136 -- with an optional subtype mark, or "for Y in C".
138 procedure Expand_Iterator_Loop_Over_Container
144 -- Expand loop over containers that uses the form "for X of C" with an
145 -- optional subtype mark, or "for Y in C". Isc is the iteration scheme.
146 -- I_Spec is the iterator specification and Container is either the
147 -- Container (for OF) or the iterator (for IN).
150 -- Expand for loop over predicated subtype
153 -- Generate the necessary code for controlled and tagged assignment, that
154 -- is to say, finalization of the target before, adjustment of the target
155 -- after and save and restore of the tag and finalization pointers which
156 -- are not 'part of the value' and must not be changed upon assignment. N
157 -- is the original Assignment node.
159 --------------------------------------
160 -- Build_Formal_Container_iteration --
161 --------------------------------------
163 procedure Build_Formal_Container_Iteration
170 is
181 begin
182 -- Declaration for Cursor
184 Init :=
188 Expression =>
194 -- Statement that advances cursor in loop
196 Advance :=
199 Expression =>
206 -- Iterator is rewritten as a while_loop
208 New_Loop :=
210 Iteration_Scheme =>
212 Condition =>
222 ------------------------------
223 -- Change_Of_Representation --
224 ------------------------------
228 begin
229 return
231 and then
235 -------------------------
236 -- Expand_Assign_Array --
237 -------------------------
239 -- There are two issues here. First, do we let Gigi do a block move, or
240 -- do we expand out into a loop? Second, we need to set the two flags
241 -- Forwards_OK and Backwards_OK which show whether the block move (or
242 -- corresponding loops) can be legitimately done in a forwards (low to
243 -- high) or backwards (high to low) manner.
269 -- This switch is set to True if the array move must be done using
270 -- an explicit front end generated loop.
273 -- If the argument is an access to an array, and the assignment is
274 -- converted into a procedure call, apply explicit dereference.
277 -- Test if Exp is a reference to an array whose declaration has
278 -- an address clause, or it is a slice of such an array.
281 -- Test if Exp is a reference to an array which is either a formal
282 -- parameter or a slice of a formal parameter. These are the cases
283 -- where hidden aliasing can occur.
286 -- Determine if Exp is a reference to an array variable which is other
287 -- than an object defined in the current scope, or a component or a
288 -- slice of such an object. Such objects can be aliased to parameters
289 -- (unlike local array references).
291 -----------------------
292 -- Apply_Dereference --
293 -----------------------
297 begin
305 ------------------------
306 -- Has_Address_Clause --
307 ------------------------
310 begin
311 return
314 or else
318 ---------------------
319 -- Is_Formal_Array --
320 ---------------------
323 begin
324 return
326 or else
330 ------------------------
331 -- Is_Non_Local_Array --
332 ------------------------
335 begin
337 when N_Indexed_Component
338 | N_Selected_Component
339 | N_Slice
340 =>
344 return
350 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
358 -- Start of processing for Expand_Assign_Array
360 begin
361 -- Deal with length check. Note that the length check is done with
362 -- respect to the right-hand side as given, not a possible underlying
363 -- renamed object, since this would generate incorrect extra checks.
367 -- We start by assuming that the move can be done in either direction,
368 -- i.e. that the two sides are completely disjoint.
373 -- Normally it is only the slice case that can lead to overlap, and
374 -- explicit checks for slices are made below. But there is one case
375 -- where the slice can be implicit and invisible to us: when we have a
376 -- one dimensional array, and either both operands are parameters, or
377 -- one is a parameter (which can be a slice passed by reference) and the
378 -- other is a non-local variable. In this case the parameter could be a
379 -- slice that overlaps with the other operand.
381 -- However, if the array subtype is a constrained first subtype in the
382 -- parameter case, then we don't have to worry about overlap, since
383 -- slice assignments aren't possible (other than for a slice denoting
384 -- the whole array).
386 -- Note: No overlap is possible if there is a change of representation,
387 -- so we can exclude this case.
390 and then not Crep
391 and then
393 or else
395 or else
397 and then
400 then
404 -- Note: the bit-packed case is not worrisome here, since if we have
405 -- a slice passed as a parameter, it is always aligned on a byte
406 -- boundary, and if there are no explicit slices, the assignment
407 -- can be performed directly.
410 -- If either operand has an address clause clear Backwards_OK and
411 -- Forwards_OK, since we cannot tell if the operands overlap. We
412 -- exclude this treatment when Rhs is an aggregate, since we know
413 -- that overlap can't occur.
417 then
422 -- We certainly must use a loop for change of representation and also
423 -- we use the operand of the conversion on the right-hand side as the
424 -- effective right-hand side (the component types must match in this
425 -- situation).
432 -- We require a loop if the left side is possibly bit unaligned
435 or else
437 then
440 -- Arrays with controlled components are expanded into a loop to force
441 -- calls to Adjust at the component level.
446 -- If object is atomic/VFA, we cannot tolerate a loop
449 or else
451 then
454 -- Loop is required if we have atomic components since we have to
455 -- be sure to do any accesses on an element by element basis.
461 then
464 -- Case where no slice is involved
468 -- The following code deals with the case of unconstrained bit packed
469 -- arrays. The problem is that the template for such arrays contains
470 -- the bounds of the actual source level array, but the copy of an
471 -- entire array requires the bounds of the underlying array. It would
472 -- be nice if the back end could take care of this, but right now it
473 -- does not know how, so if we have such a type, then we expand out
474 -- into a loop, which is inefficient but works correctly. If we don't
475 -- do this, we get the wrong length computed for the array to be
476 -- moved. The two cases we need to worry about are:
478 -- Explicit dereference of an unconstrained packed array type as in
479 -- the following example:
481 -- procedure C52 is
482 -- type BITS is array(INTEGER range <>) of BOOLEAN;
483 -- pragma PACK(BITS);
484 -- type A is access BITS;
485 -- P1,P2 : A;
486 -- begin
487 -- P1 := new BITS (1 .. 65_535);
488 -- P2 := new BITS (1 .. 65_535);
489 -- P2.ALL := P1.ALL;
490 -- end C52;
492 -- A formal parameter reference with an unconstrained bit array type
493 -- is the other case we need to worry about (here we assume the same
494 -- BITS type declared above):
496 -- procedure Write_All (File : out BITS; Contents : BITS);
497 -- begin
498 -- File.Storage := Contents;
499 -- end Write_All;
501 -- We expand to a loop in either of these two cases
503 -- Question for future thought. Another potentially more efficient
504 -- approach would be to create the actual subtype, and then do an
505 -- unchecked conversion to this actual subtype ???
510 -- Function to perform required test for the first case, above
511 -- (dereference of an unconstrained bit packed array).
513 -----------------------
514 -- Is_UBPA_Reference --
515 -----------------------
522 begin
526 then
535 else
537 return
542 else
547 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
549 begin
551 or else
553 then
556 -- Here if we do not have the case of a reference to a bit packed
557 -- unconstrained array case. In this case gigi can most certainly
558 -- handle the assignment if a forwards move is allowed.
560 -- (could it handle the backwards case also???)
567 -- The back end can always handle the assignment if the right side is a
568 -- string literal (note that overlap is definitely impossible in this
569 -- case). If the type is packed, a string literal is always converted
570 -- into an aggregate, except in the case of a null slice, for which no
571 -- aggregate can be written. In that case, rewrite the assignment as a
572 -- null statement, a length check has already been emitted to verify
573 -- that the range of the left-hand side is empty.
575 -- Note that this code is not executed if we have an assignment of a
576 -- string literal to a non-bit aligned component of a record, a case
577 -- which cannot be handled by the backend.
582 then
589 -- If either operand is bit packed, then we need a loop, since we can't
590 -- be sure that the slice is byte aligned. Similarly, if either operand
591 -- is a possibly unaligned slice, then we need a loop (since the back
592 -- end cannot handle unaligned slices).
598 then
601 -- If we are not bit-packed, and we have only one slice, then no overlap
602 -- is possible except in the parameter case, so we can let the back end
603 -- handle things.
611 -- If the right-hand side is a string literal, introduce a temporary for
612 -- it, for use in the generated loop that will follow.
615 declare
619 begin
620 Decl :=
632 -- Come here to complete the analysis
634 -- Loop_Required: Set to True if we know that a loop is required
635 -- regardless of overlap considerations.
637 -- Forwards_OK: Set to False if we already know that a forwards
638 -- move is not safe, else set to True.
640 -- Backwards_OK: Set to False if we already know that a backwards
641 -- move is not safe, else set to True
643 -- Our task at this stage is to complete the overlap analysis, which can
644 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
645 -- then generating the final code, either by deciding that it is OK
646 -- after all to let Gigi handle it, or by generating appropriate code
647 -- in the front end.
649 declare
667 begin
668 -- Get the expressions for the arrays. If we are dealing with a
669 -- private type, then convert to the underlying type. We can do
670 -- direct assignments to an array that is a private type, but we
671 -- cannot assign to elements of the array without this extra
672 -- unchecked conversion.
674 -- Note: We propagate Parent to the conversion nodes to generate
675 -- a well-formed subtree.
679 else
683 declare
685 begin
686 Larray :=
687 Unchecked_Convert_To
696 else
700 declare
702 begin
703 Rarray :=
704 Unchecked_Convert_To
711 -- If both sides are slices, we must figure out whether it is safe
712 -- to do the move in one direction or the other. It is always safe
713 -- if there is a change of representation since obviously two arrays
714 -- with different representations cannot possibly overlap.
720 -- If both left- and right-hand arrays are entity names, and refer
721 -- to different entities, then we know that the move is safe (the
722 -- two storage areas are completely disjoint).
727 then
730 -- Otherwise, we assume the worst, which is that the two arrays
731 -- are the same array. There is no need to check if we know that
732 -- is the case, because if we don't know it, we still have to
733 -- assume it.
735 -- Generally if the same array is involved, then we have an
736 -- overlapping case. We will have to really assume the worst (i.e.
737 -- set neither of the OK flags) unless we can determine the lower
738 -- or upper bounds at compile time and compare them.
740 else
741 Cresult :=
742 Compile_Time_Compare
746 Cresult :=
747 Compile_Time_Compare
765 -- If after that analysis Loop_Required is False, meaning that we
766 -- have not discovered some non-overlap reason for requiring a loop,
767 -- then the outcome depends on the capabilities of the back end.
770 -- Assume the back end can deal with all cases of overlap by
771 -- falling back to memmove if it cannot use a more efficient
772 -- approach.
777 -- At this stage we have to generate an explicit loop, and we have
778 -- the following cases:
780 -- Forwards_OK = True
782 -- Rnn : right_index := right_index'First;
783 -- for Lnn in left-index loop
784 -- left (Lnn) := right (Rnn);
785 -- Rnn := right_index'Succ (Rnn);
786 -- end loop;
788 -- Note: the above code MUST be analyzed with checks off, because
789 -- otherwise the Succ could overflow. But in any case this is more
790 -- efficient.
792 -- Forwards_OK = False, Backwards_OK = True
794 -- Rnn : right_index := right_index'Last;
795 -- for Lnn in reverse left-index loop
796 -- left (Lnn) := right (Rnn);
797 -- Rnn := right_index'Pred (Rnn);
798 -- end loop;
800 -- Note: the above code MUST be analyzed with checks off, because
801 -- otherwise the Pred could overflow. But in any case this is more
802 -- efficient.
804 -- Forwards_OK = Backwards_OK = False
806 -- This only happens if we have the same array on each side. It is
807 -- possible to create situations using overlays that violate this,
808 -- but we simply do not promise to get this "right" in this case.
810 -- There are two possible subcases. If the No_Implicit_Conditionals
811 -- restriction is set, then we generate the following code:
813 -- declare
814 -- T : constant <operand-type> := rhs;
815 -- begin
816 -- lhs := T;
817 -- end;
819 -- If implicit conditionals are permitted, then we generate:
821 -- if Left_Lo <= Right_Lo then
822 -- <code for Forwards_OK = True above>
823 -- else
824 -- <code for Backwards_OK = True above>
825 -- end if;
827 -- In order to detect possible aliasing, we examine the renamed
828 -- expression when the source or target is a renaming. However,
829 -- the renaming may be intended to capture an address that may be
830 -- affected by subsequent code, and therefore we must recover
831 -- the actual entity for the expansion that follows, not the
832 -- object it renames. In particular, if source or target designate
833 -- a portion of a dynamically allocated object, the pointer to it
834 -- may be reassigned but the renaming preserves the proper location.
837 and then
840 then
845 and then
848 then
852 -- Cases where either Forwards_OK or Backwards_OK is true
859 then
860 declare
865 begin
877 New_Occurrence_Of (
886 else
888 Expand_Assign_Array_Loop
893 -- Case of both are false with No_Implicit_Conditionals
896 declare
900 begin
907 Object_Definition =>
911 Handled_Statement_Sequence =>
919 -- Case of both are false with implicit conditionals allowed
921 else
922 -- Before we generate this code, we must ensure that the left and
923 -- right side array types are defined. They may be itypes, and we
924 -- cannot let them be defined inside the if, since the first use
925 -- in the then may not be executed.
930 -- We normally compare addresses to find out which way round to
931 -- do the loop, since this is reliable, and handles the cases of
932 -- parameters, conversions etc. But we can't do that in the bit
933 -- packed case, because addresses don't work there.
936 Condition :=
938 Left_Opnd =>
941 Prefix =>
943 Prefix =>
947 Prefix =>
948 New_Occurrence_Of
953 Right_Opnd =>
956 Prefix =>
958 Prefix =>
962 Prefix =>
963 New_Occurrence_Of
968 -- For the bit packed and VM cases we use the bounds. That's OK,
969 -- because we don't have to worry about parameters, since they
970 -- cannot cause overlap. Perhaps we should worry about weird slice
971 -- conversions ???
973 else
974 -- Copy the bounds
979 -- If the types do not match we add an implicit conversion
980 -- here to ensure proper match
983 Cright_Lo :=
987 -- Reset the Analyzed flag, because the bounds of the index
988 -- type itself may be universal, and must must be reanalyzed
989 -- to acquire the proper type for the back end.
994 Condition :=
1004 then
1006 -- Call TSS procedure for array assignment, passing the
1007 -- explicit bounds of right- and left-hand sides.
1009 declare
1014 begin
1035 else
1041 Expand_Assign_Array_Loop
1046 Expand_Assign_Array_Loop
1055 exception
1060 ------------------------------
1061 -- Expand_Assign_Array_Loop --
1062 ------------------------------
1064 -- The following is an example of the loop generated for the case of a
1065 -- two-dimensional array:
1067 -- declare
1068 -- R2b : Tm1X1 := 1;
1069 -- begin
1070 -- for L1b in 1 .. 100 loop
1071 -- declare
1072 -- R4b : Tm1X2 := 1;
1073 -- begin
1074 -- for L3b in 1 .. 100 loop
1075 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
1076 -- R4b := Tm1X2'succ(R4b);
1077 -- end loop;
1078 -- end;
1079 -- R2b := Tm1X1'succ(R2b);
1080 -- end loop;
1081 -- end;
1083 -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand
1084 -- side. The declarations of R2b and R4b are inserted before the original
1085 -- assignment statement.
1087 function Expand_Assign_Array_Loop
1095 is
1100 -- Entities used as subscripts on left and right sides
1104 -- Left and right index types
1112 -- The increment step for the index of the right-hand side is written
1113 -- as an attribute reference (Succ or Pred). This function returns
1114 -- the corresponding node, which is placed at the end of the loop body.
1116 ----------------
1117 -- Build_Step --
1118 ----------------
1124 begin
1127 else
1131 Step :=
1134 Expression =>
1136 Prefix =>
1142 -- Note that on the last iteration of the loop, the index is increased
1143 -- (or decreased) past the corresponding bound. This is consistent with
1144 -- the C semantics of the back-end, where such an off-by-one value on a
1145 -- dead index variable is OK. However, in CodePeer mode this leads to
1146 -- spurious warnings, and thus we place a guard around the attribute
1147 -- reference. For obvious reasons we only do this for CodePeer.
1150 Step :=
1152 Condition =>
1155 Right_Opnd =>
1165 -- Start of processing for Expand_Assign_Array_Loop
1167 begin
1171 else
1176 -- Setup index types and subscript entities
1178 declare
1182 begin
1198 -- Now construct the assignment statement
1200 declare
1204 begin
1210 Assign :=
1212 Name =>
1216 Expression =>
1221 -- We set assignment OK, since there are some cases, e.g. in object
1222 -- declarations, where we are actually assigning into a constant.
1223 -- If there really is an illegality, it was caught long before now,
1224 -- and was flagged when the original assignment was analyzed.
1228 -- Propagate the No_Ctrl_Actions flag to individual assignments
1233 -- Now construct the loop from the inside out, with the last subscript
1234 -- varying most rapidly. Note that Assign is first the raw assignment
1235 -- statement, and then subsequently the loop that wraps it up.
1238 Assign :=
1243 Object_Definition =>
1245 Expression =>
1250 Handled_Statement_Sequence =>
1254 Iteration_Scheme =>
1256 Loop_Parameter_Specification =>
1260 Discrete_Subtype_Definition =>
1269 --------------------------
1270 -- Expand_Assign_Record --
1271 --------------------------
1278 begin
1279 -- If change of representation, then extract the real right-hand side
1280 -- from the type conversion, and proceed with component-wise assignment,
1281 -- since the two types are not the same as far as the back end is
1282 -- concerned.
1287 -- If this may be a case of a large bit aligned component, then proceed
1288 -- with component-wise assignment, to avoid possible clobbering of other
1289 -- components sharing bits in the first or last byte of the component to
1290 -- be assigned.
1293 or
1295 then
1298 -- If we have a tagged type that has a complete record representation
1299 -- clause, we must do we must do component-wise assignments, since child
1300 -- types may have used gaps for their components, and we might be
1301 -- dealing with a view conversion.
1306 -- If neither condition met, then nothing special to do, the back end
1307 -- can handle assignment of the entire component as a single entity.
1309 else
1313 -- At this stage we know that we must do a component wise assignment
1315 declare
1322 function Find_Component
1325 -- Find the component with the given name in the underlying record
1326 -- declaration for Typ. We need to use the actual entity because the
1327 -- type may be private and resolution by identifier alone would fail.
1329 function Make_Component_List_Assign
1332 -- Returns a sequence of statements to assign the components that
1333 -- are referenced in the given component list. The flag U_U is
1334 -- used to force the usage of the inferred value of the variant
1335 -- part expression as the switch for the generated case statement.
1337 function Make_Field_Assign
1340 -- Given C, the entity for a discriminant or component, build an
1341 -- assignment for the corresponding field values. The flag U_U
1342 -- signals the presence of an Unchecked_Union and forces the usage
1343 -- of the inferred discriminant value of C as the right-hand side
1344 -- of the assignment.
1347 -- Given CI, a component items list, construct series of statements
1348 -- for fieldwise assignment of the corresponding components.
1350 --------------------
1351 -- Find_Component --
1352 --------------------
1354 function Find_Component
1357 is
1361 begin
1374 --------------------------------
1375 -- Make_Component_List_Assign --
1376 --------------------------------
1378 function Make_Component_List_Assign
1381 is
1392 begin
1409 Statements =>
1414 -- If we have an Unchecked_Union, use the value of the inferred
1415 -- discriminant of the variant part expression as the switch
1416 -- for the case statement. The case statement may later be
1417 -- folded.
1420 Expr :=
1425 else
1426 Expr :=
1429 Selector_Name =>
1442 -----------------------
1443 -- Make_Field_Assign --
1444 -----------------------
1446 function Make_Field_Assign
1449 is
1453 begin
1454 -- In the case of an Unchecked_Union, use the discriminant
1455 -- constraint value as on the right-hand side of the assignment.
1458 Expr :=
1462 else
1463 Expr :=
1469 A :=
1471 Name =>
1474 Selector_Name =>
1478 -- Set Assignment_OK, so discriminants can be assigned
1485 then
1492 ------------------------
1493 -- Make_Field_Assigns --
1494 ------------------------
1500 begin
1506 -- Look for components, but exclude _tag field assignment if
1507 -- the special Componentwise_Assignment flag is set.
1512 then
1513 Append_To
1523 -- Start of processing for Expand_Assign_Record
1525 begin
1526 -- Note that we use the base types for this processing. This results
1527 -- in some extra work in the constrained case, but the change of
1528 -- representation case is so unusual that it is not worth the effort.
1530 -- First copy the discriminants. This is done unconditionally. It
1531 -- is required in the unconstrained left side case, and also in the
1532 -- case where this assignment was constructed during the expansion
1533 -- of a type conversion (since initialization of discriminants is
1534 -- suppressed in this case). It is unnecessary but harmless in
1535 -- other cases.
1541 -- If we are expanding the initialization of a derived record
1542 -- that constrains or renames discriminants of the parent, we
1543 -- must use the corresponding discriminant in the parent.
1545 declare
1548 begin
1549 if Inside_Init_Proc
1551 then
1553 else
1559 -- Within an initialization procedure this is the
1560 -- assignment to an unchecked union component, in which
1561 -- case there is no discriminant to initialize.
1566 else
1567 -- The assignment is part of a conversion from a
1568 -- derived unchecked union type with an inferable
1569 -- discriminant, to a parent type.
1574 else
1583 -- We know the underlying type is a record, but its current view
1584 -- may be private. We must retrieve the usable record declaration.
1587 N_Private_Extension_Declaration)
1589 then
1591 else
1601 then
1605 else
1606 Insert_Actions
1615 -------------------------------------
1616 -- Expand_Assign_With_Target_Names --
1617 -------------------------------------
1626 -- The entity of the left-hand side
1629 -- Replace occurrences of the target name by the proper entity: either
1630 -- the entity of the LHS in simple cases, or the formal of the
1631 -- constructed procedure otherwise.
1633 --------------------
1634 -- Replace_Target --
1635 --------------------
1638 begin
1642 -- The expression will be reanalyzed when the enclosing assignment
1643 -- is reanalyzed, so reset the entity, which may be a temporary
1644 -- created during analysis, e.g. a loop variable for an iterated
1645 -- component association. However, if entity is callable then
1646 -- resolution has established its proper identity (including in
1647 -- rewritten prefixed calls) so we must preserve it.
1652 then
1663 -- Local variables
1668 -- Start of processing for Expand_Assign_With_Target_Names
1670 begin
1673 -- The left-hand side is a direct name
1677 then
1681 -- Generate:
1682 -- LHS := ... LHS ...;
1689 -- The left-hand side is not a direct name, but is side-effect free.
1690 -- Capture its value in a temporary to avoid multiple evaluations.
1696 -- Generate:
1697 -- T : LHS_Typ := LHS;
1705 -- Generate:
1706 -- LHS := ... T ...;
1713 -- Otherwise wrap the whole assignment statement in a procedure with an
1714 -- IN OUT parameter. The original assignment then becomes a call to the
1715 -- procedure with the left-hand side as an actual.
1717 else
1721 -- Generate:
1722 -- procedure P (T : in out LHS_Typ) is
1723 -- begin
1724 -- T := ... T ...;
1725 -- end P;
1731 Specification =>
1739 Parameter_Type =>
1744 Handled_Statement_Sequence =>
1751 -- Generate:
1752 -- P (LHS);
1760 -- Analyze rewritten node, either as assignment or procedure call
1765 -----------------------------------
1766 -- Expand_N_Assignment_Statement --
1767 -----------------------------------
1769 -- This procedure implements various cases where an assignment statement
1770 -- cannot just be passed on to the back end in untransformed state.
1780 begin
1781 -- Special case to check right away, if the Componentwise_Assignment
1782 -- flag is set, this is a reanalysis from the expansion of the primitive
1783 -- assignment procedure for a tagged type, and all we need to do is to
1784 -- expand to assignment of components, because otherwise, we would get
1785 -- infinite recursion (since this looks like a tagged assignment which
1786 -- would normally try to *call* the primitive assignment procedure).
1793 -- Defend against invalid subscripts on left side if we are in standard
1794 -- validity checking mode. No need to do this if we are checking all
1795 -- subscripts.
1797 -- Note that we do this right away, because there are some early return
1798 -- paths in this procedure, and this is required on all paths.
1800 if Validity_Checks_On
1801 and then Validity_Check_Default
1802 and then not Validity_Check_Subscripts
1803 then
1807 -- Separate expansion if RHS contain target names. Note that assignment
1808 -- may already have been expanded if RHS is aggregate.
1815 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
1817 -- Rewrite an assignment to X'Priority into a run-time call
1819 -- For example: X'Priority := New_Prio_Expr;
1820 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
1822 -- Note that although X'Priority is notionally an object, it is quite
1823 -- deliberately not defined as an aliased object in the RM. This means
1824 -- that it works fine to rewrite it as a call, without having to worry
1825 -- about complications that would other arise from X'Priority'Access,
1826 -- which is illegal, because of the lack of aliasing.
1829 declare
1836 begin
1837 -- Handle chains of renamings
1843 loop
1847 -- The attribute Priority applied to protected objects has been
1848 -- previously expanded into a call to the Get_Ceiling run-time
1849 -- subprogram. In restricted profiles this is not available.
1853 -- Look for the enclosing concurrent type
1862 -- Generate the first actual of the call
1869 -- Select the appropriate run-time call
1872 RT_Subprg_Name :=
1874 else
1875 RT_Subprg_Name :=
1879 Call :=
1894 -- Deal with assignment checks unless suppressed
1898 -- First deal with generation of range check if required
1904 -- Then generate predicate check if required
1909 -- Check for a special case where a high level transformation is
1910 -- required. If we have either of:
1912 -- P.field := rhs;
1913 -- P (sub) := rhs;
1915 -- where P is a reference to a bit packed array, then we have to unwind
1916 -- the assignment. The exact meaning of being a reference to a bit
1917 -- packed array is as follows:
1919 -- An indexed component whose prefix is a bit packed array is a
1920 -- reference to a bit packed array.
1922 -- An indexed component or selected component whose prefix is a
1923 -- reference to a bit packed array is itself a reference ot a
1924 -- bit packed array.
1926 -- The required transformation is
1928 -- Tnn : prefix_type := P;
1929 -- Tnn.field := rhs;
1930 -- P := Tnn;
1932 -- or
1934 -- Tnn : prefix_type := P;
1935 -- Tnn (subscr) := rhs;
1936 -- P := Tnn;
1938 -- Since P is going to be evaluated more than once, any subscripts
1939 -- in P must have their evaluation forced.
1943 then
1944 declare
1950 begin
1951 -- Insert the post assignment first, because we want to copy the
1952 -- BPAR_Expr tree before it gets analyzed in the context of the
1953 -- pre assignment. Note that we do not analyze the post assignment
1954 -- yet (we cannot till we have completed the analysis of the pre
1955 -- assignment). As usual, the analysis of this post assignment
1956 -- will happen on its own when we "run into" it after finishing
1957 -- the current assignment.
1964 -- At this stage BPAR_Expr is a reference to a bit packed array
1965 -- where the reference was not expanded in the original tree,
1966 -- since it was on the left side of an assignment. But in the
1967 -- pre-assignment statement (the object definition), BPAR_Expr
1968 -- will end up on the right-hand side, and must be reexpanded. To
1969 -- achieve this, we reset the analyzed flag of all selected and
1970 -- indexed components down to the actual indexed component for
1971 -- the packed array.
1974 loop
1978 N_Selected_Component)
1979 then
1981 else
1986 -- Now we can insert and analyze the pre-assignment
1988 -- If the right-hand side requires a transient scope, it has
1989 -- already been placed on the stack. However, the declaration is
1990 -- inserted in the tree outside of this scope, and must reflect
1991 -- the proper scope for its variable. This awkward bit is forced
1992 -- by the stricter scope discipline imposed by GCC 2.97.
1994 declare
1996 Scope_Is_Transient
1999 begin
2011 Pop_Scope;
2015 -- Now fix up the original assignment and continue processing
2020 -- We do not need to reanalyze that assignment, and we do not need
2021 -- to worry about references to the temporary, but we do need to
2022 -- make sure that the temporary is not marked as a true constant
2023 -- since we now have a generated assignment to it.
2029 -- When we have the appropriate type of aggregate in the expression (it
2030 -- has been determined during analysis of the aggregate by setting the
2031 -- delay flag), let's perform in place assignment and thus avoid
2032 -- creating a temporary.
2042 -- Apply discriminant check if required. If Lhs is an access type to a
2043 -- designated type with discriminants, we must always check. If the
2044 -- type has unknown discriminants, more elaborate processing below.
2048 then
2049 -- Skip discriminant check if change of representation. Will be
2050 -- done when the change of representation is expanded out.
2056 -- If the type is private without discriminants, and the full type
2057 -- has discriminants (necessarily with defaults) a check may still be
2058 -- necessary if the Lhs is aliased. The private discriminants must be
2059 -- visible to build the discriminant constraints.
2061 -- Only an explicit dereference that comes from source indicates
2062 -- aliasing. Access to formals of protected operations and entries
2063 -- create dereferences but are not semantic aliasings.
2069 then
2070 declare
2074 begin
2075 -- In the case of an expander-generated record subtype whose base
2076 -- type still appears private, Typ will have been set to that
2077 -- private type rather than the underlying record type (because
2078 -- Underlying type will have returned the record subtype), so it's
2079 -- necessary to apply Underlying_Type again to the base type to
2080 -- get the record type we need for the discriminant check. Such
2081 -- subtypes can be created for assignments in certain cases, such
2082 -- as within an instantiation passed this kind of private type.
2083 -- It would be good to avoid this special test, but making changes
2084 -- to prevent this odd form of record subtype seems difficult. ???
2096 -- If the Lhs has a private type with unknown discriminants, it may
2097 -- have a full view with discriminants, but those are nameable only
2098 -- in the underlying type, so convert the Rhs to it before potential
2099 -- checking. Convert Lhs as well, otherwise the actual subtype might
2100 -- not be constructible. If the discriminants have defaults the type
2101 -- is unconstrained and there is nothing to check.
2106 then
2111 -- In the access type case, we need the same discriminant check, and
2112 -- also range checks if we have an access to constrained array.
2116 then
2119 -- Skip discriminant check if change of representation. Will be
2120 -- done when the change of representation is expanded out.
2134 declare
2138 begin
2139 C_Es :=
2140 Get_Range_Checks
2142 Target_Typ,
2145 Insert_Range_Checks
2147 N,
2148 Target_Typ,
2150 Lhs);
2155 -- Apply range check for access type case
2160 then
2162 Apply_Range_Check
2166 -- Ada 2005 (AI-231): Generate the run-time check
2172 -- If an actual is an out parameter of a null-excluding access
2173 -- type, there is access check on entry, so we set the flag
2174 -- Suppress_Assignment_Checks on the generated statement to
2175 -- assign the actual to the parameter block, and we do not want
2176 -- to generate an additional check at this point.
2179 then
2183 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2184 -- stand-alone obj of an anonymous access type. Do not install the check
2185 -- when the Lhs denotes a container cursor and the Next function employs
2186 -- an access type, because this can never result in a dangling pointer.
2192 then
2193 declare
2195 -- Look through renames to find the underlying entity.
2196 -- For assignment to a rename, we don't care about the
2197 -- Enclosing_Dynamic_Scope of the rename declaration.
2199 ----------------
2200 -- Lhs_Entity --
2201 ----------------
2206 begin
2209 -- Renamed_Object must return an Entity_Name here
2210 -- because of preceding "Present (E_E_A (...))" test.
2218 -- Local Declarations
2222 Condition =>
2224 Left_Opnd =>
2226 Right_Opnd =>
2228 Intval =>
2229 Scope_Depth
2230 (Enclosing_Dynamic_Scope
2236 Name =>
2237 New_Occurrence_Of
2238 (Effective_Extra_Accessibility
2240 Expression =>
2243 begin
2252 -- Case of assignment to a bit packed array element. If there is a
2253 -- change of representation this must be expanded into components,
2254 -- otherwise this is a bit-field assignment.
2258 then
2259 -- Normal case, no change of representation
2265 -- Change of representation case
2267 else
2268 -- Generate the following, to force component-by-component
2269 -- assignments in an efficient way. Otherwise each component
2270 -- will require a temporary and two bit-field manipulations.
2272 -- T1 : Elmt_Type;
2273 -- T1 := RhS;
2274 -- Lhs := T1;
2276 declare
2280 begin
2281 Stats :=
2282 New_List (
2285 Object_Definition =>
2300 -- Build-in-place function call case. Note that we're not yet doing
2301 -- build-in-place for user-written assignment statements (the assignment
2302 -- here came from an aggregate.)
2306 then
2311 then
2316 begin
2317 -- In the controlled case, we ensure that function calls are
2318 -- evaluated before finalizing the target. In all cases, it makes
2319 -- the expansion easier if the side effects are removed first.
2324 -- Avoid recursion in the mechanism
2328 -- If dispatching assignment, we need to dispatch to _assign
2332 -- If the type is tagged, we may as well use the predefined
2333 -- primitive assignment. This avoids inlining a lot of code
2334 -- and in the class-wide case, the assignment is replaced
2335 -- by a dispatching call to _assign. It is suppressed in the
2336 -- case of assignments created by the expander that correspond
2337 -- to initializations, where we do want to copy the tag
2338 -- (Expand_Ctrl_Actions flag is set False in this case). It is
2339 -- also suppressed if restriction No_Dispatching_Calls is in
2340 -- force because in that case predefined primitives are not
2341 -- generated.
2345 and then Expand_Ctrl_Actions
2346 and then
2348 then
2351 -- This can happen in an instance when the formal is an
2352 -- extension of a limited interface, and the actual is
2353 -- limited. This is an error according to AI05-0087, but
2354 -- is not caught at the point of instantiation in earlier
2355 -- versions.
2357 -- This is wrong, error messages cannot be issued during
2358 -- expansion, since they would be missed in -gnatc mode ???
2364 -- Fetch the primitive op _assign and proper type to call it.
2365 -- Because of possible conflicts between private and full view,
2366 -- fetch the proper type directly from the operation profile.
2368 declare
2373 begin
2374 -- If the assignment is dispatching, make sure to use the
2375 -- proper type.
2383 -- In case of assignment to a class-wide tagged type, before
2384 -- the assignment we generate run-time check to ensure that
2385 -- the tags of source and target match.
2391 then
2392 declare
2396 begin
2398 Lhs_Tag :=
2401 Selector_Name =>
2403 Rhs_Tag :=
2406 Selector_Name =>
2408 else
2409 -- Displace the pointer to the base of the objects
2410 -- applying 'Address, which is later expanded into
2411 -- a call to RE_Base_Address.
2413 Lhs_Tag :=
2415 Prefix =>
2420 Rhs_Tag :=
2422 Prefix =>
2431 Condition =>
2439 declare
2443 begin
2444 -- In order to dispatch the call to _assign the type of
2445 -- the actuals must match. Add conversion (if required).
2464 else
2467 -- We can't afford to have destructive Finalization Actions in
2468 -- the Self assignment case, so if the target and the source
2469 -- are not obviously different, code is generated to avoid the
2470 -- self assignment case:
2472 -- if lhs'address /= rhs'address then
2473 -- <code for controlled and/or tagged assignment>
2474 -- end if;
2476 -- Skip this if Restriction (No_Finalization) is active
2479 and then Expand_Ctrl_Actions
2481 then
2484 Condition =>
2486 Left_Opnd =>
2491 Right_Opnd =>
2499 -- We need to set up an exception handler for implementing
2500 -- 7.6.1(18). The remaining adjustments are tackled by the
2501 -- implementation of adjust for record_controllers (see
2502 -- s-finimp.adb).
2504 -- This is skipped if we have no finalization
2506 if Expand_Ctrl_Actions
2508 then
2511 Handled_Statement_Sequence =>
2521 Handled_Statement_Sequence =>
2524 -- If no restrictions on aborts, protect the whole assignment
2525 -- for controlled objects as per 9.8(11).
2528 and then Expand_Ctrl_Actions
2529 and then Abort_Allowed
2530 then
2531 declare
2533 New_Internal_Entity
2537 begin
2548 -- Present the Abort_Undefer_Direct function to the backend
2549 -- so that it can inline the call to the function.
2553 Expand_At_End_Handler
2558 -- N has been rewritten to a block statement for which it is
2559 -- known by construction that no checks are necessary: analyze
2560 -- it with all checks suppressed.
2566 -- Array types
2569 declare
2572 begin
2574 N_Qualified_Expression)
2575 loop
2583 -- Record types
2589 -- Scalar types. This is where we perform the processing related to the
2590 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
2591 -- scalar values.
2595 -- Case where right side is known valid
2599 -- Here the right side is valid, so it is fine. The case to deal
2600 -- with is when the left side is a local variable reference whose
2601 -- value is not currently known to be valid. If this is the case,
2602 -- and the assignment appears in an unconditional context, then
2603 -- we can mark the left side as now being valid if one of these
2604 -- conditions holds:
2606 -- The expression of the right side has Do_Range_Check set so
2607 -- that we know a range check will be performed. Note that it
2608 -- can be the case that a range check is omitted because we
2609 -- make the assumption that we can assume validity for operands
2610 -- appearing in the right side in determining whether a range
2611 -- check is required
2613 -- The subtype of the right side matches the subtype of the
2614 -- left side. In this case, even though we have not checked
2615 -- the range of the right side, we know it is in range of its
2616 -- subtype if the expression is valid.
2621 then
2624 then
2629 -- Case where right side may be invalid in the sense of the RM
2630 -- reference above. The RM does not require that we check for the
2631 -- validity on an assignment, but it does require that the assignment
2632 -- of an invalid value not cause erroneous behavior.
2634 -- The general approach in GNAT is to use the Is_Known_Valid flag
2635 -- to avoid the need for validity checking on assignments. However
2636 -- in some cases, we have to do validity checking in order to make
2637 -- sure that the setting of this flag is correct.
2639 else
2640 -- Validate right side if we are validating copies
2642 if Validity_Checks_On
2643 and then Validity_Check_Copies
2644 then
2645 -- Skip this if left-hand side is an array or record component
2646 -- and elementary component validity checks are suppressed.
2649 and then not Validity_Check_Components
2650 then
2652 else
2656 -- We can propagate this to the left side where appropriate
2661 then
2665 -- Otherwise check to see what should be done
2667 -- If left side is a local variable, then we just set its flag to
2668 -- indicate that its value may no longer be valid, since we are
2669 -- copying a potentially invalid value.
2674 -- Check for case of a nonlocal variable on the left side which
2675 -- is currently known to be valid. In this case, we simply ensure
2676 -- that the right side is valid. We only play the game of copying
2677 -- validity status for local variables, since we are doing this
2678 -- statically, not by tracing the full flow graph.
2682 then
2683 -- Note: If Validity_Checking mode is set to none, we ignore
2684 -- the Ensure_Valid call so don't worry about that case here.
2688 -- In all other cases, we can safely copy an invalid value without
2689 -- worrying about the status of the left side. Since it is not a
2690 -- variable reference it will not be considered
2691 -- as being known to be valid in any case.
2693 else
2699 exception
2704 ------------------------------
2705 -- Expand_N_Block_Statement --
2706 ------------------------------
2708 -- Encode entity names defined in block statement
2711 begin
2715 -----------------------------
2716 -- Expand_N_Case_Statement --
2717 -----------------------------
2728 begin
2729 -- Check for the situation where we know at compile time which branch
2730 -- will be taken.
2732 -- If the value is static but its subtype is predicated and the value
2733 -- does not obey the predicate, the value is marked non-static, and
2734 -- there can be no corresponding static alternative. In that case we
2735 -- replace the case statement with an exception, regardless of whether
2736 -- assertions are enabled or not, unless predicates are ignored.
2742 then
2751 then
2754 -- Do not consider controlled objects found in a case statement which
2755 -- actually models a case expression because their early finalization
2756 -- will affect the result of the expression.
2762 -- Move statements from this alternative after the case statement.
2763 -- They are already analyzed, so will be skipped by the analyzer.
2767 -- That leaves the case statement as a shell. So now we can kill all
2768 -- other alternatives in the case statement.
2772 declare
2775 begin
2776 -- Loop through case alternatives, skipping pragmas, and skipping
2777 -- the one alternative that we select (and therefore retain).
2783 then
2795 -- Here if the choice is not determined at compile time
2797 declare
2806 begin
2810 else
2814 -- First step is to worry about possible invalid argument. The RM
2815 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
2816 -- outside the base range), then Constraint_Error must be raised.
2818 -- Case of validity check required (validity checks are on, the
2819 -- expression is not known to be valid, and the case statement
2820 -- comes from source -- no need to validity check internally
2821 -- generated case statements).
2823 if Validity_Check_Default
2825 then
2829 -- If there is only a single alternative, just replace it with the
2830 -- sequence of statements since obviously that is what is going to
2831 -- be executed in all cases.
2837 -- We still need to evaluate the expression if it has any side
2838 -- effects.
2843 -- Do not consider controlled objects found in a case statement
2844 -- which actually models a case expression because their early
2845 -- finalization will affect the result of the expression.
2853 -- That leaves the case statement as a shell. The alternative that
2854 -- will be executed is reset to a null list. So now we can kill
2855 -- the entire case statement.
2861 -- An optimization. If there are only two alternatives, and only
2862 -- a single choice, then rewrite the whole case statement as an
2863 -- if statement, since this can result in subsequent optimizations.
2864 -- This helps not only with case statements in the source of a
2865 -- simple form, but also with generated code (discriminant check
2866 -- functions in particular).
2868 -- Note: it is OK to do this before expanding out choices for any
2869 -- static predicates, since the if statement processing will handle
2870 -- the static predicate case fine.
2881 -- For TRUE, generate "expression", not expression = true
2885 then
2888 -- For FALSE, generate "expression" and switch then/else
2892 then
2897 -- For a range, generate "expression in range"
2904 then
2905 Cond :=
2910 -- A subtype indication is not a legal operator in a membership
2911 -- test, so retrieve its range.
2914 Cond :=
2917 Right_Opnd =>
2918 Relocate_Node
2921 -- For any other subexpression "expression = value"
2923 else
2924 Cond :=
2930 -- Now rewrite the case as an IF
2942 -- If the last alternative is not an Others choice, replace it with
2943 -- an N_Others_Choice. Note that we do not bother to call Analyze on
2944 -- the modified case statement, since it's only effect would be to
2945 -- compute the contents of the Others_Discrete_Choices which is not
2946 -- needed by the back end anyway.
2948 -- The reason for this is that the back end always needs some default
2949 -- for a switch, so if we have not supplied one in the processing
2950 -- above for validity checking, then we need to supply one here.
2955 -- If Predicates_Ignored is true the value does not satisfy the
2956 -- predicate, and there is no Others choice, Constraint_Error
2957 -- must be raised (4.5.7 (21/3)).
2960 declare
2970 begin
2975 else
2976 Set_Others_Discrete_Choices
2983 -- Deal with possible declarations of controlled objects, and also
2984 -- with rewriting choice sequences for static predicate references.
2989 -- Do not consider controlled objects found in a case statement
2990 -- which actually models a case expression because their early
2991 -- finalization will affect the result of the expression.
3006 -----------------------------
3007 -- Expand_N_Exit_Statement --
3008 -----------------------------
3010 -- The only processing required is to deal with a possible C/Fortran
3011 -- boolean value used as the condition for the exit statement.
3014 begin
3018 ----------------------------------
3019 -- Expand_Formal_Container_Loop --
3020 ----------------------------------
3035 begin
3036 -- The expansion resembles the one for Ada containers, but the
3037 -- primitives mention the domain of iteration explicitly, and
3038 -- function First applied to the container yields a cursor directly.
3040 -- Cursor : Cursor_type := First (Container);
3041 -- while Has_Element (Cursor, Container) loop
3042 -- <original loop statements>
3043 -- Cursor := Next (Container, Cursor);
3044 -- end loop;
3046 Build_Formal_Container_Iteration
3052 -- Build block to capture declaration of cursor entity.
3054 Blk_Nod :=
3057 Handled_Statement_Sequence =>
3065 ------------------------------------------
3066 -- Expand_Formal_Container_Element_Loop --
3067 ------------------------------------------
3091 begin
3092 -- For an element iterator, the Element aspect must be present,
3093 -- (this is checked during analysis) and the expansion takes the form:
3095 -- Cursor : Cursor_Type := First (Container);
3096 -- Elmt : Element_Type;
3097 -- while Has_Element (Cursor, Container) loop
3098 -- Elmt := Element (Container, Cursor);
3099 -- <original loop statements>
3100 -- Cursor := Next (Container, Cursor);
3101 -- end loop;
3103 -- However this expansion is not legal if the element is indefinite.
3104 -- In that case we create a block to hold a variable declaration
3105 -- initialized with a call to Element, and generate:
3107 -- Cursor : Cursor_Type := First (Container);
3108 -- while Has_Element (Cursor, Container) loop
3109 -- declare
3110 -- Elmt : Element_Type := Element (Container, Cursor);
3111 -- begin
3112 -- <original loop statements>
3113 -- Cursor := Next (Container, Cursor);
3114 -- end;
3115 -- end loop;
3117 Build_Formal_Container_Iteration
3124 -- Declaration for Element
3126 Elmt_Decl :=
3140 New_List
3143 Handled_Statement_Sequence =>
3147 else
3148 Elmt_Ref :=
3151 Expression =>
3160 -- The element is assignable in the expanded code
3164 -- The loop is rewritten as a block, to hold the element declaration
3166 New_Loop :=
3169 Handled_Statement_Sequence =>
3174 -- The element is only modified in expanded code, so it appears as
3175 -- unassigned to the warning machinery. We must suppress this spurious
3176 -- warning explicitly.
3182 -- The loop parameter is declared by an object declaration, but within
3183 -- the loop we must prevent user assignments to it, so we analyze the
3184 -- declaration and reset the entity kind, before analyzing the rest of
3185 -- the loop;
3193 -----------------------------
3194 -- Expand_N_Goto_Statement --
3195 -----------------------------
3197 -- Add poll before goto if polling active
3200 begin
3204 ---------------------------
3205 -- Expand_N_If_Statement --
3206 ---------------------------
3208 -- First we deal with the case of C and Fortran convention boolean values,
3209 -- with zero/non-zero semantics.
3211 -- Second, we deal with the obvious rewriting for the cases where the
3212 -- condition of the IF is known at compile time to be True or False.
3214 -- Third, we remove elsif parts which have non-empty Condition_Actions and
3215 -- rewrite as independent if statements. For example:
3217 -- if x then xs
3218 -- elsif y then ys
3219 -- ...
3220 -- end if;
3222 -- becomes
3223 --
3224 -- if x then xs
3225 -- else
3226 -- <<condition actions of y>>
3227 -- if y then ys
3228 -- ...
3229 -- end if;
3230 -- end if;
3232 -- This rewriting is needed if at least one elsif part has a non-empty
3233 -- Condition_Actions list. We also do the same processing if there is a
3234 -- constant condition in an elsif part (in conjunction with the first
3235 -- processing step mentioned above, for the recursive call made to deal
3236 -- with the created inner if, this deals with properly optimizing the
3237 -- cases of constant elsif conditions).
3247 -- Indicates whether we want warnings when we delete branches of the
3248 -- if statement based on constant condition analysis. We never want
3249 -- these warnings for expander generated code.
3251 begin
3252 -- Do not consider controlled objects found in an if statement which
3253 -- actually models an if expression because their early finalization
3254 -- will affect the result of the expression.
3262 -- The following loop deals with constant conditions for the IF. We
3263 -- need a loop because as we eliminate False conditions, we grab the
3264 -- first elsif condition and use it as the primary condition.
3268 -- If condition is True, we can simply rewrite the if statement now
3269 -- by replacing it by the series of then statements.
3273 -- All the else parts can be killed
3283 -- If condition is False, then we can delete the condition and
3284 -- the Then statements
3286 else
3287 -- We do not delete the condition if constant condition warnings
3288 -- are enabled, since otherwise we end up deleting the desired
3289 -- warning. Of course the backend will get rid of this True/False
3290 -- test anyway, so nothing is lost here.
3298 -- If there are no elsif statements, then we simply replace the
3299 -- entire if statement by the sequence of else statements.
3304 then
3307 else
3315 -- If there are elsif statements, the first of them becomes the
3316 -- if/then section of the rebuilt if statement This is the case
3317 -- where we loop to reprocess this copied condition.
3319 else
3325 -- Hed might have been captured as the condition determining
3326 -- the current value for an entity. Now it is detached from
3327 -- the tree, so a Current_Value pointer in the condition might
3328 -- need to be updated.
3339 -- Loop through elsif parts, dealing with constant conditions and
3340 -- possible condition actions that are present.
3346 -- Do not consider controlled objects found in an if statement
3347 -- which actually models an if expression because their early
3348 -- finalization will affect the result of the expression.
3356 -- If there are condition actions, then rewrite the if statement
3357 -- as indicated above. We also do the same rewrite for a True or
3358 -- False condition. The further processing of this constant
3359 -- condition is then done by the recursive call to expand the
3360 -- newly created if statement
3364 then
3365 New_If :=
3372 -- Elsif parts for new if come from remaining elsif's of parent
3396 -- Note this is not an implicit if statement, since it is part
3397 -- of an explicit if statement in the source (or of an implicit
3398 -- if statement that has already been tested). We set the flag
3399 -- after calling Analyze to avoid generating extra warnings
3400 -- specific to pure if statements, however (see
3401 -- Sem_Ch5.Analyze_If_Statement).
3406 -- No special processing for that elsif part, move to next
3408 else
3414 -- Some more optimizations applicable if we still have an IF statement
3420 -- Another optimization, special cases that can be simplified
3422 -- if expression then
3423 -- return true;
3424 -- else
3425 -- return false;
3426 -- end if;
3428 -- can be changed to:
3430 -- return expression;
3432 -- and
3434 -- if expression then
3435 -- return false;
3436 -- else
3437 -- return true;
3438 -- end if;
3440 -- can be changed to:
3442 -- return not (expression);
3444 -- Only do these optimizations if we are at least at -O1 level and
3445 -- do not do them if control flow optimizations are suppressed.
3449 then
3455 then
3456 declare
3460 begin
3462 and then
3464 then
3465 declare
3469 begin
3471 and then
3473 then
3476 then
3485 then
3488 Expression =>
3490 Right_Opnd =>
3503 --------------------------
3504 -- Expand_Iterator_Loop --
3505 --------------------------
3514 begin
3515 -- Processing for arrays
3524 else
3528 -- Processing for containers
3530 else
3531 Expand_Iterator_Loop_Over_Container
3536 -------------------------------------
3537 -- Expand_Iterator_Loop_Over_Array --
3538 -------------------------------------
3554 -- Start of processing for Expand_Iterator_Loop_Over_Array
3556 begin
3557 -- for Element of Array loop
3559 -- It requires an internally generated cursor to iterate over the array
3565 -- Generate:
3566 -- Element : Component_Type renames Array (Iterator);
3567 -- Iterator is the index value, or a list of index values
3568 -- in the case of a multidimensional array.
3570 Ind_Comp :=
3578 Subtype_Mark =>
3582 -- Mark the loop variable as needing debug info, so that expansion
3583 -- of the renaming will result in Materialize_Entity getting set via
3584 -- Debug_Renaming_Declaration. (This setting is needed here because
3585 -- the setting in Freeze_Entity comes after the expansion, which is
3586 -- too late. ???)
3590 -- Generate:
3592 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
3593 -- Element : Component_Type renames Array (Iterator);
3594 -- <original loop statements>
3595 -- end loop;
3597 -- If this is an iteration over a multidimensional array, the
3598 -- innermost loop is over the last dimension in Ada, and over
3599 -- the first dimension in Fortran.
3603 else
3607 Core_Loop :=
3609 Iteration_Scheme =>
3611 Loop_Parameter_Specification =>
3614 Discrete_Subtype_Definition =>
3624 -- Processing for multidimensional array. The body of each loop is
3625 -- a loop over a previous dimension, going in decreasing order in Ada
3626 -- and in increasing order in Fortran.
3632 else
3638 -- Generate the dimension loops starting from the innermost one
3640 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
3641 -- <core loop>
3642 -- end loop;
3644 Core_Loop :=
3646 Iteration_Scheme =>
3648 Loop_Parameter_Specification =>
3651 Discrete_Subtype_Definition =>
3661 -- Update the previously created object renaming declaration with
3662 -- the new iterator, by adding the index of the next loop to the
3663 -- indexed component, in the order that corresponds to the
3664 -- convention.
3669 else
3676 -- Inherit the loop identifier from the original loop. This ensures that
3677 -- the scope stack is consistent after the rewriting.
3687 -----------------------------------------
3688 -- Expand_Iterator_Loop_Over_Container --
3689 -----------------------------------------
3691 -- For a 'for ... in' loop, such as:
3693 -- for Cursor in Iterator_Function (...) loop
3694 -- ...
3695 -- end loop;
3697 -- we generate:
3699 -- Iter : Iterator_Type := Iterator_Function (...);
3700 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
3701 -- while Has_Element (Cursor) loop
3702 -- ...
3703 --
3704 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3705 -- end loop;
3707 -- For a 'for ... of' loop, such as:
3709 -- for X of Container loop
3710 -- ...
3711 -- end loop;
3713 -- the RM implies the generation of:
3715 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
3716 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
3717 -- while Has_Element (Cursor) loop
3718 -- declare
3719 -- X : Element_Type renames Element (Cursor).Element.all;
3720 -- -- or Constant_Element
3721 -- begin
3722 -- ...
3723 -- end;
3724 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3725 -- end loop;
3727 -- In the general case, we do what the RM says. However, the operations
3728 -- Element and Iter.Next are slow, which is bad inside a loop, because they
3729 -- involve dispatching via interfaces, secondary stack manipulation,
3730 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
3731 -- predefined containers, we use an equivalent but optimized expansion.
3733 -- In the optimized case, we make use of these:
3735 -- procedure Next (Position : in out Cursor); -- instead of Iter.Next
3737 -- function Pseudo_Reference
3738 -- (Container : aliased Vector'Class) return Reference_Control_Type;
3740 -- type Element_Access is access all Element_Type;
3742 -- function Get_Element_Access
3743 -- (Position : Cursor) return not null Element_Access;
3745 -- Next is declared in the visible part of the container packages.
3746 -- The other three are added in the private part. (We're not supposed to
3747 -- pollute the namespace for clients. The compiler has no trouble breaking
3748 -- privacy to call things in the private part of an instance.)
3750 -- Source:
3752 -- for X of My_Vector loop
3753 -- X.Count := X.Count + 1;
3754 -- ...
3755 -- end loop;
3757 -- The compiler will generate:
3759 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector);
3760 -- -- Reversible_Iterator is an interface. Iterate is the
3761 -- -- Default_Iterator aspect of Vector. This increments Lock,
3762 -- -- disallowing tampering with cursors. Unfortunately, it does not
3763 -- -- increment Busy. The result of Iterate is Limited_Controlled;
3764 -- -- finalization will decrement Lock. This is a build-in-place
3765 -- -- dispatching call to Iterate.
3767 -- Cur : Cursor := First (Iter); -- or Last
3768 -- -- Dispatching call via interface.
3770 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
3771 -- -- Pseudo_Reference increments Busy, to detect tampering with
3772 -- -- elements, as required by RM. Also redundantly increment
3773 -- -- Lock. Finalization of Control will decrement both Busy and
3774 -- -- Lock. Pseudo_Reference returns a record containing a pointer to
3775 -- -- My_Vector, used by Finalize.
3776 -- --
3777 -- -- Control is not used below, except to finalize it -- it's purely
3778 -- -- an RAII thing. This is needed because we are eliminating the
3779 -- -- call to Reference within the loop.
3781 -- while Has_Element (Cur) loop
3782 -- declare
3783 -- X : My_Element renames Get_Element_Access (Cur).all;
3784 -- -- Get_Element_Access returns a pointer to the element
3785 -- -- designated by Cur. No dispatching here, and no horsing
3786 -- -- around with access discriminants. This is instead of the
3787 -- -- existing
3788 -- --
3789 -- -- X : My_Element renames Reference (Cur).Element.all;
3790 -- --
3791 -- -- which creates a controlled object.
3792 -- begin
3793 -- -- Any attempt to tamper with My_Vector here in the loop
3794 -- -- will correctly raise Program_Error, because of the
3795 -- -- Control.
3796 --
3797 -- X.Count := X.Count + 1;
3798 -- ...
3799 --
3800 -- Next (Cur); -- or Prev
3801 -- -- This is instead of "Cur := Next (Iter, Cur);"
3802 -- end;
3803 -- -- No finalization here
3804 -- end loop;
3805 -- Finalize Iter and Control here, decrementing Lock twice and Busy
3806 -- once.
3808 -- This optimization makes "for ... of" loops over 30 times faster in cases
3809 -- measured.
3811 procedure Expand_Iterator_Loop_Over_Container
3817 is
3834 -- Only for optimized version of "for ... of"
3837 -- The package in which the iterator interface is instantiated. This is
3838 -- typically an instance within the container package.
3841 -- The package in which the container type is declared
3843 begin
3844 -- Determine the advancement and initialization steps for the cursor.
3845 -- Analysis of the expanded loop will verify that the container has a
3846 -- reverse iterator.
3851 else
3856 -- The type of the iterator is the return type of the Iterate function
3857 -- used. For the "of" form this is the default iterator for the type,
3858 -- otherwise it is the type of the explicit function used in the
3859 -- iterator specification. The most common case will be an Iterate
3860 -- function in the container package.
3862 -- The Iterator type is declared in an instance within the container
3863 -- package itself, for example:
3865 -- package Vector_Iterator_Interfaces is new
3866 -- Ada.Iterator_Interfaces (Cursor, Has_Element);
3868 -- If the container type is a derived type, the cursor type is found in
3869 -- the package of the ultimate ancestor type.
3873 else
3881 function Get_Default_Iterator
3883 -- If the container is a derived type, the aspect holds the parent
3884 -- operation. The required one is a primitive of the derived type
3885 -- and is either inherited or overridden. Also sets Container_Arg.
3887 --------------------------
3888 -- Get_Default_Iterator --
3889 --------------------------
3891 function Get_Default_Iterator
3893 is
3899 begin
3902 -- A previous version of GNAT allowed indexing aspects to
3903 -- be redefined on derived container types, while the
3904 -- default iterator was inherited from the parent type.
3905 -- This non-standard extension is preserved temporarily for
3906 -- use by the modelling project under debug flag d.X.
3911 then
3912 Container_Arg :=
3914 Subtype_Mark =>
3915 New_Occurrence_Of
3924 -- The default iterator must be a primitive operation of the
3925 -- type, at the same dispatch slot position. The DT position
3926 -- may not be established if type is not frozen yet.
3933 or else
3937 then
3944 -- Default iterator must exist
3948 -- Otherwise not a derived type
3950 else
3955 -- Local variables
3963 -- Start of processing for Handle_Of
3965 begin
3967 Default_Iter :=
3969 else
3975 -- For a container element iterator, the iterator type is obtained
3976 -- from the corresponding aspect, whose return type is descended
3977 -- from the corresponding interface type in some instance of
3978 -- Ada.Iterator_Interfaces. The actuals of that instantiation
3979 -- are Cursor and Has_Element.
3983 -- The iterator type, which is a class-wide type, may itself be
3984 -- derived locally, so the desired instantiation is the scope of
3985 -- the root type of the iterator type.
3989 -- Find declarations needed for "for ... of" optimization
3998 then
4013 then
4017 Object_Definition =>
4019 Expression =>
4021 Name =>
4023 Parameter_Associations =>
4027 -- Rewrite domain of iteration as a call to the default iterator
4028 -- for the container type. The formal may be an access parameter
4029 -- in which case we must build a reference to the container.
4031 declare
4033 begin
4035 Arg :=
4039 else
4045 Name =>
4052 -- Find cursor type in proper iterator package, which is an
4053 -- instantiation of Iterator_Interfaces.
4066 Decl :=
4069 Subtype_Mark =>
4071 Name =>
4073 Prefix =>
4075 Name =>
4077 Parameter_Associations =>
4080 else
4081 Decl :=
4084 Subtype_Mark =>
4086 Name =>
4089 Expressions =>
4093 -- The defining identifier in the iterator is user-visible and
4094 -- must be visible in the debugger.
4098 -- If the container does not have a variable indexing aspect,
4099 -- the element is a constant in the loop. The container itself
4100 -- may be constant, in which case the element is a constant as
4101 -- well. The container has been rewritten as a call to Iterate,
4102 -- so examine original node.
4107 then
4114 -- X in Iterate (S) : type of iterator is type of explicitly given
4115 -- Iterate function, and the loop variable is the cursor. It will be
4116 -- assigned in the loop and must be a variable.
4118 else
4121 -- The iterator type, which is a class-wide type, may itself be
4122 -- derived locally, so the desired instantiation is the scope of
4123 -- the root type of the iterator type, as in the "of" case.
4131 -- For both iterator forms, add a call to the step operation to advance
4132 -- the cursor. Generate:
4134 -- Cursor := Iterator.Next (Cursor);
4136 -- or else
4138 -- Cursor := Next (Cursor);
4141 declare
4145 begin
4146 Step_Call :=
4148 Name =>
4156 else
4157 declare
4160 begin
4161 Rhs :=
4163 Name =>
4178 -- Generate:
4179 -- while Has_Element (Cursor) loop
4180 -- <Stats>
4181 -- end loop;
4183 -- Has_Element is the second actual in the iterator package
4185 New_Loop :=
4187 Iteration_Scheme =>
4189 Condition =>
4191 Name =>
4192 New_Occurrence_Of
4200 -- If present, preserve identifier of loop, which can be used in an exit
4201 -- statement in the body.
4207 -- Create the declarations for Iterator and cursor and insert them
4208 -- before the source loop. Given that the domain of iteration is already
4209 -- an entity, the iterator is just a renaming of that entity. Possible
4210 -- optimization ???
4218 -- Create declaration for cursor
4220 declare
4224 Object_Definition =>
4226 Expression =>
4228 Prefix =>
4230 Selector_Name =>
4233 begin
4234 -- The cursor is only modified in expanded code, so it appears
4235 -- as unassigned to the warning machinery. We must suppress this
4236 -- spurious warning explicitly. The cursor's kind is that of the
4237 -- original loop parameter (it is a constant if the domain of
4238 -- iteration is constant).
4247 -- If the range of iteration is given by a function call that returns
4248 -- a container, the finalization actions have been saved in the
4249 -- Condition_Actions of the iterator. Insert them now at the head of
4250 -- the loop.
4260 -----------------------------
4261 -- Expand_N_Loop_Statement --
4262 -----------------------------
4264 -- 1. Remove null loop entirely
4265 -- 2. Deal with while condition for C/Fortran boolean
4266 -- 3. Deal with loops with a non-standard enumeration type range
4267 -- 4. Deal with while loops where Condition_Actions is set
4268 -- 5. Deal with loops over predicated subtypes
4269 -- 6. Deal with loops with iterators over arrays and containers
4270 -- 7. Insert polling call if required
4277 begin
4278 -- Delete null loop
4285 -- Deal with condition for C/Fortran Boolean
4291 -- Generate polling call
4297 -- Nothing more to do for plain loop with no iteration scheme
4302 -- Case of for loop (Loop_Parameter_Specification present)
4304 -- Note: we do not have to worry about validity checking of the for loop
4305 -- range bounds here, since they were frozen with constant declarations
4306 -- and it is during that process that the validity checking is done.
4309 declare
4319 begin
4320 -- Deal with loop over predicates
4324 then
4327 -- Handle the case where we have a for loop with the range type
4328 -- being an enumeration type with non-standard representation.
4329 -- In this case we expand:
4331 -- for x in [reverse] a .. b loop
4332 -- ...
4333 -- end loop;
4335 -- to
4337 -- for xP in [reverse] integer
4338 -- range etype'Pos (a) .. etype'Pos (b)
4339 -- loop
4340 -- declare
4341 -- x : constant etype := Pos_To_Rep (xP);
4342 -- begin
4343 -- ...
4344 -- end;
4345 -- end loop;
4349 then
4350 New_Id :=
4354 -- If the type has a contiguous representation, successive
4355 -- values can be generated as offsets from the first literal.
4358 Expr :=
4361 Left_Opnd =>
4365 else
4366 -- Use the constructed array Enum_Pos_To_Rep
4368 Expr :=
4370 Prefix =>
4372 Expressions =>
4376 -- Build declaration for loop identifier
4378 Decls :=
4379 New_List (
4390 Iteration_Scheme =>
4392 Loop_Parameter_Specification =>
4397 Discrete_Subtype_Definition =>
4400 Subtype_Mark =>
4403 Constraint =>
4405 Range_Expression =>
4408 Low_Bound =>
4410 Prefix =>
4416 Relocate_Node
4419 High_Bound =>
4421 Prefix =>
4427 Relocate_Node
4428 (Type_High_Bound
4434 Handled_Statement_Sequence =>
4440 -- The loop parameter's entity must be removed from the loop
4441 -- scope's entity list and rendered invisible, since it will
4442 -- now be located in the new block scope. Any other entities
4443 -- already associated with the loop scope, such as the loop
4444 -- parameter's subtype, will remain there.
4446 -- In an element loop, the loop will contain a declaration for
4447 -- a cursor variable; otherwise the loop id is the first entity
4448 -- in the scope constructed for the loop.
4464 -- Nothing to do with other cases of for loops
4466 else
4471 -- Second case, if we have a while loop with Condition_Actions set, then
4472 -- we change it into a plain loop:
4474 -- while C loop
4475 -- ...
4476 -- end loop;
4478 -- changed to:
4480 -- loop
4481 -- <<condition actions>>
4482 -- exit when not C;
4483 -- ...
4484 -- end loop
4489 then
4490 declare
4493 begin
4494 ES :=
4496 Condition =>
4503 -- This is not an implicit loop, since it is generated in response
4504 -- to the loop statement being processed. If this is itself
4505 -- implicit, the restriction has already been checked. If not,
4506 -- it is an explicit loop.
4517 -- Here to deal with iterator case
4521 then
4524 -- An iterator loop may generate renaming declarations for elements
4525 -- that require debug information. This is the case in particular
4526 -- with element iterators, where debug information must be generated
4527 -- for the temporary that holds the element value. These temporaries
4528 -- are created within a transient block whose local declarations are
4529 -- transferred to the loop, which now has nontrivial local objects.
4533 then
4538 -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
4539 -- is transformed into a conditional block where the original loop is
4540 -- the sole statement. Inspect the statements of the nested loop for
4541 -- controlled objects.
4552 ----------------------------
4553 -- Expand_Predicated_Loop --
4554 ----------------------------
4556 -- Note: the expander can handle generation of loops over predicated
4557 -- subtypes for both the dynamic and static cases. Depending on what
4558 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
4559 -- mode, the semantic analyzer may disallow one or both forms.
4570 begin
4571 -- Case of iteration over non-static predicate, should not be possible
4572 -- since this is not allowed by the semantics and should have been
4573 -- caught during analysis of the loop statement.
4578 -- If the predicate list is empty, that corresponds to a predicate of
4579 -- False, in which case the loop won't run at all, and we rewrite the
4580 -- entire loop as a null statement.
4586 -- For expansion over a static predicate we generate the following
4588 -- declare
4589 -- J : Ltype := min-val;
4590 -- begin
4591 -- loop
4592 -- body
4593 -- case J is
4594 -- when endpoint => J := startpoint;
4595 -- when endpoint => J := startpoint;
4596 -- ...
4597 -- when max-val => exit;
4598 -- when others => J := Lval'Succ (J);
4599 -- end case;
4600 -- end loop;
4601 -- end;
4603 -- with min-val replaced by max-val and Succ replaced by Pred if the
4604 -- loop parameter specification carries a Reverse indicator.
4606 -- To make this a little clearer, let's take a specific example:
4608 -- type Int is range 1 .. 10;
4609 -- subtype StaticP is Int with
4610 -- predicate => StaticP in 3 | 10 | 5 .. 7;
4611 -- ...
4612 -- for L in StaticP loop
4613 -- Put_Line ("static:" & J'Img);
4614 -- end loop;
4616 -- In this case, the loop is transformed into
4618 -- begin
4619 -- J : L := 3;
4620 -- loop
4621 -- body
4622 -- case J is
4623 -- when 3 => J := 5;
4624 -- when 7 => J := 10;
4625 -- when 10 => exit;
4626 -- when others => J := L'Succ (J);
4627 -- end case;
4628 -- end loop;
4629 -- end;
4631 else
4640 -- Given static expression or static range, returns an identifier
4641 -- whose value is the low bound of the expression value or range.
4644 -- Given static expression or static range, returns an identifier
4645 -- whose value is the high bound of the expression value or range.
4647 ------------
4648 -- Hi_Val --
4649 ------------
4652 begin
4655 else
4661 ------------
4662 -- Lo_Val --
4663 ------------
4666 begin
4669 else
4675 -- Start of processing for Static_Predicate
4677 begin
4678 -- Convert loop identifier to normal variable and reanalyze it so
4679 -- that this conversion works. We have to use the same defining
4680 -- identifier, since there may be references in the loop body.
4685 -- In most loops the loop variable is assigned in various
4686 -- alternatives in the body. However, in the rare case when
4687 -- the range specifies a single element, the loop variable
4688 -- may trigger a spurious warning that is could be constant.
4689 -- This warning might as well be suppressed.
4693 -- Loop to create branches of case statement
4699 -- Initial value is largest value in predicate.
4701 D :=
4711 else
4712 S :=
4727 else
4729 -- Initial value is smallest value in predicate.
4731 D :=
4741 else
4742 S :=
4758 -- Add others choice
4760 declare
4763 begin
4766 else
4770 S :=
4773 Expression =>
4787 -- Construct case statement and append to body statements
4789 Cstm :=
4795 -- Rewrite the loop
4802 Handled_Statement_Sequence =>
4814 ------------------------------
4815 -- Make_Tag_Ctrl_Assignment --
4816 ------------------------------
4829 and then not Comp_Asn
4836 begin
4837 -- Finalize the target of the assignment when controlled
4839 -- We have two exceptions here:
4841 -- 1. If we are in an init proc since it is an initialization more
4842 -- than an assignment.
4844 -- 2. If the left-hand side is a temporary that was not initialized
4845 -- (or the parent part of a temporary since it is the case in
4846 -- extension aggregates). Such a temporary does not come from
4847 -- source. We must examine the original node for the prefix, because
4848 -- it may be a component of an entry formal, in which case it has
4849 -- been rewritten and does not appear to come from source either.
4851 -- Case of init proc
4856 -- The left-hand side is an uninitialized temporary object
4861 N_Object_Declaration
4863 then
4866 else
4867 Fin_Call :=
4868 Make_Final_Call
4877 -- Save the Tag in a local variable Tag_Id
4886 Expression =>
4889 Selector_Name =>
4892 -- Otherwise Tag_Id is not used
4894 else
4898 -- If the tagged type has a full rep clause, expand the assignment into
4899 -- component-wise assignments. Mark the node as unanalyzed in order to
4900 -- generate the proper code and propagate this scenario by setting a
4901 -- flag to avoid infinite recursion.
4910 -- Restore the tag
4915 Name =>
4918 Selector_Name =>
4923 -- Adjust the target after the assignment when controlled (not in the
4924 -- init proc since it is an initialization more than an assignment).
4927 Adj_Call :=
4928 Make_Adjust_Call
4939 exception
4941 -- Could use comment here ???