| blob | d8d22d02af961f160383402cec0e58e52e3bfbfb |
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-2017, 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 =>
214 Name =>
223 ------------------------------
224 -- Change_Of_Representation --
225 ------------------------------
229 begin
230 return
232 and then
236 -------------------------
237 -- Expand_Assign_Array --
238 -------------------------
240 -- There are two issues here. First, do we let Gigi do a block move, or
241 -- do we expand out into a loop? Second, we need to set the two flags
242 -- Forwards_OK and Backwards_OK which show whether the block move (or
243 -- corresponding loops) can be legitimately done in a forwards (low to
244 -- high) or backwards (high to low) manner.
270 -- This switch is set to True if the array move must be done using
271 -- an explicit front end generated loop.
274 -- If the argument is an access to an array, and the assignment is
275 -- converted into a procedure call, apply explicit dereference.
278 -- Test if Exp is a reference to an array whose declaration has
279 -- an address clause, or it is a slice of such an array.
282 -- Test if Exp is a reference to an array which is either a formal
283 -- parameter or a slice of a formal parameter. These are the cases
284 -- where hidden aliasing can occur.
287 -- Determine if Exp is a reference to an array variable which is other
288 -- than an object defined in the current scope, or a component or a
289 -- slice of such an object. Such objects can be aliased to parameters
290 -- (unlike local array references).
292 -----------------------
293 -- Apply_Dereference --
294 -----------------------
298 begin
306 ------------------------
307 -- Has_Address_Clause --
308 ------------------------
311 begin
312 return
315 or else
319 ---------------------
320 -- Is_Formal_Array --
321 ---------------------
324 begin
325 return
327 or else
331 ------------------------
332 -- Is_Non_Local_Array --
333 ------------------------
336 begin
338 when N_Indexed_Component
339 | N_Selected_Component
340 | N_Slice
341 =>
345 return
351 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
359 -- Start of processing for Expand_Assign_Array
361 begin
362 -- Deal with length check. Note that the length check is done with
363 -- respect to the right-hand side as given, not a possible underlying
364 -- renamed object, since this would generate incorrect extra checks.
368 -- We start by assuming that the move can be done in either direction,
369 -- i.e. that the two sides are completely disjoint.
374 -- Normally it is only the slice case that can lead to overlap, and
375 -- explicit checks for slices are made below. But there is one case
376 -- where the slice can be implicit and invisible to us: when we have a
377 -- one dimensional array, and either both operands are parameters, or
378 -- one is a parameter (which can be a slice passed by reference) and the
379 -- other is a non-local variable. In this case the parameter could be a
380 -- slice that overlaps with the other operand.
382 -- However, if the array subtype is a constrained first subtype in the
383 -- parameter case, then we don't have to worry about overlap, since
384 -- slice assignments aren't possible (other than for a slice denoting
385 -- the whole array).
387 -- Note: No overlap is possible if there is a change of representation,
388 -- so we can exclude this case.
391 and then not Crep
392 and then
394 or else
396 or else
398 and then
401 then
405 -- Note: the bit-packed case is not worrisome here, since if we have
406 -- a slice passed as a parameter, it is always aligned on a byte
407 -- boundary, and if there are no explicit slices, the assignment
408 -- can be performed directly.
411 -- If either operand has an address clause clear Backwards_OK and
412 -- Forwards_OK, since we cannot tell if the operands overlap. We
413 -- exclude this treatment when Rhs is an aggregate, since we know
414 -- that overlap can't occur.
418 then
423 -- We certainly must use a loop for change of representation and also
424 -- we use the operand of the conversion on the right-hand side as the
425 -- effective right-hand side (the component types must match in this
426 -- situation).
433 -- We require a loop if the left side is possibly bit unaligned
436 or else
438 then
441 -- Arrays with controlled components are expanded into a loop to force
442 -- calls to Adjust at the component level.
447 -- If object is atomic/VFA, we cannot tolerate a loop
450 or else
452 then
455 -- Loop is required if we have atomic components since we have to
456 -- be sure to do any accesses on an element by element basis.
462 then
465 -- Case where no slice is involved
469 -- The following code deals with the case of unconstrained bit packed
470 -- arrays. The problem is that the template for such arrays contains
471 -- the bounds of the actual source level array, but the copy of an
472 -- entire array requires the bounds of the underlying array. It would
473 -- be nice if the back end could take care of this, but right now it
474 -- does not know how, so if we have such a type, then we expand out
475 -- into a loop, which is inefficient but works correctly. If we don't
476 -- do this, we get the wrong length computed for the array to be
477 -- moved. The two cases we need to worry about are:
479 -- Explicit dereference of an unconstrained packed array type as in
480 -- the following example:
482 -- procedure C52 is
483 -- type BITS is array(INTEGER range <>) of BOOLEAN;
484 -- pragma PACK(BITS);
485 -- type A is access BITS;
486 -- P1,P2 : A;
487 -- begin
488 -- P1 := new BITS (1 .. 65_535);
489 -- P2 := new BITS (1 .. 65_535);
490 -- P2.ALL := P1.ALL;
491 -- end C52;
493 -- A formal parameter reference with an unconstrained bit array type
494 -- is the other case we need to worry about (here we assume the same
495 -- BITS type declared above):
497 -- procedure Write_All (File : out BITS; Contents : BITS);
498 -- begin
499 -- File.Storage := Contents;
500 -- end Write_All;
502 -- We expand to a loop in either of these two cases
504 -- Question for future thought. Another potentially more efficient
505 -- approach would be to create the actual subtype, and then do an
506 -- unchecked conversion to this actual subtype ???
511 -- Function to perform required test for the first case, above
512 -- (dereference of an unconstrained bit packed array).
514 -----------------------
515 -- Is_UBPA_Reference --
516 -----------------------
523 begin
527 then
536 else
538 return
543 else
548 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
550 begin
552 or else
554 then
557 -- Here if we do not have the case of a reference to a bit packed
558 -- unconstrained array case. In this case gigi can most certainly
559 -- handle the assignment if a forwards move is allowed.
561 -- (could it handle the backwards case also???)
568 -- The back end can always handle the assignment if the right side is a
569 -- string literal (note that overlap is definitely impossible in this
570 -- case). If the type is packed, a string literal is always converted
571 -- into an aggregate, except in the case of a null slice, for which no
572 -- aggregate can be written. In that case, rewrite the assignment as a
573 -- null statement, a length check has already been emitted to verify
574 -- that the range of the left-hand side is empty.
576 -- Note that this code is not executed if we have an assignment of a
577 -- string literal to a non-bit aligned component of a record, a case
578 -- which cannot be handled by the backend.
583 then
590 -- If either operand is bit packed, then we need a loop, since we can't
591 -- be sure that the slice is byte aligned. Similarly, if either operand
592 -- is a possibly unaligned slice, then we need a loop (since the back
593 -- end cannot handle unaligned slices).
599 then
602 -- If we are not bit-packed, and we have only one slice, then no overlap
603 -- is possible except in the parameter case, so we can let the back end
604 -- handle things.
612 -- If the right-hand side is a string literal, introduce a temporary for
613 -- it, for use in the generated loop that will follow.
616 declare
620 begin
621 Decl :=
633 -- Come here to complete the analysis
635 -- Loop_Required: Set to True if we know that a loop is required
636 -- regardless of overlap considerations.
638 -- Forwards_OK: Set to False if we already know that a forwards
639 -- move is not safe, else set to True.
641 -- Backwards_OK: Set to False if we already know that a backwards
642 -- move is not safe, else set to True
644 -- Our task at this stage is to complete the overlap analysis, which can
645 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
646 -- then generating the final code, either by deciding that it is OK
647 -- after all to let Gigi handle it, or by generating appropriate code
648 -- in the front end.
650 declare
668 begin
669 -- Get the expressions for the arrays. If we are dealing with a
670 -- private type, then convert to the underlying type. We can do
671 -- direct assignments to an array that is a private type, but we
672 -- cannot assign to elements of the array without this extra
673 -- unchecked conversion.
675 -- Note: We propagate Parent to the conversion nodes to generate
676 -- a well-formed subtree.
680 else
684 declare
686 begin
687 Larray :=
688 Unchecked_Convert_To
697 else
701 declare
703 begin
704 Rarray :=
705 Unchecked_Convert_To
712 -- If both sides are slices, we must figure out whether it is safe
713 -- to do the move in one direction or the other. It is always safe
714 -- if there is a change of representation since obviously two arrays
715 -- with different representations cannot possibly overlap.
721 -- If both left- and right-hand arrays are entity names, and refer
722 -- to different entities, then we know that the move is safe (the
723 -- two storage areas are completely disjoint).
728 then
731 -- Otherwise, we assume the worst, which is that the two arrays
732 -- are the same array. There is no need to check if we know that
733 -- is the case, because if we don't know it, we still have to
734 -- assume it.
736 -- Generally if the same array is involved, then we have an
737 -- overlapping case. We will have to really assume the worst (i.e.
738 -- set neither of the OK flags) unless we can determine the lower
739 -- or upper bounds at compile time and compare them.
741 else
742 Cresult :=
743 Compile_Time_Compare
747 Cresult :=
748 Compile_Time_Compare
766 -- If after that analysis Loop_Required is False, meaning that we
767 -- have not discovered some non-overlap reason for requiring a loop,
768 -- then the outcome depends on the capabilities of the back end.
771 -- Assume the back end can deal with all cases of overlap by
772 -- falling back to memmove if it cannot use a more efficient
773 -- approach.
778 -- At this stage we have to generate an explicit loop, and we have
779 -- the following cases:
781 -- Forwards_OK = True
783 -- Rnn : right_index := right_index'First;
784 -- for Lnn in left-index loop
785 -- left (Lnn) := right (Rnn);
786 -- Rnn := right_index'Succ (Rnn);
787 -- end loop;
789 -- Note: the above code MUST be analyzed with checks off, because
790 -- otherwise the Succ could overflow. But in any case this is more
791 -- efficient.
793 -- Forwards_OK = False, Backwards_OK = True
795 -- Rnn : right_index := right_index'Last;
796 -- for Lnn in reverse left-index loop
797 -- left (Lnn) := right (Rnn);
798 -- Rnn := right_index'Pred (Rnn);
799 -- end loop;
801 -- Note: the above code MUST be analyzed with checks off, because
802 -- otherwise the Pred could overflow. But in any case this is more
803 -- efficient.
805 -- Forwards_OK = Backwards_OK = False
807 -- This only happens if we have the same array on each side. It is
808 -- possible to create situations using overlays that violate this,
809 -- but we simply do not promise to get this "right" in this case.
811 -- There are two possible subcases. If the No_Implicit_Conditionals
812 -- restriction is set, then we generate the following code:
814 -- declare
815 -- T : constant <operand-type> := rhs;
816 -- begin
817 -- lhs := T;
818 -- end;
820 -- If implicit conditionals are permitted, then we generate:
822 -- if Left_Lo <= Right_Lo then
823 -- <code for Forwards_OK = True above>
824 -- else
825 -- <code for Backwards_OK = True above>
826 -- end if;
828 -- In order to detect possible aliasing, we examine the renamed
829 -- expression when the source or target is a renaming. However,
830 -- the renaming may be intended to capture an address that may be
831 -- affected by subsequent code, and therefore we must recover
832 -- the actual entity for the expansion that follows, not the
833 -- object it renames. In particular, if source or target designate
834 -- a portion of a dynamically allocated object, the pointer to it
835 -- may be reassigned but the renaming preserves the proper location.
838 and then
841 then
846 and then
849 then
853 -- Cases where either Forwards_OK or Backwards_OK is true
860 then
861 declare
866 begin
878 New_Occurrence_Of (
887 else
889 Expand_Assign_Array_Loop
894 -- Case of both are false with No_Implicit_Conditionals
897 declare
901 begin
908 Object_Definition =>
912 Handled_Statement_Sequence =>
920 -- Case of both are false with implicit conditionals allowed
922 else
923 -- Before we generate this code, we must ensure that the left and
924 -- right side array types are defined. They may be itypes, and we
925 -- cannot let them be defined inside the if, since the first use
926 -- in the then may not be executed.
931 -- We normally compare addresses to find out which way round to
932 -- do the loop, since this is reliable, and handles the cases of
933 -- parameters, conversions etc. But we can't do that in the bit
934 -- packed case, because addresses don't work there.
937 Condition :=
939 Left_Opnd =>
942 Prefix =>
944 Prefix =>
948 Prefix =>
949 New_Occurrence_Of
954 Right_Opnd =>
957 Prefix =>
959 Prefix =>
963 Prefix =>
964 New_Occurrence_Of
969 -- For the bit packed and VM cases we use the bounds. That's OK,
970 -- because we don't have to worry about parameters, since they
971 -- cannot cause overlap. Perhaps we should worry about weird slice
972 -- conversions ???
974 else
975 -- Copy the bounds
980 -- If the types do not match we add an implicit conversion
981 -- here to ensure proper match
984 Cright_Lo :=
988 -- Reset the Analyzed flag, because the bounds of the index
989 -- type itself may be universal, and must must be reanalyzed
990 -- to acquire the proper type for the back end.
995 Condition :=
1005 then
1007 -- Call TSS procedure for array assignment, passing the
1008 -- explicit bounds of right- and left-hand sides.
1010 declare
1015 begin
1036 else
1042 Expand_Assign_Array_Loop
1047 Expand_Assign_Array_Loop
1056 exception
1061 ------------------------------
1062 -- Expand_Assign_Array_Loop --
1063 ------------------------------
1065 -- The following is an example of the loop generated for the case of a
1066 -- two-dimensional array:
1068 -- declare
1069 -- R2b : Tm1X1 := 1;
1070 -- begin
1071 -- for L1b in 1 .. 100 loop
1072 -- declare
1073 -- R4b : Tm1X2 := 1;
1074 -- begin
1075 -- for L3b in 1 .. 100 loop
1076 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
1077 -- R4b := Tm1X2'succ(R4b);
1078 -- end loop;
1079 -- end;
1080 -- R2b := Tm1X1'succ(R2b);
1081 -- end loop;
1082 -- end;
1084 -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand
1085 -- side. The declarations of R2b and R4b are inserted before the original
1086 -- assignment statement.
1088 function Expand_Assign_Array_Loop
1096 is
1101 -- Entities used as subscripts on left and right sides
1105 -- Left and right index types
1113 -- The increment step for the index of the right-hand side is written
1114 -- as an attribute reference (Succ or Pred). This function returns
1115 -- the corresponding node, which is placed at the end of the loop body.
1117 ----------------
1118 -- Build_Step --
1119 ----------------
1125 begin
1128 else
1132 Step :=
1135 Expression =>
1137 Prefix =>
1143 -- Note that on the last iteration of the loop, the index is increased
1144 -- (or decreased) past the corresponding bound. This is consistent with
1145 -- the C semantics of the back-end, where such an off-by-one value on a
1146 -- dead index variable is OK. However, in CodePeer mode this leads to
1147 -- spurious warnings, and thus we place a guard around the attribute
1148 -- reference. For obvious reasons we only do this for CodePeer.
1151 Step :=
1153 Condition =>
1156 Right_Opnd =>
1166 -- Start of processing for Expand_Assign_Array_Loop
1168 begin
1172 else
1177 -- Setup index types and subscript entities
1179 declare
1183 begin
1199 -- Now construct the assignment statement
1201 declare
1205 begin
1211 Assign :=
1213 Name =>
1217 Expression =>
1222 -- We set assignment OK, since there are some cases, e.g. in object
1223 -- declarations, where we are actually assigning into a constant.
1224 -- If there really is an illegality, it was caught long before now,
1225 -- and was flagged when the original assignment was analyzed.
1229 -- Propagate the No_Ctrl_Actions flag to individual assignments
1234 -- Now construct the loop from the inside out, with the last subscript
1235 -- varying most rapidly. Note that Assign is first the raw assignment
1236 -- statement, and then subsequently the loop that wraps it up.
1239 Assign :=
1244 Object_Definition =>
1246 Expression =>
1251 Handled_Statement_Sequence =>
1255 Iteration_Scheme =>
1257 Loop_Parameter_Specification =>
1261 Discrete_Subtype_Definition =>
1270 --------------------------
1271 -- Expand_Assign_Record --
1272 --------------------------
1279 begin
1280 -- If change of representation, then extract the real right-hand side
1281 -- from the type conversion, and proceed with component-wise assignment,
1282 -- since the two types are not the same as far as the back end is
1283 -- concerned.
1288 -- If this may be a case of a large bit aligned component, then proceed
1289 -- with component-wise assignment, to avoid possible clobbering of other
1290 -- components sharing bits in the first or last byte of the component to
1291 -- be assigned.
1294 or
1296 then
1299 -- If we have a tagged type that has a complete record representation
1300 -- clause, we must do we must do component-wise assignments, since child
1301 -- types may have used gaps for their components, and we might be
1302 -- dealing with a view conversion.
1307 -- If neither condition met, then nothing special to do, the back end
1308 -- can handle assignment of the entire component as a single entity.
1310 else
1314 -- At this stage we know that we must do a component wise assignment
1316 declare
1323 function Find_Component
1326 -- Find the component with the given name in the underlying record
1327 -- declaration for Typ. We need to use the actual entity because the
1328 -- type may be private and resolution by identifier alone would fail.
1330 function Make_Component_List_Assign
1333 -- Returns a sequence of statements to assign the components that
1334 -- are referenced in the given component list. The flag U_U is
1335 -- used to force the usage of the inferred value of the variant
1336 -- part expression as the switch for the generated case statement.
1338 function Make_Field_Assign
1341 -- Given C, the entity for a discriminant or component, build an
1342 -- assignment for the corresponding field values. The flag U_U
1343 -- signals the presence of an Unchecked_Union and forces the usage
1344 -- of the inferred discriminant value of C as the right-hand side
1345 -- of the assignment.
1348 -- Given CI, a component items list, construct series of statements
1349 -- for fieldwise assignment of the corresponding components.
1351 --------------------
1352 -- Find_Component --
1353 --------------------
1355 function Find_Component
1358 is
1362 begin
1375 --------------------------------
1376 -- Make_Component_List_Assign --
1377 --------------------------------
1379 function Make_Component_List_Assign
1382 is
1393 begin
1410 Statements =>
1415 -- If we have an Unchecked_Union, use the value of the inferred
1416 -- discriminant of the variant part expression as the switch
1417 -- for the case statement. The case statement may later be
1418 -- folded.
1421 Expr :=
1426 else
1427 Expr :=
1430 Selector_Name =>
1443 -----------------------
1444 -- Make_Field_Assign --
1445 -----------------------
1447 function Make_Field_Assign
1450 is
1455 begin
1456 -- The discriminant entity to be used in the retrieval below must
1457 -- be one in the corresponding type, given that the assignment may
1458 -- be between derived and parent types.
1462 else
1466 -- In the case of an Unchecked_Union, use the discriminant
1467 -- constraint value as on the right-hand side of the assignment.
1470 Expr :=
1474 else
1475 Expr :=
1481 A :=
1483 Name =>
1486 Selector_Name =>
1490 -- Set Assignment_OK, so discriminants can be assigned
1497 then
1504 ------------------------
1505 -- Make_Field_Assigns --
1506 ------------------------
1512 begin
1518 -- Look for components, but exclude _tag field assignment if
1519 -- the special Componentwise_Assignment flag is set.
1524 then
1525 Append_To
1535 -- Start of processing for Expand_Assign_Record
1537 begin
1538 -- Note that we use the base types for this processing. This results
1539 -- in some extra work in the constrained case, but the change of
1540 -- representation case is so unusual that it is not worth the effort.
1542 -- First copy the discriminants. This is done unconditionally. It
1543 -- is required in the unconstrained left side case, and also in the
1544 -- case where this assignment was constructed during the expansion
1545 -- of a type conversion (since initialization of discriminants is
1546 -- suppressed in this case). It is unnecessary but harmless in
1547 -- other cases.
1553 -- If we are expanding the initialization of a derived record
1554 -- that constrains or renames discriminants of the parent, we
1555 -- must use the corresponding discriminant in the parent.
1557 declare
1560 begin
1561 if Inside_Init_Proc
1563 then
1565 else
1571 -- Within an initialization procedure this is the
1572 -- assignment to an unchecked union component, in which
1573 -- case there is no discriminant to initialize.
1578 else
1579 -- The assignment is part of a conversion from a
1580 -- derived unchecked union type with an inferable
1581 -- discriminant, to a parent type.
1586 else
1594 -- If the derived type has a stored constraint, assign the value
1595 -- of the corresponding discriminants explicitly, skipping those
1596 -- that are renamed discriminants. We cannot just retrieve them
1597 -- from the Rhs by selected component because they are invisible
1598 -- in the type of the right-hand side.
1601 declare
1605 begin
1612 and then
1615 E_Discriminant)
1616 then
1617 Assign :=
1619 Name =>
1622 Selector_Name =>
1623 New_Occurrence_Of
1638 -- We know the underlying type is a record, but its current view
1639 -- may be private. We must retrieve the usable record declaration.
1642 N_Private_Extension_Declaration)
1644 then
1646 else
1656 then
1660 else
1661 Insert_Actions
1670 -------------------------------------
1671 -- Expand_Assign_With_Target_Names --
1672 -------------------------------------
1681 -- The entity of the left-hand side
1684 -- Replace occurrences of the target name by the proper entity: either
1685 -- the entity of the LHS in simple cases, or the formal of the
1686 -- constructed procedure otherwise.
1688 --------------------
1689 -- Replace_Target --
1690 --------------------
1693 begin
1697 -- The expression will be reanalyzed when the enclosing assignment
1698 -- is reanalyzed, so reset the entity, which may be a temporary
1699 -- created during analysis, e.g. a loop variable for an iterated
1700 -- component association. However, if entity is callable then
1701 -- resolution has established its proper identity (including in
1702 -- rewritten prefixed calls) so we must preserve it.
1707 then
1718 -- Local variables
1723 -- Start of processing for Expand_Assign_With_Target_Names
1725 begin
1728 -- The left-hand side is a direct name
1732 then
1736 -- Generate:
1737 -- LHS := ... LHS ...;
1744 -- The left-hand side is not a direct name, but is side-effect free.
1745 -- Capture its value in a temporary to avoid multiple evaluations.
1751 -- Generate:
1752 -- T : LHS_Typ := LHS;
1760 -- Generate:
1761 -- LHS := ... T ...;
1768 -- Otherwise wrap the whole assignment statement in a procedure with an
1769 -- IN OUT parameter. The original assignment then becomes a call to the
1770 -- procedure with the left-hand side as an actual.
1772 else
1776 -- Generate:
1777 -- procedure P (T : in out LHS_Typ) is
1778 -- begin
1779 -- T := ... T ...;
1780 -- end P;
1786 Specification =>
1794 Parameter_Type =>
1799 Handled_Statement_Sequence =>
1806 -- Generate:
1807 -- P (LHS);
1815 -- Analyze rewritten node, either as assignment or procedure call
1820 -----------------------------------
1821 -- Expand_N_Assignment_Statement --
1822 -----------------------------------
1824 -- This procedure implements various cases where an assignment statement
1825 -- cannot just be passed on to the back end in untransformed state.
1835 begin
1836 -- Special case to check right away, if the Componentwise_Assignment
1837 -- flag is set, this is a reanalysis from the expansion of the primitive
1838 -- assignment procedure for a tagged type, and all we need to do is to
1839 -- expand to assignment of components, because otherwise, we would get
1840 -- infinite recursion (since this looks like a tagged assignment which
1841 -- would normally try to *call* the primitive assignment procedure).
1848 -- Defend against invalid subscripts on left side if we are in standard
1849 -- validity checking mode. No need to do this if we are checking all
1850 -- subscripts.
1852 -- Note that we do this right away, because there are some early return
1853 -- paths in this procedure, and this is required on all paths.
1855 if Validity_Checks_On
1856 and then Validity_Check_Default
1857 and then not Validity_Check_Subscripts
1858 then
1862 -- Separate expansion if RHS contain target names. Note that assignment
1863 -- may already have been expanded if RHS is aggregate.
1870 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
1872 -- Rewrite an assignment to X'Priority into a run-time call
1874 -- For example: X'Priority := New_Prio_Expr;
1875 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
1877 -- Note that although X'Priority is notionally an object, it is quite
1878 -- deliberately not defined as an aliased object in the RM. This means
1879 -- that it works fine to rewrite it as a call, without having to worry
1880 -- about complications that would other arise from X'Priority'Access,
1881 -- which is illegal, because of the lack of aliasing.
1884 declare
1891 begin
1892 -- Handle chains of renamings
1898 loop
1902 -- The attribute Priority applied to protected objects has been
1903 -- previously expanded into a call to the Get_Ceiling run-time
1904 -- subprogram. In restricted profiles this is not available.
1908 -- Look for the enclosing concurrent type
1917 -- Generate the first actual of the call
1924 -- Select the appropriate run-time call
1927 RT_Subprg_Name :=
1929 else
1930 RT_Subprg_Name :=
1934 Call :=
1949 -- Deal with assignment checks unless suppressed
1953 -- First deal with generation of range check if required
1959 -- Then generate predicate check if required
1964 -- Check for a special case where a high level transformation is
1965 -- required. If we have either of:
1967 -- P.field := rhs;
1968 -- P (sub) := rhs;
1970 -- where P is a reference to a bit packed array, then we have to unwind
1971 -- the assignment. The exact meaning of being a reference to a bit
1972 -- packed array is as follows:
1974 -- An indexed component whose prefix is a bit packed array is a
1975 -- reference to a bit packed array.
1977 -- An indexed component or selected component whose prefix is a
1978 -- reference to a bit packed array is itself a reference ot a
1979 -- bit packed array.
1981 -- The required transformation is
1983 -- Tnn : prefix_type := P;
1984 -- Tnn.field := rhs;
1985 -- P := Tnn;
1987 -- or
1989 -- Tnn : prefix_type := P;
1990 -- Tnn (subscr) := rhs;
1991 -- P := Tnn;
1993 -- Since P is going to be evaluated more than once, any subscripts
1994 -- in P must have their evaluation forced.
1998 then
1999 declare
2005 begin
2006 -- Insert the post assignment first, because we want to copy the
2007 -- BPAR_Expr tree before it gets analyzed in the context of the
2008 -- pre assignment. Note that we do not analyze the post assignment
2009 -- yet (we cannot till we have completed the analysis of the pre
2010 -- assignment). As usual, the analysis of this post assignment
2011 -- will happen on its own when we "run into" it after finishing
2012 -- the current assignment.
2019 -- At this stage BPAR_Expr is a reference to a bit packed array
2020 -- where the reference was not expanded in the original tree,
2021 -- since it was on the left side of an assignment. But in the
2022 -- pre-assignment statement (the object definition), BPAR_Expr
2023 -- will end up on the right-hand side, and must be reexpanded. To
2024 -- achieve this, we reset the analyzed flag of all selected and
2025 -- indexed components down to the actual indexed component for
2026 -- the packed array.
2029 loop
2033 N_Selected_Component)
2034 then
2036 else
2041 -- Now we can insert and analyze the pre-assignment
2043 -- If the right-hand side requires a transient scope, it has
2044 -- already been placed on the stack. However, the declaration is
2045 -- inserted in the tree outside of this scope, and must reflect
2046 -- the proper scope for its variable. This awkward bit is forced
2047 -- by the stricter scope discipline imposed by GCC 2.97.
2049 declare
2051 Scope_Is_Transient
2054 begin
2066 Pop_Scope;
2070 -- Now fix up the original assignment and continue processing
2075 -- We do not need to reanalyze that assignment, and we do not need
2076 -- to worry about references to the temporary, but we do need to
2077 -- make sure that the temporary is not marked as a true constant
2078 -- since we now have a generated assignment to it.
2084 -- When we have the appropriate type of aggregate in the expression (it
2085 -- has been determined during analysis of the aggregate by setting the
2086 -- delay flag), let's perform in place assignment and thus avoid
2087 -- creating a temporary.
2097 -- Apply discriminant check if required. If Lhs is an access type to a
2098 -- designated type with discriminants, we must always check. If the
2099 -- type has unknown discriminants, more elaborate processing below.
2103 then
2104 -- Skip discriminant check if change of representation. Will be
2105 -- done when the change of representation is expanded out.
2111 -- If the type is private without discriminants, and the full type
2112 -- has discriminants (necessarily with defaults) a check may still be
2113 -- necessary if the Lhs is aliased. The private discriminants must be
2114 -- visible to build the discriminant constraints.
2116 -- Only an explicit dereference that comes from source indicates
2117 -- aliasing. Access to formals of protected operations and entries
2118 -- create dereferences but are not semantic aliasings.
2124 then
2125 declare
2129 begin
2130 -- In the case of an expander-generated record subtype whose base
2131 -- type still appears private, Typ will have been set to that
2132 -- private type rather than the underlying record type (because
2133 -- Underlying type will have returned the record subtype), so it's
2134 -- necessary to apply Underlying_Type again to the base type to
2135 -- get the record type we need for the discriminant check. Such
2136 -- subtypes can be created for assignments in certain cases, such
2137 -- as within an instantiation passed this kind of private type.
2138 -- It would be good to avoid this special test, but making changes
2139 -- to prevent this odd form of record subtype seems difficult. ???
2151 -- If the Lhs has a private type with unknown discriminants, it may
2152 -- have a full view with discriminants, but those are nameable only
2153 -- in the underlying type, so convert the Rhs to it before potential
2154 -- checking. Convert Lhs as well, otherwise the actual subtype might
2155 -- not be constructible. If the discriminants have defaults the type
2156 -- is unconstrained and there is nothing to check.
2161 then
2166 -- In the access type case, we need the same discriminant check, and
2167 -- also range checks if we have an access to constrained array.
2171 then
2174 -- Skip discriminant check if change of representation. Will be
2175 -- done when the change of representation is expanded out.
2189 declare
2193 begin
2194 C_Es :=
2195 Get_Range_Checks
2197 Target_Typ,
2200 Insert_Range_Checks
2202 N,
2203 Target_Typ,
2205 Lhs);
2210 -- Apply range check for access type case
2215 then
2217 Apply_Range_Check
2221 -- Ada 2005 (AI-231): Generate the run-time check
2227 -- If an actual is an out parameter of a null-excluding access
2228 -- type, there is access check on entry, so we set the flag
2229 -- Suppress_Assignment_Checks on the generated statement to
2230 -- assign the actual to the parameter block, and we do not want
2231 -- to generate an additional check at this point.
2234 then
2238 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2239 -- stand-alone obj of an anonymous access type. Do not install the check
2240 -- when the Lhs denotes a container cursor and the Next function employs
2241 -- an access type, because this can never result in a dangling pointer.
2247 then
2248 declare
2250 -- Look through renames to find the underlying entity.
2251 -- For assignment to a rename, we don't care about the
2252 -- Enclosing_Dynamic_Scope of the rename declaration.
2254 ----------------
2255 -- Lhs_Entity --
2256 ----------------
2261 begin
2264 -- Renamed_Object must return an Entity_Name here
2265 -- because of preceding "Present (E_E_A (...))" test.
2273 -- Local Declarations
2277 Condition =>
2279 Left_Opnd =>
2281 Right_Opnd =>
2283 Intval =>
2284 Scope_Depth
2285 (Enclosing_Dynamic_Scope
2291 Name =>
2292 New_Occurrence_Of
2293 (Effective_Extra_Accessibility
2295 Expression =>
2298 begin
2307 -- Case of assignment to a bit packed array element. If there is a
2308 -- change of representation this must be expanded into components,
2309 -- otherwise this is a bit-field assignment.
2313 then
2314 -- Normal case, no change of representation
2320 -- Change of representation case
2322 else
2323 -- Generate the following, to force component-by-component
2324 -- assignments in an efficient way. Otherwise each component
2325 -- will require a temporary and two bit-field manipulations.
2327 -- T1 : Elmt_Type;
2328 -- T1 := RhS;
2329 -- Lhs := T1;
2331 declare
2335 begin
2336 Stats :=
2337 New_List (
2340 Object_Definition =>
2355 -- Build-in-place function call case. Note that we're not yet doing
2356 -- build-in-place for user-written assignment statements (the assignment
2357 -- here came from an aggregate.)
2361 then
2366 then
2371 begin
2372 -- In the controlled case, we ensure that function calls are
2373 -- evaluated before finalizing the target. In all cases, it makes
2374 -- the expansion easier if the side effects are removed first.
2379 -- Avoid recursion in the mechanism
2383 -- If dispatching assignment, we need to dispatch to _assign
2387 -- If the type is tagged, we may as well use the predefined
2388 -- primitive assignment. This avoids inlining a lot of code
2389 -- and in the class-wide case, the assignment is replaced
2390 -- by a dispatching call to _assign. It is suppressed in the
2391 -- case of assignments created by the expander that correspond
2392 -- to initializations, where we do want to copy the tag
2393 -- (Expand_Ctrl_Actions flag is set False in this case). It is
2394 -- also suppressed if restriction No_Dispatching_Calls is in
2395 -- force because in that case predefined primitives are not
2396 -- generated.
2400 and then Expand_Ctrl_Actions
2401 and then
2403 then
2406 -- This can happen in an instance when the formal is an
2407 -- extension of a limited interface, and the actual is
2408 -- limited. This is an error according to AI05-0087, but
2409 -- is not caught at the point of instantiation in earlier
2410 -- versions.
2412 -- This is wrong, error messages cannot be issued during
2413 -- expansion, since they would be missed in -gnatc mode ???
2419 -- Fetch the primitive op _assign and proper type to call it.
2420 -- Because of possible conflicts between private and full view,
2421 -- fetch the proper type directly from the operation profile.
2423 declare
2428 begin
2429 -- If the assignment is dispatching, make sure to use the
2430 -- proper type.
2438 -- In case of assignment to a class-wide tagged type, before
2439 -- the assignment we generate run-time check to ensure that
2440 -- the tags of source and target match.
2446 then
2447 declare
2451 begin
2453 Lhs_Tag :=
2456 Selector_Name =>
2458 Rhs_Tag :=
2461 Selector_Name =>
2463 else
2464 -- Displace the pointer to the base of the objects
2465 -- applying 'Address, which is later expanded into
2466 -- a call to RE_Base_Address.
2468 Lhs_Tag :=
2470 Prefix =>
2475 Rhs_Tag :=
2477 Prefix =>
2486 Condition =>
2494 declare
2498 begin
2499 -- In order to dispatch the call to _assign the type of
2500 -- the actuals must match. Add conversion (if required).
2519 else
2522 -- We can't afford to have destructive Finalization Actions in
2523 -- the Self assignment case, so if the target and the source
2524 -- are not obviously different, code is generated to avoid the
2525 -- self assignment case:
2527 -- if lhs'address /= rhs'address then
2528 -- <code for controlled and/or tagged assignment>
2529 -- end if;
2531 -- Skip this if Restriction (No_Finalization) is active
2534 and then Expand_Ctrl_Actions
2536 then
2539 Condition =>
2541 Left_Opnd =>
2546 Right_Opnd =>
2554 -- We need to set up an exception handler for implementing
2555 -- 7.6.1(18). The remaining adjustments are tackled by the
2556 -- implementation of adjust for record_controllers (see
2557 -- s-finimp.adb).
2559 -- This is skipped if we have no finalization
2561 if Expand_Ctrl_Actions
2563 then
2566 Handled_Statement_Sequence =>
2576 Handled_Statement_Sequence =>
2579 -- If no restrictions on aborts, protect the whole assignment
2580 -- for controlled objects as per 9.8(11).
2583 and then Expand_Ctrl_Actions
2584 and then Abort_Allowed
2585 then
2586 declare
2588 New_Internal_Entity
2592 begin
2603 -- Present the Abort_Undefer_Direct function to the backend
2604 -- so that it can inline the call to the function.
2608 Expand_At_End_Handler
2613 -- N has been rewritten to a block statement for which it is
2614 -- known by construction that no checks are necessary: analyze
2615 -- it with all checks suppressed.
2621 -- Array types
2624 declare
2627 begin
2629 N_Qualified_Expression)
2630 loop
2638 -- Record types
2644 -- Scalar types. This is where we perform the processing related to the
2645 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
2646 -- scalar values.
2650 -- Case where right side is known valid
2654 -- Here the right side is valid, so it is fine. The case to deal
2655 -- with is when the left side is a local variable reference whose
2656 -- value is not currently known to be valid. If this is the case,
2657 -- and the assignment appears in an unconditional context, then
2658 -- we can mark the left side as now being valid if one of these
2659 -- conditions holds:
2661 -- The expression of the right side has Do_Range_Check set so
2662 -- that we know a range check will be performed. Note that it
2663 -- can be the case that a range check is omitted because we
2664 -- make the assumption that we can assume validity for operands
2665 -- appearing in the right side in determining whether a range
2666 -- check is required
2668 -- The subtype of the right side matches the subtype of the
2669 -- left side. In this case, even though we have not checked
2670 -- the range of the right side, we know it is in range of its
2671 -- subtype if the expression is valid.
2676 then
2679 then
2684 -- Case where right side may be invalid in the sense of the RM
2685 -- reference above. The RM does not require that we check for the
2686 -- validity on an assignment, but it does require that the assignment
2687 -- of an invalid value not cause erroneous behavior.
2689 -- The general approach in GNAT is to use the Is_Known_Valid flag
2690 -- to avoid the need for validity checking on assignments. However
2691 -- in some cases, we have to do validity checking in order to make
2692 -- sure that the setting of this flag is correct.
2694 else
2695 -- Validate right side if we are validating copies
2697 if Validity_Checks_On
2698 and then Validity_Check_Copies
2699 then
2700 -- Skip this if left-hand side is an array or record component
2701 -- and elementary component validity checks are suppressed.
2704 and then not Validity_Check_Components
2705 then
2707 else
2711 -- We can propagate this to the left side where appropriate
2716 then
2720 -- Otherwise check to see what should be done
2722 -- If left side is a local variable, then we just set its flag to
2723 -- indicate that its value may no longer be valid, since we are
2724 -- copying a potentially invalid value.
2729 -- Check for case of a nonlocal variable on the left side which
2730 -- is currently known to be valid. In this case, we simply ensure
2731 -- that the right side is valid. We only play the game of copying
2732 -- validity status for local variables, since we are doing this
2733 -- statically, not by tracing the full flow graph.
2737 then
2738 -- Note: If Validity_Checking mode is set to none, we ignore
2739 -- the Ensure_Valid call so don't worry about that case here.
2743 -- In all other cases, we can safely copy an invalid value without
2744 -- worrying about the status of the left side. Since it is not a
2745 -- variable reference it will not be considered
2746 -- as being known to be valid in any case.
2748 else
2754 exception
2759 ------------------------------
2760 -- Expand_N_Block_Statement --
2761 ------------------------------
2763 -- Encode entity names defined in block statement
2766 begin
2770 -----------------------------
2771 -- Expand_N_Case_Statement --
2772 -----------------------------
2783 begin
2784 -- Check for the situation where we know at compile time which branch
2785 -- will be taken.
2787 -- If the value is static but its subtype is predicated and the value
2788 -- does not obey the predicate, the value is marked non-static, and
2789 -- there can be no corresponding static alternative. In that case we
2790 -- replace the case statement with an exception, regardless of whether
2791 -- assertions are enabled or not, unless predicates are ignored.
2797 then
2806 then
2809 -- Do not consider controlled objects found in a case statement which
2810 -- actually models a case expression because their early finalization
2811 -- will affect the result of the expression.
2817 -- Move statements from this alternative after the case statement.
2818 -- They are already analyzed, so will be skipped by the analyzer.
2822 -- That leaves the case statement as a shell. So now we can kill all
2823 -- other alternatives in the case statement.
2827 declare
2830 begin
2831 -- Loop through case alternatives, skipping pragmas, and skipping
2832 -- the one alternative that we select (and therefore retain).
2838 then
2850 -- Here if the choice is not determined at compile time
2852 declare
2861 begin
2865 else
2869 -- First step is to worry about possible invalid argument. The RM
2870 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
2871 -- outside the base range), then Constraint_Error must be raised.
2873 -- Case of validity check required (validity checks are on, the
2874 -- expression is not known to be valid, and the case statement
2875 -- comes from source -- no need to validity check internally
2876 -- generated case statements).
2878 if Validity_Check_Default
2880 then
2884 -- If there is only a single alternative, just replace it with the
2885 -- sequence of statements since obviously that is what is going to
2886 -- be executed in all cases.
2892 -- We still need to evaluate the expression if it has any side
2893 -- effects.
2898 -- Do not consider controlled objects found in a case statement
2899 -- which actually models a case expression because their early
2900 -- finalization will affect the result of the expression.
2908 -- That leaves the case statement as a shell. The alternative that
2909 -- will be executed is reset to a null list. So now we can kill
2910 -- the entire case statement.
2916 -- An optimization. If there are only two alternatives, and only
2917 -- a single choice, then rewrite the whole case statement as an
2918 -- if statement, since this can result in subsequent optimizations.
2919 -- This helps not only with case statements in the source of a
2920 -- simple form, but also with generated code (discriminant check
2921 -- functions in particular).
2923 -- Note: it is OK to do this before expanding out choices for any
2924 -- static predicates, since the if statement processing will handle
2925 -- the static predicate case fine.
2936 -- For TRUE, generate "expression", not expression = true
2940 then
2943 -- For FALSE, generate "expression" and switch then/else
2947 then
2952 -- For a range, generate "expression in range"
2959 then
2960 Cond :=
2965 -- A subtype indication is not a legal operator in a membership
2966 -- test, so retrieve its range.
2969 Cond :=
2972 Right_Opnd =>
2973 Relocate_Node
2976 -- For any other subexpression "expression = value"
2978 else
2979 Cond :=
2985 -- Now rewrite the case as an IF
2997 -- If the last alternative is not an Others choice, replace it with
2998 -- an N_Others_Choice. Note that we do not bother to call Analyze on
2999 -- the modified case statement, since it's only effect would be to
3000 -- compute the contents of the Others_Discrete_Choices which is not
3001 -- needed by the back end anyway.
3003 -- The reason for this is that the back end always needs some default
3004 -- for a switch, so if we have not supplied one in the processing
3005 -- above for validity checking, then we need to supply one here.
3010 -- If Predicates_Ignored is true the value does not satisfy the
3011 -- predicate, and there is no Others choice, Constraint_Error
3012 -- must be raised (4.5.7 (21/3)).
3015 declare
3025 begin
3030 else
3031 Set_Others_Discrete_Choices
3038 -- Deal with possible declarations of controlled objects, and also
3039 -- with rewriting choice sequences for static predicate references.
3044 -- Do not consider controlled objects found in a case statement
3045 -- which actually models a case expression because their early
3046 -- finalization will affect the result of the expression.
3061 -----------------------------
3062 -- Expand_N_Exit_Statement --
3063 -----------------------------
3065 -- The only processing required is to deal with a possible C/Fortran
3066 -- boolean value used as the condition for the exit statement.
3069 begin
3073 ----------------------------------
3074 -- Expand_Formal_Container_Loop --
3075 ----------------------------------
3089 begin
3090 -- The expansion of a formal container loop resembles the one for Ada
3091 -- containers. The only difference is that the primitives mention the
3092 -- domain of iteration explicitly, and function First applied to the
3093 -- container yields a cursor directly.
3095 -- Cursor : Cursor_type := First (Container);
3096 -- while Has_Element (Cursor, Container) loop
3097 -- <original loop statements>
3098 -- Cursor := Next (Container, Cursor);
3099 -- end loop;
3101 Build_Formal_Container_Iteration
3106 -- Build a block to capture declaration of the cursor
3111 Handled_Statement_Sequence =>
3115 -- The loop parameter is declared by an object declaration, but within
3116 -- the loop we must prevent user assignments to it, so we analyze the
3117 -- declaration and reset the entity kind, before analyzing the rest of
3118 -- the loop.
3123 -- The cursor was marked as a loop parameter to prevent user assignments
3124 -- to it, however this renders the advancement step illegal as it is not
3125 -- possible to change the value of a constant. Flag the advancement step
3126 -- as a legal form of assignment to remedy this side effect.
3131 -- Because we have to analyze the initial declaration of the loop
3132 -- parameter multiple times its scope is incorrectly set at this point
3133 -- to the one surrounding the block statement - so set the scope
3134 -- manually to be the actual block statement.
3139 ------------------------------------------
3140 -- Expand_Formal_Container_Element_Loop --
3141 ------------------------------------------
3165 begin
3166 -- For an element iterator, the Element aspect must be present,
3167 -- (this is checked during analysis) and the expansion takes the form:
3169 -- Cursor : Cursor_Type := First (Container);
3170 -- Elmt : Element_Type;
3171 -- while Has_Element (Cursor, Container) loop
3172 -- Elmt := Element (Container, Cursor);
3173 -- <original loop statements>
3174 -- Cursor := Next (Container, Cursor);
3175 -- end loop;
3177 -- However this expansion is not legal if the element is indefinite.
3178 -- In that case we create a block to hold a variable declaration
3179 -- initialized with a call to Element, and generate:
3181 -- Cursor : Cursor_Type := First (Container);
3182 -- while Has_Element (Cursor, Container) loop
3183 -- declare
3184 -- Elmt : Element_Type := Element (Container, Cursor);
3185 -- begin
3186 -- <original loop statements>
3187 -- Cursor := Next (Container, Cursor);
3188 -- end;
3189 -- end loop;
3191 Build_Formal_Container_Iteration
3198 -- Declaration for Element
3200 Elmt_Decl :=
3214 New_List
3217 Handled_Statement_Sequence =>
3221 else
3222 Elmt_Ref :=
3225 Expression =>
3234 -- The element is assignable in the expanded code
3238 -- The loop is rewritten as a block, to hold the element declaration
3240 New_Loop :=
3243 Handled_Statement_Sequence =>
3248 -- The element is only modified in expanded code, so it appears as
3249 -- unassigned to the warning machinery. We must suppress this spurious
3250 -- warning explicitly.
3256 -- The loop parameter is declared by an object declaration, but within
3257 -- the loop we must prevent user assignments to it, so we analyze the
3258 -- declaration and reset the entity kind, before analyzing the rest of
3259 -- the loop.
3267 -----------------------------
3268 -- Expand_N_Goto_Statement --
3269 -----------------------------
3271 -- Add poll before goto if polling active
3274 begin
3278 ---------------------------
3279 -- Expand_N_If_Statement --
3280 ---------------------------
3282 -- First we deal with the case of C and Fortran convention boolean values,
3283 -- with zero/non-zero semantics.
3285 -- Second, we deal with the obvious rewriting for the cases where the
3286 -- condition of the IF is known at compile time to be True or False.
3288 -- Third, we remove elsif parts which have non-empty Condition_Actions and
3289 -- rewrite as independent if statements. For example:
3291 -- if x then xs
3292 -- elsif y then ys
3293 -- ...
3294 -- end if;
3296 -- becomes
3297 --
3298 -- if x then xs
3299 -- else
3300 -- <<condition actions of y>>
3301 -- if y then ys
3302 -- ...
3303 -- end if;
3304 -- end if;
3306 -- This rewriting is needed if at least one elsif part has a non-empty
3307 -- Condition_Actions list. We also do the same processing if there is a
3308 -- constant condition in an elsif part (in conjunction with the first
3309 -- processing step mentioned above, for the recursive call made to deal
3310 -- with the created inner if, this deals with properly optimizing the
3311 -- cases of constant elsif conditions).
3321 -- Indicates whether we want warnings when we delete branches of the
3322 -- if statement based on constant condition analysis. We never want
3323 -- these warnings for expander generated code.
3325 begin
3326 -- Do not consider controlled objects found in an if statement which
3327 -- actually models an if expression because their early finalization
3328 -- will affect the result of the expression.
3336 -- The following loop deals with constant conditions for the IF. We
3337 -- need a loop because as we eliminate False conditions, we grab the
3338 -- first elsif condition and use it as the primary condition.
3342 -- If condition is True, we can simply rewrite the if statement now
3343 -- by replacing it by the series of then statements.
3347 -- All the else parts can be killed
3357 -- If condition is False, then we can delete the condition and
3358 -- the Then statements
3360 else
3361 -- We do not delete the condition if constant condition warnings
3362 -- are enabled, since otherwise we end up deleting the desired
3363 -- warning. Of course the backend will get rid of this True/False
3364 -- test anyway, so nothing is lost here.
3372 -- If there are no elsif statements, then we simply replace the
3373 -- entire if statement by the sequence of else statements.
3378 then
3381 else
3389 -- If there are elsif statements, the first of them becomes the
3390 -- if/then section of the rebuilt if statement This is the case
3391 -- where we loop to reprocess this copied condition.
3393 else
3399 -- Hed might have been captured as the condition determining
3400 -- the current value for an entity. Now it is detached from
3401 -- the tree, so a Current_Value pointer in the condition might
3402 -- need to be updated.
3413 -- Loop through elsif parts, dealing with constant conditions and
3414 -- possible condition actions that are present.
3420 -- Do not consider controlled objects found in an if statement
3421 -- which actually models an if expression because their early
3422 -- finalization will affect the result of the expression.
3430 -- If there are condition actions, then rewrite the if statement
3431 -- as indicated above. We also do the same rewrite for a True or
3432 -- False condition. The further processing of this constant
3433 -- condition is then done by the recursive call to expand the
3434 -- newly created if statement
3438 then
3439 New_If :=
3446 -- Elsif parts for new if come from remaining elsif's of parent
3470 -- Note this is not an implicit if statement, since it is part
3471 -- of an explicit if statement in the source (or of an implicit
3472 -- if statement that has already been tested). We set the flag
3473 -- after calling Analyze to avoid generating extra warnings
3474 -- specific to pure if statements, however (see
3475 -- Sem_Ch5.Analyze_If_Statement).
3480 -- No special processing for that elsif part, move to next
3482 else
3488 -- Some more optimizations applicable if we still have an IF statement
3494 -- Another optimization, special cases that can be simplified
3496 -- if expression then
3497 -- return true;
3498 -- else
3499 -- return false;
3500 -- end if;
3502 -- can be changed to:
3504 -- return expression;
3506 -- and
3508 -- if expression then
3509 -- return false;
3510 -- else
3511 -- return true;
3512 -- end if;
3514 -- can be changed to:
3516 -- return not (expression);
3518 -- Only do these optimizations if we are at least at -O1 level and
3519 -- do not do them if control flow optimizations are suppressed.
3523 then
3529 then
3530 declare
3534 begin
3536 and then
3538 then
3539 declare
3543 begin
3545 and then
3547 then
3550 then
3559 then
3562 Expression =>
3564 Right_Opnd =>
3577 --------------------------
3578 -- Expand_Iterator_Loop --
3579 --------------------------
3588 begin
3589 -- Processing for arrays
3598 else
3602 -- Processing for containers
3604 else
3605 Expand_Iterator_Loop_Over_Container
3610 -------------------------------------
3611 -- Expand_Iterator_Loop_Over_Array --
3612 -------------------------------------
3628 -- Start of processing for Expand_Iterator_Loop_Over_Array
3630 begin
3631 -- for Element of Array loop
3633 -- It requires an internally generated cursor to iterate over the array
3639 -- Generate:
3640 -- Element : Component_Type renames Array (Iterator);
3641 -- Iterator is the index value, or a list of index values
3642 -- in the case of a multidimensional array.
3644 Ind_Comp :=
3652 Subtype_Mark =>
3656 -- Mark the loop variable as needing debug info, so that expansion
3657 -- of the renaming will result in Materialize_Entity getting set via
3658 -- Debug_Renaming_Declaration. (This setting is needed here because
3659 -- the setting in Freeze_Entity comes after the expansion, which is
3660 -- too late. ???)
3664 -- Generate:
3666 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
3667 -- Element : Component_Type renames Array (Iterator);
3668 -- <original loop statements>
3669 -- end loop;
3671 -- If this is an iteration over a multidimensional array, the
3672 -- innermost loop is over the last dimension in Ada, and over
3673 -- the first dimension in Fortran.
3677 else
3681 Core_Loop :=
3683 Iteration_Scheme =>
3685 Loop_Parameter_Specification =>
3688 Discrete_Subtype_Definition =>
3698 -- Processing for multidimensional array. The body of each loop is
3699 -- a loop over a previous dimension, going in decreasing order in Ada
3700 -- and in increasing order in Fortran.
3706 else
3712 -- Generate the dimension loops starting from the innermost one
3714 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
3715 -- <core loop>
3716 -- end loop;
3718 Core_Loop :=
3720 Iteration_Scheme =>
3722 Loop_Parameter_Specification =>
3725 Discrete_Subtype_Definition =>
3735 -- Update the previously created object renaming declaration with
3736 -- the new iterator, by adding the index of the next loop to the
3737 -- indexed component, in the order that corresponds to the
3738 -- convention.
3743 else
3750 -- Inherit the loop identifier from the original loop. This ensures that
3751 -- the scope stack is consistent after the rewriting.
3761 -----------------------------------------
3762 -- Expand_Iterator_Loop_Over_Container --
3763 -----------------------------------------
3765 -- For a 'for ... in' loop, such as:
3767 -- for Cursor in Iterator_Function (...) loop
3768 -- ...
3769 -- end loop;
3771 -- we generate:
3773 -- Iter : Iterator_Type := Iterator_Function (...);
3774 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
3775 -- while Has_Element (Cursor) loop
3776 -- ...
3777 --
3778 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3779 -- end loop;
3781 -- For a 'for ... of' loop, such as:
3783 -- for X of Container loop
3784 -- ...
3785 -- end loop;
3787 -- the RM implies the generation of:
3789 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
3790 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
3791 -- while Has_Element (Cursor) loop
3792 -- declare
3793 -- X : Element_Type renames Element (Cursor).Element.all;
3794 -- -- or Constant_Element
3795 -- begin
3796 -- ...
3797 -- end;
3798 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3799 -- end loop;
3801 -- In the general case, we do what the RM says. However, the operations
3802 -- Element and Iter.Next are slow, which is bad inside a loop, because they
3803 -- involve dispatching via interfaces, secondary stack manipulation,
3804 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
3805 -- predefined containers, we use an equivalent but optimized expansion.
3807 -- In the optimized case, we make use of these:
3809 -- procedure Next (Position : in out Cursor); -- instead of Iter.Next
3811 -- function Pseudo_Reference
3812 -- (Container : aliased Vector'Class) return Reference_Control_Type;
3814 -- type Element_Access is access all Element_Type;
3816 -- function Get_Element_Access
3817 -- (Position : Cursor) return not null Element_Access;
3819 -- Next is declared in the visible part of the container packages.
3820 -- The other three are added in the private part. (We're not supposed to
3821 -- pollute the namespace for clients. The compiler has no trouble breaking
3822 -- privacy to call things in the private part of an instance.)
3824 -- Source:
3826 -- for X of My_Vector loop
3827 -- X.Count := X.Count + 1;
3828 -- ...
3829 -- end loop;
3831 -- The compiler will generate:
3833 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector);
3834 -- -- Reversible_Iterator is an interface. Iterate is the
3835 -- -- Default_Iterator aspect of Vector. This increments Lock,
3836 -- -- disallowing tampering with cursors. Unfortunately, it does not
3837 -- -- increment Busy. The result of Iterate is Limited_Controlled;
3838 -- -- finalization will decrement Lock. This is a build-in-place
3839 -- -- dispatching call to Iterate.
3841 -- Cur : Cursor := First (Iter); -- or Last
3842 -- -- Dispatching call via interface.
3844 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
3845 -- -- Pseudo_Reference increments Busy, to detect tampering with
3846 -- -- elements, as required by RM. Also redundantly increment
3847 -- -- Lock. Finalization of Control will decrement both Busy and
3848 -- -- Lock. Pseudo_Reference returns a record containing a pointer to
3849 -- -- My_Vector, used by Finalize.
3850 -- --
3851 -- -- Control is not used below, except to finalize it -- it's purely
3852 -- -- an RAII thing. This is needed because we are eliminating the
3853 -- -- call to Reference within the loop.
3855 -- while Has_Element (Cur) loop
3856 -- declare
3857 -- X : My_Element renames Get_Element_Access (Cur).all;
3858 -- -- Get_Element_Access returns a pointer to the element
3859 -- -- designated by Cur. No dispatching here, and no horsing
3860 -- -- around with access discriminants. This is instead of the
3861 -- -- existing
3862 -- --
3863 -- -- X : My_Element renames Reference (Cur).Element.all;
3864 -- --
3865 -- -- which creates a controlled object.
3866 -- begin
3867 -- -- Any attempt to tamper with My_Vector here in the loop
3868 -- -- will correctly raise Program_Error, because of the
3869 -- -- Control.
3870 --
3871 -- X.Count := X.Count + 1;
3872 -- ...
3873 --
3874 -- Next (Cur); -- or Prev
3875 -- -- This is instead of "Cur := Next (Iter, Cur);"
3876 -- end;
3877 -- -- No finalization here
3878 -- end loop;
3879 -- Finalize Iter and Control here, decrementing Lock twice and Busy
3880 -- once.
3882 -- This optimization makes "for ... of" loops over 30 times faster in cases
3883 -- measured.
3885 procedure Expand_Iterator_Loop_Over_Container
3891 is
3908 -- Only for optimized version of "for ... of"
3911 -- The package in which the iterator interface is instantiated. This is
3912 -- typically an instance within the container package.
3915 -- The package in which the container type is declared
3917 begin
3918 -- Determine the advancement and initialization steps for the cursor.
3919 -- Analysis of the expanded loop will verify that the container has a
3920 -- reverse iterator.
3925 else
3930 -- The type of the iterator is the return type of the Iterate function
3931 -- used. For the "of" form this is the default iterator for the type,
3932 -- otherwise it is the type of the explicit function used in the
3933 -- iterator specification. The most common case will be an Iterate
3934 -- function in the container package.
3936 -- The Iterator type is declared in an instance within the container
3937 -- package itself, for example:
3939 -- package Vector_Iterator_Interfaces is new
3940 -- Ada.Iterator_Interfaces (Cursor, Has_Element);
3942 -- If the container type is a derived type, the cursor type is found in
3943 -- the package of the ultimate ancestor type.
3947 else
3955 function Get_Default_Iterator
3957 -- Return the default iterator for a specific type. If the type is
3958 -- derived, we return the inherited or overridden one if
3959 -- appropriate.
3961 --------------------------
3962 -- Get_Default_Iterator --
3963 --------------------------
3965 function Get_Default_Iterator
3967 is
3973 begin
3976 -- A previous version of GNAT allowed indexing aspects to be
3977 -- redefined on derived container types, while the default
3978 -- iterator was inherited from the parent type. This
3979 -- nonstandard extension is preserved for use by the
3980 -- modeling project under debug flag -gnatd.X.
3985 then
3986 Container_Arg :=
3988 Subtype_Mark =>
3989 New_Occurrence_Of
3998 -- The default iterator must be a primitive operation of the
3999 -- type, at the same dispatch slot position. The DT position
4000 -- may not be established if type is not frozen yet.
4007 or else
4011 then
4018 -- If we didn't find it, then our parent type is not
4019 -- iterable, so we return the Default_Iterator aspect of
4020 -- this type.
4024 -- Otherwise not a derived type
4026 else
4031 -- Local variables
4039 -- Start of processing for Handle_Of
4041 begin
4043 Default_Iter :=
4045 else
4051 -- For a container element iterator, the iterator type is obtained
4052 -- from the corresponding aspect, whose return type is descended
4053 -- from the corresponding interface type in some instance of
4054 -- Ada.Iterator_Interfaces. The actuals of that instantiation
4055 -- are Cursor and Has_Element.
4059 -- The iterator type, which is a class-wide type, may itself be
4060 -- derived locally, so the desired instantiation is the scope of
4061 -- the root type of the iterator type.
4065 -- Find declarations needed for "for ... of" optimization
4074 then
4089 then
4093 Object_Definition =>
4095 Expression =>
4097 Name =>
4099 Parameter_Associations =>
4103 -- Rewrite domain of iteration as a call to the default iterator
4104 -- for the container type. The formal may be an access parameter
4105 -- in which case we must build a reference to the container.
4107 declare
4109 begin
4111 Arg :=
4115 else
4121 Name =>
4128 -- Find cursor type in proper iterator package, which is an
4129 -- instantiation of Iterator_Interfaces.
4142 Decl :=
4145 Subtype_Mark =>
4147 Name =>
4149 Prefix =>
4151 Name =>
4153 Parameter_Associations =>
4156 else
4157 Decl :=
4160 Subtype_Mark =>
4162 Name =>
4165 Expressions =>
4169 -- The defining identifier in the iterator is user-visible and
4170 -- must be visible in the debugger.
4174 -- If the container does not have a variable indexing aspect,
4175 -- the element is a constant in the loop. The container itself
4176 -- may be constant, in which case the element is a constant as
4177 -- well. The container has been rewritten as a call to Iterate,
4178 -- so examine original node.
4183 then
4190 -- X in Iterate (S) : type of iterator is type of explicitly given
4191 -- Iterate function, and the loop variable is the cursor. It will be
4192 -- assigned in the loop and must be a variable.
4194 else
4197 -- The iterator type, which is a class-wide type, may itself be
4198 -- derived locally, so the desired instantiation is the scope of
4199 -- the root type of the iterator type, as in the "of" case.
4207 -- For both iterator forms, add a call to the step operation to advance
4208 -- the cursor. Generate:
4210 -- Cursor := Iterator.Next (Cursor);
4212 -- or else
4214 -- Cursor := Next (Cursor);
4217 declare
4221 begin
4222 Step_Call :=
4224 Name =>
4232 else
4233 declare
4236 begin
4237 Rhs :=
4239 Name =>
4254 -- Generate:
4255 -- while Has_Element (Cursor) loop
4256 -- <Stats>
4257 -- end loop;
4259 -- Has_Element is the second actual in the iterator package
4261 New_Loop :=
4263 Iteration_Scheme =>
4265 Condition =>
4267 Name =>
4268 New_Occurrence_Of
4276 -- If present, preserve identifier of loop, which can be used in an exit
4277 -- statement in the body.
4283 -- Create the declarations for Iterator and cursor and insert them
4284 -- before the source loop. Given that the domain of iteration is already
4285 -- an entity, the iterator is just a renaming of that entity. Possible
4286 -- optimization ???
4294 -- Create declaration for cursor
4296 declare
4300 Object_Definition =>
4302 Expression =>
4304 Prefix =>
4306 Selector_Name =>
4309 begin
4310 -- The cursor is only modified in expanded code, so it appears
4311 -- as unassigned to the warning machinery. We must suppress this
4312 -- spurious warning explicitly. The cursor's kind is that of the
4313 -- original loop parameter (it is a constant if the domain of
4314 -- iteration is constant).
4323 -- If the range of iteration is given by a function call that returns
4324 -- a container, the finalization actions have been saved in the
4325 -- Condition_Actions of the iterator. Insert them now at the head of
4326 -- the loop.
4336 -----------------------------
4337 -- Expand_N_Loop_Statement --
4338 -----------------------------
4340 -- 1. Remove null loop entirely
4341 -- 2. Deal with while condition for C/Fortran boolean
4342 -- 3. Deal with loops with a non-standard enumeration type range
4343 -- 4. Deal with while loops where Condition_Actions is set
4344 -- 5. Deal with loops over predicated subtypes
4345 -- 6. Deal with loops with iterators over arrays and containers
4346 -- 7. Insert polling call if required
4353 begin
4354 -- Delete null loop
4361 -- Deal with condition for C/Fortran Boolean
4367 -- Generate polling call
4373 -- Nothing more to do for plain loop with no iteration scheme
4378 -- Case of for loop (Loop_Parameter_Specification present)
4380 -- Note: we do not have to worry about validity checking of the for loop
4381 -- range bounds here, since they were frozen with constant declarations
4382 -- and it is during that process that the validity checking is done.
4385 declare
4395 begin
4396 -- Deal with loop over predicates
4400 then
4403 -- Handle the case where we have a for loop with the range type
4404 -- being an enumeration type with non-standard representation.
4405 -- In this case we expand:
4407 -- for x in [reverse] a .. b loop
4408 -- ...
4409 -- end loop;
4411 -- to
4413 -- for xP in [reverse] integer
4414 -- range etype'Pos (a) .. etype'Pos (b)
4415 -- loop
4416 -- declare
4417 -- x : constant etype := Pos_To_Rep (xP);
4418 -- begin
4419 -- ...
4420 -- end;
4421 -- end loop;
4425 then
4426 New_Id :=
4430 -- If the type has a contiguous representation, successive
4431 -- values can be generated as offsets from the first literal.
4434 Expr :=
4437 Left_Opnd =>
4441 else
4442 -- Use the constructed array Enum_Pos_To_Rep
4444 Expr :=
4446 Prefix =>
4448 Expressions =>
4452 -- Build declaration for loop identifier
4454 Decls :=
4455 New_List (
4466 Iteration_Scheme =>
4468 Loop_Parameter_Specification =>
4473 Discrete_Subtype_Definition =>
4476 Subtype_Mark =>
4479 Constraint =>
4481 Range_Expression =>
4484 Low_Bound =>
4486 Prefix =>
4492 Relocate_Node
4495 High_Bound =>
4497 Prefix =>
4503 Relocate_Node
4504 (Type_High_Bound
4510 Handled_Statement_Sequence =>
4516 -- The loop parameter's entity must be removed from the loop
4517 -- scope's entity list and rendered invisible, since it will
4518 -- now be located in the new block scope. Any other entities
4519 -- already associated with the loop scope, such as the loop
4520 -- parameter's subtype, will remain there.
4522 -- In an element loop, the loop will contain a declaration for
4523 -- a cursor variable; otherwise the loop id is the first entity
4524 -- in the scope constructed for the loop.
4540 -- Nothing to do with other cases of for loops
4542 else
4547 -- Second case, if we have a while loop with Condition_Actions set, then
4548 -- we change it into a plain loop:
4550 -- while C loop
4551 -- ...
4552 -- end loop;
4554 -- changed to:
4556 -- loop
4557 -- <<condition actions>>
4558 -- exit when not C;
4559 -- ...
4560 -- end loop
4565 then
4566 declare
4569 begin
4570 ES :=
4572 Condition =>
4579 -- This is not an implicit loop, since it is generated in response
4580 -- to the loop statement being processed. If this is itself
4581 -- implicit, the restriction has already been checked. If not,
4582 -- it is an explicit loop.
4593 -- Here to deal with iterator case
4597 then
4600 -- An iterator loop may generate renaming declarations for elements
4601 -- that require debug information. This is the case in particular
4602 -- with element iterators, where debug information must be generated
4603 -- for the temporary that holds the element value. These temporaries
4604 -- are created within a transient block whose local declarations are
4605 -- transferred to the loop, which now has nontrivial local objects.
4609 then
4614 -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
4615 -- is transformed into a conditional block where the original loop is
4616 -- the sole statement. Inspect the statements of the nested loop for
4617 -- controlled objects.
4628 ----------------------------
4629 -- Expand_Predicated_Loop --
4630 ----------------------------
4632 -- Note: the expander can handle generation of loops over predicated
4633 -- subtypes for both the dynamic and static cases. Depending on what
4634 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
4635 -- mode, the semantic analyzer may disallow one or both forms.
4646 begin
4647 -- Case of iteration over non-static predicate, should not be possible
4648 -- since this is not allowed by the semantics and should have been
4649 -- caught during analysis of the loop statement.
4654 -- If the predicate list is empty, that corresponds to a predicate of
4655 -- False, in which case the loop won't run at all, and we rewrite the
4656 -- entire loop as a null statement.
4662 -- For expansion over a static predicate we generate the following
4664 -- declare
4665 -- J : Ltype := min-val;
4666 -- begin
4667 -- loop
4668 -- body
4669 -- case J is
4670 -- when endpoint => J := startpoint;
4671 -- when endpoint => J := startpoint;
4672 -- ...
4673 -- when max-val => exit;
4674 -- when others => J := Lval'Succ (J);
4675 -- end case;
4676 -- end loop;
4677 -- end;
4679 -- with min-val replaced by max-val and Succ replaced by Pred if the
4680 -- loop parameter specification carries a Reverse indicator.
4682 -- To make this a little clearer, let's take a specific example:
4684 -- type Int is range 1 .. 10;
4685 -- subtype StaticP is Int with
4686 -- predicate => StaticP in 3 | 10 | 5 .. 7;
4687 -- ...
4688 -- for L in StaticP loop
4689 -- Put_Line ("static:" & J'Img);
4690 -- end loop;
4692 -- In this case, the loop is transformed into
4694 -- begin
4695 -- J : L := 3;
4696 -- loop
4697 -- body
4698 -- case J is
4699 -- when 3 => J := 5;
4700 -- when 7 => J := 10;
4701 -- when 10 => exit;
4702 -- when others => J := L'Succ (J);
4703 -- end case;
4704 -- end loop;
4705 -- end;
4707 -- In addition, if the loop specification is given by a subtype
4708 -- indication that constrains a predicated type, the bounds of
4709 -- iteration are given by those of the subtype indication.
4711 else
4719 -- If the domain is an itype, note the bounds of its range.
4725 -- Given static expression or static range, returns an identifier
4726 -- whose value is the low bound of the expression value or range.
4729 -- Given static expression or static range, returns an identifier
4730 -- whose value is the high bound of the expression value or range.
4732 ------------
4733 -- Hi_Val --
4734 ------------
4737 begin
4740 else
4746 ------------
4747 -- Lo_Val --
4748 ------------
4751 begin
4754 else
4760 -- Start of processing for Static_Predicate
4762 begin
4763 -- Convert loop identifier to normal variable and reanalyze it so
4764 -- that this conversion works. We have to use the same defining
4765 -- identifier, since there may be references in the loop body.
4770 -- In most loops the loop variable is assigned in various
4771 -- alternatives in the body. However, in the rare case when
4772 -- the range specifies a single element, the loop variable
4773 -- may trigger a spurious warning that is could be constant.
4774 -- This warning might as well be suppressed.
4783 -- Loop to create branches of case statement
4789 -- Initial value is largest value in predicate.
4792 D :=
4798 else
4799 D :=
4810 else
4811 S :=
4828 and then
4830 then
4837 else
4838 -- Initial value is smallest value in predicate
4841 D :=
4846 else
4847 D :=
4858 else
4859 S :=
4876 and then
4878 then
4886 -- Add others choice
4888 declare
4891 begin
4894 else
4898 S :=
4901 Expression =>
4915 -- Construct case statement and append to body statements
4917 Cstm :=
4923 -- Rewrite the loop
4930 Handled_Statement_Sequence =>
4942 ------------------------------
4943 -- Make_Tag_Ctrl_Assignment --
4944 ------------------------------
4957 and then not Comp_Asn
4964 begin
4965 -- Finalize the target of the assignment when controlled
4967 -- We have two exceptions here:
4969 -- 1. If we are in an init proc since it is an initialization more
4970 -- than an assignment.
4972 -- 2. If the left-hand side is a temporary that was not initialized
4973 -- (or the parent part of a temporary since it is the case in
4974 -- extension aggregates). Such a temporary does not come from
4975 -- source. We must examine the original node for the prefix, because
4976 -- it may be a component of an entry formal, in which case it has
4977 -- been rewritten and does not appear to come from source either.
4979 -- Case of init proc
4984 -- The left-hand side is an uninitialized temporary object
4989 N_Object_Declaration
4991 then
4994 else
4995 Fin_Call :=
4996 Make_Final_Call
5005 -- Save the Tag in a local variable Tag_Id
5014 Expression =>
5017 Selector_Name =>
5020 -- Otherwise Tag_Id is not used
5022 else
5026 -- If the tagged type has a full rep clause, expand the assignment into
5027 -- component-wise assignments. Mark the node as unanalyzed in order to
5028 -- generate the proper code and propagate this scenario by setting a
5029 -- flag to avoid infinite recursion.
5038 -- Restore the tag
5043 Name =>
5046 Selector_Name =>
5051 -- Adjust the target after the assignment when controlled (not in the
5052 -- init proc since it is an initialization more than an assignment).
5055 Adj_Call :=
5056 Make_Adjust_Call
5067 exception
5069 -- Could use comment here ???