| blob | 2fd38ac86a610326a38d2abc5f779fd83b463db1 |
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-2013, 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 ------------------------------------------------------------------------------
65 procedure Build_Formal_Container_Iteration
72 -- Utility to create declarations and loop statement for both forms
73 -- of formal container iterators.
76 -- Determine if the right hand side of assignment N is a type conversion
77 -- which requires a change of representation. Called only for the array
78 -- and record cases.
81 -- N is an assignment which assigns an array value. This routine process
82 -- the various special cases and checks required for such assignments,
83 -- including change of representation. Rhs is normally simply the right
84 -- hand side of the assignment, except that if the right hand side is a
85 -- type conversion or a qualified expression, then the RHS is the actual
86 -- expression inside any such type conversions or qualifications.
88 function Expand_Assign_Array_Loop
96 -- N is an assignment statement which assigns an array value. This routine
97 -- expands the assignment into a loop (or nested loops for the case of a
98 -- multi-dimensional array) to do the assignment component by component.
99 -- Larray and Rarray are the entities of the actual arrays on the left
100 -- hand and right hand sides. L_Type and R_Type are the types of these
101 -- arrays (which may not be the same, due to either sliding, or to a
102 -- change of representation case). Ndim is the number of dimensions and
103 -- the parameter Rev indicates if the loops run normally (Rev = False),
104 -- or reversed (Rev = True). The value returned is the constructed
105 -- loop statement. Auxiliary declarations are inserted before node N
106 -- using the standard Insert_Actions mechanism.
109 -- N is an assignment of a non-tagged record value. This routine handles
110 -- the case where the assignment must be made component by component,
111 -- either because the target is not byte aligned, or there is a change
112 -- of representation, or when we have a tagged type with a representation
113 -- clause (this last case is required because holes in the tagged type
114 -- might be filled with components from child types).
117 -- Use the primitives specified in an Iterable aspect to expand a loop
118 -- over a so-called formal container, primarily for SPARK usage.
121 -- Same, for an iterator of the form " For E of C". In this case the
122 -- iterator provides the name of the element, and the cursor is generated
123 -- internally.
126 -- Expand loop over arrays and containers that uses the form "for X of C"
127 -- with an optional subtype mark, or "for Y in C".
130 -- Expand loop over arrays that uses the form "for X of C"
133 -- Expand for loop over predicated subtype
136 -- Generate the necessary code for controlled and tagged assignment, that
137 -- is to say, finalization of the target before, adjustment of the target
138 -- after and save and restore of the tag and finalization pointers which
139 -- are not 'part of the value' and must not be changed upon assignment. N
140 -- is the original Assignment node.
142 --------------------------------------
143 -- Build_Formal_Container_iteration --
144 --------------------------------------
146 procedure Build_Formal_Container_Iteration
153 is
164 begin
165 -- Declaration for Cursor
167 Init :=
171 Expression =>
177 -- Statement that advances cursor in loop
179 Advance :=
182 Expression =>
189 -- Iterator is rewritten as a while_loop
191 New_Loop :=
193 Iteration_Scheme =>
195 Condition =>
205 ------------------------------
206 -- Change_Of_Representation --
207 ------------------------------
211 begin
212 return
214 and then
218 -------------------------
219 -- Expand_Assign_Array --
220 -------------------------
222 -- There are two issues here. First, do we let Gigi do a block move, or
223 -- do we expand out into a loop? Second, we need to set the two flags
224 -- Forwards_OK and Backwards_OK which show whether the block move (or
225 -- corresponding loops) can be legitimately done in a forwards (low to
226 -- high) or backwards (high to low) manner.
252 -- This switch is set to True if the array move must be done using
253 -- an explicit front end generated loop.
256 -- If the argument is an access to an array, and the assignment is
257 -- converted into a procedure call, apply explicit dereference.
260 -- Test if Exp is a reference to an array whose declaration has
261 -- an address clause, or it is a slice of such an array.
264 -- Test if Exp is a reference to an array which is either a formal
265 -- parameter or a slice of a formal parameter. These are the cases
266 -- where hidden aliasing can occur.
269 -- Determine if Exp is a reference to an array variable which is other
270 -- than an object defined in the current scope, or a slice of such
271 -- an object. Such objects can be aliased to parameters (unlike local
272 -- array references).
274 -----------------------
275 -- Apply_Dereference --
276 -----------------------
280 begin
288 ------------------------
289 -- Has_Address_Clause --
290 ------------------------
293 begin
294 return
297 or else
301 ---------------------
302 -- Is_Formal_Array --
303 ---------------------
306 begin
307 return
309 or else
313 ------------------------
314 -- Is_Non_Local_Array --
315 ------------------------
318 begin
325 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
333 -- Start of processing for Expand_Assign_Array
335 begin
336 -- Deal with length check. Note that the length check is done with
337 -- respect to the right hand side as given, not a possible underlying
338 -- renamed object, since this would generate incorrect extra checks.
342 -- We start by assuming that the move can be done in either direction,
343 -- i.e. that the two sides are completely disjoint.
348 -- Normally it is only the slice case that can lead to overlap, and
349 -- explicit checks for slices are made below. But there is one case
350 -- where the slice can be implicit and invisible to us: when we have a
351 -- one dimensional array, and either both operands are parameters, or
352 -- one is a parameter (which can be a slice passed by reference) and the
353 -- other is a non-local variable. In this case the parameter could be a
354 -- slice that overlaps with the other operand.
356 -- However, if the array subtype is a constrained first subtype in the
357 -- parameter case, then we don't have to worry about overlap, since
358 -- slice assignments aren't possible (other than for a slice denoting
359 -- the whole array).
361 -- Note: No overlap is possible if there is a change of representation,
362 -- so we can exclude this case.
365 and then not Crep
366 and then
368 or else
370 or else
372 and then
376 -- In the case of compiling for the Java or .NET Virtual Machine,
377 -- slices are always passed by making a copy, so we don't have to
378 -- worry about overlap. We also want to prevent generation of "<"
379 -- comparisons for array addresses, since that's a meaningless
380 -- operation on the VM.
383 then
387 -- Note: the bit-packed case is not worrisome here, since if we have
388 -- a slice passed as a parameter, it is always aligned on a byte
389 -- boundary, and if there are no explicit slices, the assignment
390 -- can be performed directly.
393 -- If either operand has an address clause clear Backwards_OK and
394 -- Forwards_OK, since we cannot tell if the operands overlap. We
395 -- exclude this treatment when Rhs is an aggregate, since we know
396 -- that overlap can't occur.
400 then
405 -- We certainly must use a loop for change of representation and also
406 -- we use the operand of the conversion on the right hand side as the
407 -- effective right hand side (the component types must match in this
408 -- situation).
415 -- We require a loop if the left side is possibly bit unaligned
418 or else
420 then
423 -- Arrays with controlled components are expanded into a loop to force
424 -- calls to Adjust at the component level.
429 -- If object is atomic, we cannot tolerate a loop
432 or else
434 then
437 -- Loop is required if we have atomic components since we have to
438 -- be sure to do any accesses on an element by element basis.
444 then
447 -- Case where no slice is involved
451 -- The following code deals with the case of unconstrained bit packed
452 -- arrays. The problem is that the template for such arrays contains
453 -- the bounds of the actual source level array, but the copy of an
454 -- entire array requires the bounds of the underlying array. It would
455 -- be nice if the back end could take care of this, but right now it
456 -- does not know how, so if we have such a type, then we expand out
457 -- into a loop, which is inefficient but works correctly. If we don't
458 -- do this, we get the wrong length computed for the array to be
459 -- moved. The two cases we need to worry about are:
461 -- Explicit dereference of an unconstrained packed array type as in
462 -- the following example:
464 -- procedure C52 is
465 -- type BITS is array(INTEGER range <>) of BOOLEAN;
466 -- pragma PACK(BITS);
467 -- type A is access BITS;
468 -- P1,P2 : A;
469 -- begin
470 -- P1 := new BITS (1 .. 65_535);
471 -- P2 := new BITS (1 .. 65_535);
472 -- P2.ALL := P1.ALL;
473 -- end C52;
475 -- A formal parameter reference with an unconstrained bit array type
476 -- is the other case we need to worry about (here we assume the same
477 -- BITS type declared above):
479 -- procedure Write_All (File : out BITS; Contents : BITS);
480 -- begin
481 -- File.Storage := Contents;
482 -- end Write_All;
484 -- We expand to a loop in either of these two cases
486 -- Question for future thought. Another potentially more efficient
487 -- approach would be to create the actual subtype, and then do an
488 -- unchecked conversion to this actual subtype ???
493 -- Function to perform required test for the first case, above
494 -- (dereference of an unconstrained bit packed array).
496 -----------------------
497 -- Is_UBPA_Reference --
498 -----------------------
505 begin
509 then
518 else
520 return
525 else
530 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
532 begin
534 or else
536 then
539 -- Here if we do not have the case of a reference to a bit packed
540 -- unconstrained array case. In this case gigi can most certainly
541 -- handle the assignment if a forwards move is allowed.
543 -- (could it handle the backwards case also???)
550 -- The back end can always handle the assignment if the right side is a
551 -- string literal (note that overlap is definitely impossible in this
552 -- case). If the type is packed, a string literal is always converted
553 -- into an aggregate, except in the case of a null slice, for which no
554 -- aggregate can be written. In that case, rewrite the assignment as a
555 -- null statement, a length check has already been emitted to verify
556 -- that the range of the left-hand side is empty.
558 -- Note that this code is not executed if we have an assignment of a
559 -- string literal to a non-bit aligned component of a record, a case
560 -- which cannot be handled by the backend.
565 then
572 -- If either operand is bit packed, then we need a loop, since we can't
573 -- be sure that the slice is byte aligned. Similarly, if either operand
574 -- is a possibly unaligned slice, then we need a loop (since the back
575 -- end cannot handle unaligned slices).
581 then
584 -- If we are not bit-packed, and we have only one slice, then no overlap
585 -- is possible except in the parameter case, so we can let the back end
586 -- handle things.
594 -- If the right-hand side is a string literal, introduce a temporary for
595 -- it, for use in the generated loop that will follow.
598 declare
602 begin
603 Decl :=
615 -- Come here to complete the analysis
617 -- Loop_Required: Set to True if we know that a loop is required
618 -- regardless of overlap considerations.
620 -- Forwards_OK: Set to False if we already know that a forwards
621 -- move is not safe, else set to True.
623 -- Backwards_OK: Set to False if we already know that a backwards
624 -- move is not safe, else set to True
626 -- Our task at this stage is to complete the overlap analysis, which can
627 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
628 -- then generating the final code, either by deciding that it is OK
629 -- after all to let Gigi handle it, or by generating appropriate code
630 -- in the front end.
632 declare
650 begin
651 -- Get the expressions for the arrays. If we are dealing with a
652 -- private type, then convert to the underlying type. We can do
653 -- direct assignments to an array that is a private type, but we
654 -- cannot assign to elements of the array without this extra
655 -- unchecked conversion.
657 -- Note: We propagate Parent to the conversion nodes to generate
658 -- a well-formed subtree.
662 else
666 declare
668 begin
669 Larray :=
670 Unchecked_Convert_To
679 else
683 declare
685 begin
686 Rarray :=
687 Unchecked_Convert_To
694 -- If both sides are slices, we must figure out whether it is safe
695 -- to do the move in one direction or the other. It is always safe
696 -- if there is a change of representation since obviously two arrays
697 -- with different representations cannot possibly overlap.
703 -- If both left and right hand arrays are entity names, and refer
704 -- to different entities, then we know that the move is safe (the
705 -- two storage areas are completely disjoint).
710 then
713 -- Otherwise, we assume the worst, which is that the two arrays
714 -- are the same array. There is no need to check if we know that
715 -- is the case, because if we don't know it, we still have to
716 -- assume it.
718 -- Generally if the same array is involved, then we have an
719 -- overlapping case. We will have to really assume the worst (i.e.
720 -- set neither of the OK flags) unless we can determine the lower
721 -- or upper bounds at compile time and compare them.
723 else
724 Cresult :=
725 Compile_Time_Compare
729 Cresult :=
730 Compile_Time_Compare
743 -- If after that analysis Loop_Required is False, meaning that we
744 -- have not discovered some non-overlap reason for requiring a loop,
745 -- then the outcome depends on the capabilities of the back end.
749 -- The GCC back end can deal with all cases of overlap by falling
750 -- back to memmove if it cannot use a more efficient approach.
755 -- Assume other back ends can handle it if Forwards_OK is set
760 -- If Forwards_OK is not set, the back end will need something
761 -- like memmove to handle the move. For now, this processing is
762 -- activated using the .s debug flag (-gnatd.s).
769 -- At this stage we have to generate an explicit loop, and we have
770 -- the following cases:
772 -- Forwards_OK = True
774 -- Rnn : right_index := right_index'First;
775 -- for Lnn in left-index loop
776 -- left (Lnn) := right (Rnn);
777 -- Rnn := right_index'Succ (Rnn);
778 -- end loop;
780 -- Note: the above code MUST be analyzed with checks off, because
781 -- otherwise the Succ could overflow. But in any case this is more
782 -- efficient.
784 -- Forwards_OK = False, Backwards_OK = True
786 -- Rnn : right_index := right_index'Last;
787 -- for Lnn in reverse left-index loop
788 -- left (Lnn) := right (Rnn);
789 -- Rnn := right_index'Pred (Rnn);
790 -- end loop;
792 -- Note: the above code MUST be analyzed with checks off, because
793 -- otherwise the Pred could overflow. But in any case this is more
794 -- efficient.
796 -- Forwards_OK = Backwards_OK = False
798 -- This only happens if we have the same array on each side. It is
799 -- possible to create situations using overlays that violate this,
800 -- but we simply do not promise to get this "right" in this case.
802 -- There are two possible subcases. If the No_Implicit_Conditionals
803 -- restriction is set, then we generate the following code:
805 -- declare
806 -- T : constant <operand-type> := rhs;
807 -- begin
808 -- lhs := T;
809 -- end;
811 -- If implicit conditionals are permitted, then we generate:
813 -- if Left_Lo <= Right_Lo then
814 -- <code for Forwards_OK = True above>
815 -- else
816 -- <code for Backwards_OK = True above>
817 -- end if;
819 -- In order to detect possible aliasing, we examine the renamed
820 -- expression when the source or target is a renaming. However,
821 -- the renaming may be intended to capture an address that may be
822 -- affected by subsequent code, and therefore we must recover
823 -- the actual entity for the expansion that follows, not the
824 -- object it renames. In particular, if source or target designate
825 -- a portion of a dynamically allocated object, the pointer to it
826 -- may be reassigned but the renaming preserves the proper location.
829 and then
832 then
837 and then
840 then
844 -- Cases where either Forwards_OK or Backwards_OK is true
851 then
852 declare
857 begin
869 New_Occurrence_Of (
878 else
880 Expand_Assign_Array_Loop
885 -- Case of both are false with No_Implicit_Conditionals
888 declare
892 begin
899 Object_Definition =>
903 Handled_Statement_Sequence =>
911 -- Case of both are false with implicit conditionals allowed
913 else
914 -- Before we generate this code, we must ensure that the left and
915 -- right side array types are defined. They may be itypes, and we
916 -- cannot let them be defined inside the if, since the first use
917 -- in the then may not be executed.
922 -- We normally compare addresses to find out which way round to
923 -- do the loop, since this is reliable, and handles the cases of
924 -- parameters, conversions etc. But we can't do that in the bit
925 -- packed case or the VM case, because addresses don't work there.
928 Condition :=
930 Left_Opnd =>
933 Prefix =>
935 Prefix =>
939 Prefix =>
940 New_Occurrence_Of
945 Right_Opnd =>
948 Prefix =>
950 Prefix =>
954 Prefix =>
955 New_Occurrence_Of
960 -- For the bit packed and VM cases we use the bounds. That's OK,
961 -- because we don't have to worry about parameters, since they
962 -- cannot cause overlap. Perhaps we should worry about weird slice
963 -- conversions ???
965 else
966 -- Copy the bounds
971 -- If the types do not match we add an implicit conversion
972 -- here to ensure proper match
975 Cright_Lo :=
979 -- Reset the Analyzed flag, because the bounds of the index
980 -- type itself may be universal, and must must be reanalyzed
981 -- to acquire the proper type for the back end.
986 Condition :=
996 then
998 -- Call TSS procedure for array assignment, passing the
999 -- explicit bounds of right and left hand sides.
1001 declare
1006 begin
1027 else
1033 Expand_Assign_Array_Loop
1038 Expand_Assign_Array_Loop
1047 exception
1052 ------------------------------
1053 -- Expand_Assign_Array_Loop --
1054 ------------------------------
1056 -- The following is an example of the loop generated for the case of a
1057 -- two-dimensional array:
1059 -- declare
1060 -- R2b : Tm1X1 := 1;
1061 -- begin
1062 -- for L1b in 1 .. 100 loop
1063 -- declare
1064 -- R4b : Tm1X2 := 1;
1065 -- begin
1066 -- for L3b in 1 .. 100 loop
1067 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
1068 -- R4b := Tm1X2'succ(R4b);
1069 -- end loop;
1070 -- end;
1071 -- R2b := Tm1X1'succ(R2b);
1072 -- end loop;
1073 -- end;
1075 -- Here Rev is False, and Tm1Xn are the subscript types for the right hand
1076 -- side. The declarations of R2b and R4b are inserted before the original
1077 -- assignment statement.
1079 function Expand_Assign_Array_Loop
1087 is
1092 -- Entities used as subscripts on left and right sides
1096 -- Left and right index types
1104 -- The increment step for the index of the right-hand side is written
1105 -- as an attribute reference (Succ or Pred). This function returns
1106 -- the corresponding node, which is placed at the end of the loop body.
1108 ----------------
1109 -- Build_Step --
1110 ----------------
1116 begin
1119 else
1123 Step :=
1126 Expression =>
1128 Prefix =>
1134 -- Note that on the last iteration of the loop, the index is increased
1135 -- (or decreased) past the corresponding bound. This is consistent with
1136 -- the C semantics of the back-end, where such an off-by-one value on a
1137 -- dead index variable is OK. However, in CodePeer mode this leads to
1138 -- spurious warnings, and thus we place a guard around the attribute
1139 -- reference. For obvious reasons we only do this for CodePeer.
1142 Step :=
1144 Condition =>
1147 Right_Opnd =>
1157 -- Start of processing for Expand_Assign_Array_Loop
1159 begin
1163 else
1168 -- Setup index types and subscript entities
1170 declare
1174 begin
1190 -- Now construct the assignment statement
1192 declare
1196 begin
1202 Assign :=
1204 Name =>
1208 Expression =>
1213 -- We set assignment OK, since there are some cases, e.g. in object
1214 -- declarations, where we are actually assigning into a constant.
1215 -- If there really is an illegality, it was caught long before now,
1216 -- and was flagged when the original assignment was analyzed.
1220 -- Propagate the No_Ctrl_Actions flag to individual assignments
1225 -- Now construct the loop from the inside out, with the last subscript
1226 -- varying most rapidly. Note that Assign is first the raw assignment
1227 -- statement, and then subsequently the loop that wraps it up.
1230 Assign :=
1235 Object_Definition =>
1237 Expression =>
1242 Handled_Statement_Sequence =>
1246 Iteration_Scheme =>
1248 Loop_Parameter_Specification =>
1252 Discrete_Subtype_Definition =>
1261 --------------------------
1262 -- Expand_Assign_Record --
1263 --------------------------
1270 begin
1271 -- If change of representation, then extract the real right hand side
1272 -- from the type conversion, and proceed with component-wise assignment,
1273 -- since the two types are not the same as far as the back end is
1274 -- concerned.
1279 -- If this may be a case of a large bit aligned component, then proceed
1280 -- with component-wise assignment, to avoid possible clobbering of other
1281 -- components sharing bits in the first or last byte of the component to
1282 -- be assigned.
1285 or
1287 then
1290 -- If we have a tagged type that has a complete record representation
1291 -- clause, we must do we must do component-wise assignments, since child
1292 -- types may have used gaps for their components, and we might be
1293 -- dealing with a view conversion.
1298 -- If neither condition met, then nothing special to do, the back end
1299 -- can handle assignment of the entire component as a single entity.
1301 else
1305 -- At this stage we know that we must do a component wise assignment
1307 declare
1314 function Find_Component
1317 -- Find the component with the given name in the underlying record
1318 -- declaration for Typ. We need to use the actual entity because the
1319 -- type may be private and resolution by identifier alone would fail.
1321 function Make_Component_List_Assign
1324 -- Returns a sequence of statements to assign the components that
1325 -- are referenced in the given component list. The flag U_U is
1326 -- used to force the usage of the inferred value of the variant
1327 -- part expression as the switch for the generated case statement.
1329 function Make_Field_Assign
1332 -- Given C, the entity for a discriminant or component, build an
1333 -- assignment for the corresponding field values. The flag U_U
1334 -- signals the presence of an Unchecked_Union and forces the usage
1335 -- of the inferred discriminant value of C as the right hand side
1336 -- of the assignment.
1339 -- Given CI, a component items list, construct series of statements
1340 -- for fieldwise assignment of the corresponding components.
1342 --------------------
1343 -- Find_Component --
1344 --------------------
1346 function Find_Component
1349 is
1353 begin
1366 --------------------------------
1367 -- Make_Component_List_Assign --
1368 --------------------------------
1370 function Make_Component_List_Assign
1373 is
1384 begin
1401 Statements =>
1406 -- If we have an Unchecked_Union, use the value of the inferred
1407 -- discriminant of the variant part expression as the switch
1408 -- for the case statement. The case statement may later be
1409 -- folded.
1412 Expr :=
1417 else
1418 Expr :=
1421 Selector_Name =>
1434 -----------------------
1435 -- Make_Field_Assign --
1436 -----------------------
1438 function Make_Field_Assign
1441 is
1445 begin
1446 -- In the case of an Unchecked_Union, use the discriminant
1447 -- constraint value as on the right hand side of the assignment.
1450 Expr :=
1454 else
1455 Expr :=
1461 A :=
1463 Name =>
1466 Selector_Name =>
1470 -- Set Assignment_OK, so discriminants can be assigned
1477 then
1484 ------------------------
1485 -- Make_Field_Assigns --
1486 ------------------------
1492 begin
1498 -- Look for components, but exclude _tag field assignment if
1499 -- the special Componentwise_Assignment flag is set.
1504 then
1505 Append_To
1515 -- Start of processing for Expand_Assign_Record
1517 begin
1518 -- Note that we use the base types for this processing. This results
1519 -- in some extra work in the constrained case, but the change of
1520 -- representation case is so unusual that it is not worth the effort.
1522 -- First copy the discriminants. This is done unconditionally. It
1523 -- is required in the unconstrained left side case, and also in the
1524 -- case where this assignment was constructed during the expansion
1525 -- of a type conversion (since initialization of discriminants is
1526 -- suppressed in this case). It is unnecessary but harmless in
1527 -- other cases.
1533 -- If we are expanding the initialization of a derived record
1534 -- that constrains or renames discriminants of the parent, we
1535 -- must use the corresponding discriminant in the parent.
1537 declare
1540 begin
1541 if Inside_Init_Proc
1543 then
1545 else
1551 -- Within an initialization procedure this is the
1552 -- assignment to an unchecked union component, in which
1553 -- case there is no discriminant to initialize.
1558 else
1559 -- The assignment is part of a conversion from a
1560 -- derived unchecked union type with an inferable
1561 -- discriminant, to a parent type.
1566 else
1575 -- We know the underlying type is a record, but its current view
1576 -- may be private. We must retrieve the usable record declaration.
1579 N_Private_Extension_Declaration)
1581 then
1583 else
1593 then
1597 else
1598 Insert_Actions
1607 -----------------------------------
1608 -- Expand_N_Assignment_Statement --
1609 -----------------------------------
1611 -- This procedure implements various cases where an assignment statement
1612 -- cannot just be passed on to the back end in untransformed state.
1622 begin
1623 -- Special case to check right away, if the Componentwise_Assignment
1624 -- flag is set, this is a reanalysis from the expansion of the primitive
1625 -- assignment procedure for a tagged type, and all we need to do is to
1626 -- expand to assignment of components, because otherwise, we would get
1627 -- infinite recursion (since this looks like a tagged assignment which
1628 -- would normally try to *call* the primitive assignment procedure).
1635 -- Defend against invalid subscripts on left side if we are in standard
1636 -- validity checking mode. No need to do this if we are checking all
1637 -- subscripts.
1639 -- Note that we do this right away, because there are some early return
1640 -- paths in this procedure, and this is required on all paths.
1642 if Validity_Checks_On
1643 and then Validity_Check_Default
1644 and then not Validity_Check_Subscripts
1645 then
1649 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
1651 -- Rewrite an assignment to X'Priority into a run-time call
1653 -- For example: X'Priority := New_Prio_Expr;
1654 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
1656 -- Note that although X'Priority is notionally an object, it is quite
1657 -- deliberately not defined as an aliased object in the RM. This means
1658 -- that it works fine to rewrite it as a call, without having to worry
1659 -- about complications that would other arise from X'Priority'Access,
1660 -- which is illegal, because of the lack of aliasing.
1663 declare
1670 begin
1671 -- Handle chains of renamings
1677 loop
1681 -- The attribute Priority applied to protected objects has been
1682 -- previously expanded into a call to the Get_Ceiling run-time
1683 -- subprogram.
1687 or else
1689 then
1690 -- Look for the enclosing concurrent type
1699 -- Generate the first actual of the call
1706 -- Select the appropriate run-time call
1709 RT_Subprg_Name :=
1711 else
1712 RT_Subprg_Name :=
1716 Call :=
1730 -- Deal with assignment checks unless suppressed
1734 -- First deal with generation of range check if required
1741 -- Then generate predicate check if required
1746 -- Check for a special case where a high level transformation is
1747 -- required. If we have either of:
1749 -- P.field := rhs;
1750 -- P (sub) := rhs;
1752 -- where P is a reference to a bit packed array, then we have to unwind
1753 -- the assignment. The exact meaning of being a reference to a bit
1754 -- packed array is as follows:
1756 -- An indexed component whose prefix is a bit packed array is a
1757 -- reference to a bit packed array.
1759 -- An indexed component or selected component whose prefix is a
1760 -- reference to a bit packed array is itself a reference ot a
1761 -- bit packed array.
1763 -- The required transformation is
1765 -- Tnn : prefix_type := P;
1766 -- Tnn.field := rhs;
1767 -- P := Tnn;
1769 -- or
1771 -- Tnn : prefix_type := P;
1772 -- Tnn (subscr) := rhs;
1773 -- P := Tnn;
1775 -- Since P is going to be evaluated more than once, any subscripts
1776 -- in P must have their evaluation forced.
1780 then
1781 declare
1787 begin
1788 -- Insert the post assignment first, because we want to copy the
1789 -- BPAR_Expr tree before it gets analyzed in the context of the
1790 -- pre assignment. Note that we do not analyze the post assignment
1791 -- yet (we cannot till we have completed the analysis of the pre
1792 -- assignment). As usual, the analysis of this post assignment
1793 -- will happen on its own when we "run into" it after finishing
1794 -- the current assignment.
1801 -- At this stage BPAR_Expr is a reference to a bit packed array
1802 -- where the reference was not expanded in the original tree,
1803 -- since it was on the left side of an assignment. But in the
1804 -- pre-assignment statement (the object definition), BPAR_Expr
1805 -- will end up on the right hand side, and must be reexpanded. To
1806 -- achieve this, we reset the analyzed flag of all selected and
1807 -- indexed components down to the actual indexed component for
1808 -- the packed array.
1811 loop
1814 if Nkind_In
1816 then
1818 else
1823 -- Now we can insert and analyze the pre-assignment
1825 -- If the right-hand side requires a transient scope, it has
1826 -- already been placed on the stack. However, the declaration is
1827 -- inserted in the tree outside of this scope, and must reflect
1828 -- the proper scope for its variable. This awkward bit is forced
1829 -- by the stricter scope discipline imposed by GCC 2.97.
1831 declare
1833 Scope_Is_Transient
1836 begin
1848 Pop_Scope;
1852 -- Now fix up the original assignment and continue processing
1857 -- We do not need to reanalyze that assignment, and we do not need
1858 -- to worry about references to the temporary, but we do need to
1859 -- make sure that the temporary is not marked as a true constant
1860 -- since we now have a generated assignment to it.
1866 -- When we have the appropriate type of aggregate in the expression (it
1867 -- has been determined during analysis of the aggregate by setting the
1868 -- delay flag), let's perform in place assignment and thus avoid
1869 -- creating a temporary.
1878 -- Apply discriminant check if required. If Lhs is an access type to a
1879 -- designated type with discriminants, we must always check. If the
1880 -- type has unknown discriminants, more elaborate processing below.
1884 then
1885 -- Skip discriminant check if change of representation. Will be
1886 -- done when the change of representation is expanded out.
1892 -- If the type is private without discriminants, and the full type
1893 -- has discriminants (necessarily with defaults) a check may still be
1894 -- necessary if the Lhs is aliased. The private discriminants must be
1895 -- visible to build the discriminant constraints.
1897 -- Only an explicit dereference that comes from source indicates
1898 -- aliasing. Access to formals of protected operations and entries
1899 -- create dereferences but are not semantic aliasings.
1905 then
1906 declare
1910 begin
1911 -- In the case of an expander-generated record subtype whose base
1912 -- type still appears private, Typ will have been set to that
1913 -- private type rather than the underlying record type (because
1914 -- Underlying type will have returned the record subtype), so it's
1915 -- necessary to apply Underlying_Type again to the base type to
1916 -- get the record type we need for the discriminant check. Such
1917 -- subtypes can be created for assignments in certain cases, such
1918 -- as within an instantiation passed this kind of private type.
1919 -- It would be good to avoid this special test, but making changes
1920 -- to prevent this odd form of record subtype seems difficult. ???
1932 -- If the Lhs has a private type with unknown discriminants, it may
1933 -- have a full view with discriminants, but those are nameable only
1934 -- in the underlying type, so convert the Rhs to it before potential
1935 -- checking. Convert Lhs as well, otherwise the actual subtype might
1936 -- not be constructible.
1940 then
1945 -- In the access type case, we need the same discriminant check, and
1946 -- also range checks if we have an access to constrained array.
1950 then
1953 -- Skip discriminant check if change of representation. Will be
1954 -- done when the change of representation is expanded out.
1968 declare
1972 begin
1973 C_Es :=
1974 Get_Range_Checks
1976 Target_Typ,
1979 Insert_Range_Checks
1981 N,
1982 Target_Typ,
1984 Lhs);
1989 -- Apply range check for access type case
1994 then
1996 Apply_Range_Check
2000 -- Ada 2005 (AI-231): Generate the run-time check
2005 then
2009 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2010 -- stand-alone obj of an anonymous access type.
2015 then
2016 declare
2018 -- Look through renames to find the underlying entity.
2019 -- For assignment to a rename, we don't care about the
2020 -- Enclosing_Dynamic_Scope of the rename declaration.
2022 ----------------
2023 -- Lhs_Entity --
2024 ----------------
2029 begin
2032 -- Renamed_Object must return an Entity_Name here
2033 -- because of preceding "Present (E_E_A (...))" test.
2041 -- Local Declarations
2045 Condition =>
2047 Left_Opnd =>
2049 Right_Opnd =>
2051 Intval =>
2052 Scope_Depth
2053 (Enclosing_Dynamic_Scope
2059 Name =>
2060 New_Occurrence_Of
2061 (Effective_Extra_Accessibility
2063 Expression =>
2066 begin
2075 -- Case of assignment to a bit packed array element. If there is a
2076 -- change of representation this must be expanded into components,
2077 -- otherwise this is a bit-field assignment.
2081 then
2082 -- Normal case, no change of representation
2088 -- Change of representation case
2090 else
2091 -- Generate the following, to force component-by-component
2092 -- assignments in an efficient way. Otherwise each component
2093 -- will require a temporary and two bit-field manipulations.
2095 -- T1 : Elmt_Type;
2096 -- T1 := RhS;
2097 -- Lhs := T1;
2099 declare
2103 begin
2104 Stats :=
2105 New_List (
2108 Object_Definition =>
2123 -- Build-in-place function call case. Note that we're not yet doing
2124 -- build-in-place for user-written assignment statements (the assignment
2125 -- here came from an aggregate.)
2129 then
2134 -- Nothing to do for valuetypes
2135 -- ??? Set_Scope_Is_Transient (False);
2141 then
2146 begin
2147 -- In the controlled case, we ensure that function calls are
2148 -- evaluated before finalizing the target. In all cases, it makes
2149 -- the expansion easier if the side-effects are removed first.
2154 -- Avoid recursion in the mechanism
2158 -- If dispatching assignment, we need to dispatch to _assign
2162 -- If the type is tagged, we may as well use the predefined
2163 -- primitive assignment. This avoids inlining a lot of code
2164 -- and in the class-wide case, the assignment is replaced
2165 -- by a dispatching call to _assign. It is suppressed in the
2166 -- case of assignments created by the expander that correspond
2167 -- to initializations, where we do want to copy the tag
2168 -- (Expand_Ctrl_Actions flag is set False in this case). It is
2169 -- also suppressed if restriction No_Dispatching_Calls is in
2170 -- force because in that case predefined primitives are not
2171 -- generated.
2176 and then Expand_Ctrl_Actions
2177 and then
2179 then
2182 -- This can happen in an instance when the formal is an
2183 -- extension of a limited interface, and the actual is
2184 -- limited. This is an error according to AI05-0087, but
2185 -- is not caught at the point of instantiation in earlier
2186 -- versions.
2188 -- This is wrong, error messages cannot be issued during
2189 -- expansion, since they would be missed in -gnatc mode ???
2195 -- Fetch the primitive op _assign and proper type to call it.
2196 -- Because of possible conflicts between private and full view,
2197 -- fetch the proper type directly from the operation profile.
2199 declare
2204 begin
2205 -- If the assignment is dispatching, make sure to use the
2206 -- proper type.
2214 -- In case of assignment to a class-wide tagged type, before
2215 -- the assignment we generate run-time check to ensure that
2216 -- the tags of source and target match.
2222 then
2225 Condition =>
2227 Left_Opnd =>
2230 Selector_Name =>
2232 Right_Opnd =>
2235 Selector_Name =>
2240 declare
2244 begin
2245 -- In order to dispatch the call to _assign the type of
2246 -- the actuals must match. Add conversion (if required).
2265 else
2268 -- We can't afford to have destructive Finalization Actions in
2269 -- the Self assignment case, so if the target and the source
2270 -- are not obviously different, code is generated to avoid the
2271 -- self assignment case:
2273 -- if lhs'address /= rhs'address then
2274 -- <code for controlled and/or tagged assignment>
2275 -- end if;
2277 -- Skip this if Restriction (No_Finalization) is active
2280 and then Expand_Ctrl_Actions
2282 then
2285 Condition =>
2287 Left_Opnd =>
2292 Right_Opnd =>
2300 -- We need to set up an exception handler for implementing
2301 -- 7.6.1(18). The remaining adjustments are tackled by the
2302 -- implementation of adjust for record_controllers (see
2303 -- s-finimp.adb).
2305 -- This is skipped if we have no finalization
2307 if Expand_Ctrl_Actions
2309 then
2312 Handled_Statement_Sequence =>
2322 Handled_Statement_Sequence =>
2325 -- If no restrictions on aborts, protect the whole assignment
2326 -- for controlled objects as per 9.8(11).
2329 and then Expand_Ctrl_Actions
2330 and then Abort_Allowed
2331 then
2332 declare
2334 New_Internal_Entity
2337 begin
2345 Expand_At_End_Handler
2350 -- N has been rewritten to a block statement for which it is
2351 -- known by construction that no checks are necessary: analyze
2352 -- it with all checks suppressed.
2358 -- Array types
2361 declare
2364 begin
2366 N_Qualified_Expression)
2367 loop
2375 -- Record types
2381 -- Scalar types. This is where we perform the processing related to the
2382 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
2383 -- scalar values.
2387 -- Case where right side is known valid
2391 -- Here the right side is valid, so it is fine. The case to deal
2392 -- with is when the left side is a local variable reference whose
2393 -- value is not currently known to be valid. If this is the case,
2394 -- and the assignment appears in an unconditional context, then
2395 -- we can mark the left side as now being valid if one of these
2396 -- conditions holds:
2398 -- The expression of the right side has Do_Range_Check set so
2399 -- that we know a range check will be performed. Note that it
2400 -- can be the case that a range check is omitted because we
2401 -- make the assumption that we can assume validity for operands
2402 -- appearing in the right side in determining whether a range
2403 -- check is required
2405 -- The subtype of the right side matches the subtype of the
2406 -- left side. In this case, even though we have not checked
2407 -- the range of the right side, we know it is in range of its
2408 -- subtype if the expression is valid.
2413 then
2416 then
2421 -- Case where right side may be invalid in the sense of the RM
2422 -- reference above. The RM does not require that we check for the
2423 -- validity on an assignment, but it does require that the assignment
2424 -- of an invalid value not cause erroneous behavior.
2426 -- The general approach in GNAT is to use the Is_Known_Valid flag
2427 -- to avoid the need for validity checking on assignments. However
2428 -- in some cases, we have to do validity checking in order to make
2429 -- sure that the setting of this flag is correct.
2431 else
2432 -- Validate right side if we are validating copies
2434 if Validity_Checks_On
2435 and then Validity_Check_Copies
2436 then
2437 -- Skip this if left hand side is an array or record component
2438 -- and elementary component validity checks are suppressed.
2441 and then not Validity_Check_Components
2442 then
2444 else
2448 -- We can propagate this to the left side where appropriate
2453 then
2457 -- Otherwise check to see what should be done
2459 -- If left side is a local variable, then we just set its flag to
2460 -- indicate that its value may no longer be valid, since we are
2461 -- copying a potentially invalid value.
2466 -- Check for case of a nonlocal variable on the left side which
2467 -- is currently known to be valid. In this case, we simply ensure
2468 -- that the right side is valid. We only play the game of copying
2469 -- validity status for local variables, since we are doing this
2470 -- statically, not by tracing the full flow graph.
2474 then
2475 -- Note: If Validity_Checking mode is set to none, we ignore
2476 -- the Ensure_Valid call so don't worry about that case here.
2480 -- In all other cases, we can safely copy an invalid value without
2481 -- worrying about the status of the left side. Since it is not a
2482 -- variable reference it will not be considered
2483 -- as being known to be valid in any case.
2485 else
2491 exception
2496 ------------------------------
2497 -- Expand_N_Block_Statement --
2498 ------------------------------
2500 -- Encode entity names defined in block statement
2503 begin
2507 -----------------------------
2508 -- Expand_N_Case_Statement --
2509 -----------------------------
2520 begin
2521 -- Check for the situation where we know at compile time which branch
2522 -- will be taken
2529 -- Move statements from this alternative after the case statement.
2530 -- They are already analyzed, so will be skipped by the analyzer.
2534 -- That leaves the case statement as a shell. So now we can kill all
2535 -- other alternatives in the case statement.
2539 declare
2542 begin
2543 -- Loop through case alternatives, skipping pragmas, and skipping
2544 -- the one alternative that we select (and therefore retain).
2550 then
2562 -- Here if the choice is not determined at compile time
2564 declare
2573 begin
2577 else
2581 -- First step is to worry about possible invalid argument. The RM
2582 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
2583 -- outside the base range), then Constraint_Error must be raised.
2585 -- Case of validity check required (validity checks are on, the
2586 -- expression is not known to be valid, and the case statement
2587 -- comes from source -- no need to validity check internally
2588 -- generated case statements).
2594 -- If there is only a single alternative, just replace it with the
2595 -- sequence of statements since obviously that is what is going to
2596 -- be executed in all cases.
2602 -- We still need to evaluate the expression if it has any side
2603 -- effects.
2612 -- That leaves the case statement as a shell. The alternative that
2613 -- will be executed is reset to a null list. So now we can kill
2614 -- the entire case statement.
2620 -- An optimization. If there are only two alternatives, and only
2621 -- a single choice, then rewrite the whole case statement as an
2622 -- if statement, since this can result in subsequent optimizations.
2623 -- This helps not only with case statements in the source of a
2624 -- simple form, but also with generated code (discriminant check
2625 -- functions in particular).
2627 -- Note: it is OK to do this before expanding out choices for any
2628 -- static predicates, since the if statement processing will handle
2629 -- the static predicate case fine.
2640 -- For TRUE, generate "expression", not expression = true
2644 then
2647 -- For FALSE, generate "expression" and switch then/else
2651 then
2656 -- For a range, generate "expression in range"
2664 then
2665 Cond :=
2670 -- For any other subexpression "expression = value"
2672 else
2673 Cond :=
2679 -- Now rewrite the case as an IF
2691 -- If the last alternative is not an Others choice, replace it with
2692 -- an N_Others_Choice. Note that we do not bother to call Analyze on
2693 -- the modified case statement, since it's only effect would be to
2694 -- compute the contents of the Others_Discrete_Choices which is not
2695 -- needed by the back end anyway.
2697 -- The reason we do this is that the back end always needs some
2698 -- default for a switch, so if we have not supplied one in the
2699 -- processing above for validity checking, then we need to supply
2700 -- one here.
2704 Set_Others_Discrete_Choices
2709 -- Deal with possible declarations of controlled objects, and also
2710 -- with rewriting choice sequences for static predicate references.
2725 -----------------------------
2726 -- Expand_N_Exit_Statement --
2727 -----------------------------
2729 -- The only processing required is to deal with a possible C/Fortran
2730 -- boolean value used as the condition for the exit statement.
2733 begin
2737 ----------------------------------
2738 -- Expand_Formal_Container_Loop --
2739 ----------------------------------
2752 begin
2753 -- The expansion resembles the one for Ada containers, but the
2754 -- primitives mention the domain of iteration explicitly, and
2755 -- function First applied to the container yields a cursor directly.
2757 -- Cursor : Cursor_type := First (Container);
2758 -- while Has_Element (Cursor, Container) loop
2759 -- <original loop statements>
2760 -- Cursor := Next (Container, Cursor);
2761 -- end loop;
2763 Build_Formal_Container_Iteration
2775 ------------------------------------------
2776 -- Expand_Formal_Container_Element_Loop --
2777 ------------------------------------------
2801 begin
2802 -- For an element iterator, the Element aspect must be present,
2803 -- (this is checked during analysis) and the expansion takes the form:
2805 -- Cursor : Cursor_type := First (Container);
2806 -- Elmt : Element_Type;
2807 -- while Has_Element (Cursor, Container) loop
2808 -- Elmt := Element (Container, Cursor);
2809 -- <original loop statements>
2810 -- Cursor := Next (Container, Cursor);
2811 -- end loop;
2813 Build_Formal_Container_Iteration
2819 -- Declaration for Element.
2821 Elmt_Decl :=
2826 -- The element is only modified in expanded code, so it appears as
2827 -- unassigned to the warning machinery. We must suppress this spurious
2828 -- warning explicitly.
2832 Elmt_Ref :=
2835 Expression =>
2845 -- The loop is rewritten as a block, to hold the element declaration
2847 New_Loop :=
2850 Handled_Statement_Sequence =>
2858 -----------------------------
2859 -- Expand_N_Goto_Statement --
2860 -----------------------------
2862 -- Add poll before goto if polling active
2865 begin
2869 ---------------------------
2870 -- Expand_N_If_Statement --
2871 ---------------------------
2873 -- First we deal with the case of C and Fortran convention boolean values,
2874 -- with zero/non-zero semantics.
2876 -- Second, we deal with the obvious rewriting for the cases where the
2877 -- condition of the IF is known at compile time to be True or False.
2879 -- Third, we remove elsif parts which have non-empty Condition_Actions and
2880 -- rewrite as independent if statements. For example:
2882 -- if x then xs
2883 -- elsif y then ys
2884 -- ...
2885 -- end if;
2887 -- becomes
2888 --
2889 -- if x then xs
2890 -- else
2891 -- <<condition actions of y>>
2892 -- if y then ys
2893 -- ...
2894 -- end if;
2895 -- end if;
2897 -- This rewriting is needed if at least one elsif part has a non-empty
2898 -- Condition_Actions list. We also do the same processing if there is a
2899 -- constant condition in an elsif part (in conjunction with the first
2900 -- processing step mentioned above, for the recursive call made to deal
2901 -- with the created inner if, this deals with properly optimizing the
2902 -- cases of constant elsif conditions).
2912 -- Indicates whether we want warnings when we delete branches of the
2913 -- if statement based on constant condition analysis. We never want
2914 -- these warnings for expander generated code.
2916 begin
2921 -- The following loop deals with constant conditions for the IF. We
2922 -- need a loop because as we eliminate False conditions, we grab the
2923 -- first elsif condition and use it as the primary condition.
2927 -- If condition is True, we can simply rewrite the if statement now
2928 -- by replacing it by the series of then statements.
2932 -- All the else parts can be killed
2942 -- If condition is False, then we can delete the condition and
2943 -- the Then statements
2945 else
2946 -- We do not delete the condition if constant condition warnings
2947 -- are enabled, since otherwise we end up deleting the desired
2948 -- warning. Of course the backend will get rid of this True/False
2949 -- test anyway, so nothing is lost here.
2957 -- If there are no elsif statements, then we simply replace the
2958 -- entire if statement by the sequence of else statements.
2963 then
2966 else
2974 -- If there are elsif statements, the first of them becomes the
2975 -- if/then section of the rebuilt if statement This is the case
2976 -- where we loop to reprocess this copied condition.
2978 else
2984 -- Hed might have been captured as the condition determining
2985 -- the current value for an entity. Now it is detached from
2986 -- the tree, so a Current_Value pointer in the condition might
2987 -- need to be updated.
2998 -- Loop through elsif parts, dealing with constant conditions and
2999 -- possible condition actions that are present.
3008 -- If there are condition actions, then rewrite the if statement
3009 -- as indicated above. We also do the same rewrite for a True or
3010 -- False condition. The further processing of this constant
3011 -- condition is then done by the recursive call to expand the
3012 -- newly created if statement
3016 then
3017 -- Note this is not an implicit if statement, since it is part
3018 -- of an explicit if statement in the source (or of an implicit
3019 -- if statement that has already been tested).
3021 New_If :=
3028 -- Elsif parts for new if come from remaining elsif's of parent
3053 -- No special processing for that elsif part, move to next
3055 else
3061 -- Some more optimizations applicable if we still have an IF statement
3067 -- Another optimization, special cases that can be simplified
3069 -- if expression then
3070 -- return true;
3071 -- else
3072 -- return false;
3073 -- end if;
3075 -- can be changed to:
3077 -- return expression;
3079 -- and
3081 -- if expression then
3082 -- return false;
3083 -- else
3084 -- return true;
3085 -- end if;
3087 -- can be changed to:
3089 -- return not (expression);
3091 -- Only do these optimizations if we are at least at -O1 level and
3092 -- do not do them if control flow optimizations are suppressed.
3096 then
3102 then
3103 declare
3107 begin
3109 and then
3111 then
3112 declare
3116 begin
3118 and then
3120 then
3123 then
3132 then
3135 Expression =>
3137 Right_Opnd =>
3150 --------------------------
3151 -- Expand_Iterator_Loop --
3152 --------------------------
3167 begin
3168 -- Processing for arrays
3177 else
3184 -- Processing for containers
3186 -- For an "of" iterator the name is a container expression, which
3187 -- is transformed into a call to the default iterator.
3189 -- For an iterator of the form "in" the name is a function call
3190 -- that delivers an iterator type.
3192 -- In both cases, analysis of the iterator has introduced an object
3193 -- declaration to capture the domain, so that Container is an entity.
3195 -- The for loop is expanded into a while loop which uses a container
3196 -- specific cursor to desgnate each element.
3198 -- Iter : Iterator_Type := Container.Iterate;
3199 -- Cursor : Cursor_type := First (Iter);
3200 -- while Has_Element (Iter) loop
3201 -- declare
3202 -- -- The block is added when Element_Type is controlled
3204 -- Obj : Pack.Element_Type := Element (Cursor);
3205 -- -- for the "of" loop form
3206 -- begin
3207 -- <original loop statements>
3208 -- end;
3210 -- Cursor := Iter.Next (Cursor);
3211 -- end loop;
3213 -- If "reverse" is present, then the initialization of the cursor
3214 -- uses Last and the step becomes Prev. Pack is the name of the
3215 -- scope where the container package is instantiated.
3217 declare
3225 begin
3226 -- The type of the iterator is the return type of the Iterate
3227 -- function used. For the "of" form this is the default iterator
3228 -- for the type, otherwise it is the type of the explicit
3229 -- function used in the iterator specification. The most common
3230 -- case will be an Iterate function in the container package.
3232 -- The primitive operations of the container type may not be
3233 -- use-visible, so we introduce the name of the enclosing package
3234 -- in the declarations below. The Iterator type is declared in a
3235 -- an instance within the container package itself.
3237 -- If the container type is a derived type, the cursor type is
3238 -- found in the package of the parent type.
3242 else
3248 -- The "of" case uses an internally generated cursor whose type
3249 -- is found in the container package. The domain of iteration
3250 -- is expanded into a call to the default Iterator function, but
3251 -- this expansion does not take place in quantified expressions
3252 -- that are analyzed with expansion disabled, and in that case the
3253 -- type of the iterator must be obtained from the aspect.
3256 declare
3258 Entity
3259 (Find_Value_Of_Aspect
3261 Aspect_Default_Iterator));
3266 begin
3269 -- For an container element iterator, the iterator type
3270 -- is obtained from the corresponding aspect, whose return
3271 -- type is descended from the corresponding interface type
3272 -- in some instance of Ada.Iterator_Interfaces. The actuals
3273 -- of that instantiation are Cursor and Has_Element.
3277 -- The iterator type, which is a class_wide type, may itself
3278 -- be derived locally, so the desired instantiation is the
3279 -- scope of the root type of the iterator type.
3283 -- Rewrite domain of iteration as a call to the default
3284 -- iterator for the container type. If the container is
3285 -- a derived type and the aspect is inherited, convert
3286 -- container to parent type. The Cursor type is also
3287 -- inherited from the scope of the parent.
3291 then
3294 else
3295 Container_Arg :=
3297 Subtype_Mark =>
3298 New_Occurrence_Of
3306 Parameter_Associations =>
3310 -- Find cursor type in proper iterator package, which is an
3311 -- instantiation of Iterator_Interfaces.
3322 -- Generate:
3323 -- Id : Element_Type renames Container (Cursor);
3324 -- This assumes that the container type has an indexing
3325 -- operation with Cursor. The check that this operation
3326 -- exists is performed in Check_Container_Indexing.
3328 Decl :=
3331 Subtype_Mark =>
3333 Name =>
3336 Expressions =>
3339 -- The defining identifier in the iterator is user-visible
3340 -- and must be visible in the debugger.
3344 -- If the container does not have a variable indexing aspect,
3345 -- the element is a constant in the loop.
3349 then
3353 -- If the container holds controlled objects, wrap the loop
3354 -- statements and element renaming declaration with a block.
3355 -- This ensures that the result of Element (Cusor) is
3356 -- cleaned up after each iteration of the loop.
3360 -- Generate:
3361 -- declare
3362 -- Id : Element_Type := Element (curosr);
3363 -- begin
3364 -- <original loop statements>
3365 -- end;
3370 Handled_Statement_Sequence =>
3374 -- Elements do not need finalization
3376 else
3381 -- X in Iterate (S) : type of iterator is type of explicitly
3382 -- given Iterate function, and the loop variable is the cursor.
3383 -- It will be assigned in the loop and must be a variable.
3385 else
3392 -- Determine the advancement and initialization steps for the
3393 -- cursor.
3395 -- Analysis of the expanded loop will verify that the container
3396 -- has a reverse iterator.
3402 else
3407 -- For both iterator forms, add a call to the step operation to
3408 -- advance the cursor. Generate:
3410 -- Cursor := Iterator.Next (Cursor);
3412 -- or else
3414 -- Cursor := Next (Cursor);
3416 declare
3419 begin
3420 Rhs :=
3422 Name =>
3435 -- Generate:
3436 -- while Iterator.Has_Element loop
3437 -- <Stats>
3438 -- end loop;
3440 -- Has_Element is the second actual in the iterator package
3442 New_Loop :=
3444 Iteration_Scheme =>
3446 Condition =>
3448 Name =>
3449 New_Occurrence_Of (
3451 Parameter_Associations =>
3457 -- If present, preserve identifier of loop, which can be used in
3458 -- an exit statement in the body.
3464 -- Create the declarations for Iterator and cursor and insert them
3465 -- before the source loop. Given that the domain of iteration is
3466 -- already an entity, the iterator is just a renaming of that
3467 -- entity. Possible optimization ???
3468 -- Generate:
3470 -- I : Iterator_Type renames Container;
3471 -- C : Cursor_Type := Container.[First | Last];
3479 -- Create declaration for cursor
3481 declare
3484 begin
3485 Decl :=
3488 Object_Definition =>
3490 Expression =>
3493 Selector_Name =>
3496 -- The cursor is only modified in expanded code, so it appears
3497 -- as unassigned to the warning machinery. We must suppress
3498 -- this spurious warning explicitly.
3506 -- If the range of iteration is given by a function call that
3507 -- returns a container, the finalization actions have been saved
3508 -- in the Condition_Actions of the iterator. Insert them now at
3509 -- the head of the loop.
3520 -------------------------------------
3521 -- Expand_Iterator_Loop_Over_Array --
3522 -------------------------------------
3537 -- Start of processing for Expand_Iterator_Loop_Over_Array
3539 begin
3540 -- for Element of Array loop
3542 -- This case requires an internally generated cursor to iterate over
3543 -- the array.
3548 -- Generate:
3549 -- Element : Component_Type renames Array (Iterator);
3551 Ind_Comp :=
3559 Subtype_Mark =>
3563 -- Mark the loop variable as needing debug info, so that expansion
3564 -- of the renaming will result in Materialize_Entity getting set via
3565 -- Debug_Renaming_Declaration. (This setting is needed here because
3566 -- the setting in Freeze_Entity comes after the expansion, which is
3567 -- too late. ???)
3571 -- for Index in Array loop
3573 -- This case utilizes the already given iterator name
3575 else
3579 -- Generate:
3581 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
3582 -- Element : Component_Type renames Array (Iterator);
3583 -- <original loop statements>
3584 -- end loop;
3586 Core_Loop :=
3588 Iteration_Scheme =>
3590 Loop_Parameter_Specification =>
3593 Discrete_Subtype_Definition =>
3603 -- Processing for multidimensional array
3609 -- Generate the dimension loops starting from the innermost one
3611 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
3612 -- <core loop>
3613 -- end loop;
3615 Core_Loop :=
3617 Iteration_Scheme =>
3619 Loop_Parameter_Specification =>
3622 Discrete_Subtype_Definition =>
3632 -- Update the previously created object renaming declaration with
3633 -- the new iterator.
3640 -- If original loop has a source name, preserve it so it can be
3641 -- recognized by an exit statement in the body of the rewritten loop.
3642 -- This only concerns source names: the generated name of an anonymous
3643 -- loop will be create again during the subsequent analysis below.
3647 then
3655 -----------------------------
3656 -- Expand_N_Loop_Statement --
3657 -----------------------------
3659 -- 1. Remove null loop entirely
3660 -- 2. Deal with while condition for C/Fortran boolean
3661 -- 3. Deal with loops with a non-standard enumeration type range
3662 -- 4. Deal with while loops where Condition_Actions is set
3663 -- 5. Deal with loops over predicated subtypes
3664 -- 6. Deal with loops with iterators over arrays and containers
3665 -- 7. Insert polling call if required
3672 begin
3673 -- Delete null loop
3680 -- Deal with condition for C/Fortran Boolean
3686 -- Generate polling call
3692 -- Nothing more to do for plain loop with no iteration scheme
3697 -- Case of for loop (Loop_Parameter_Specification present)
3699 -- Note: we do not have to worry about validity checking of the for loop
3700 -- range bounds here, since they were frozen with constant declarations
3701 -- and it is during that process that the validity checking is done.
3704 declare
3714 begin
3715 -- Deal with loop over predicates
3719 then
3722 -- Handle the case where we have a for loop with the range type
3723 -- being an enumeration type with non-standard representation.
3724 -- In this case we expand:
3726 -- for x in [reverse] a .. b loop
3727 -- ...
3728 -- end loop;
3730 -- to
3732 -- for xP in [reverse] integer
3733 -- range etype'Pos (a) .. etype'Pos (b)
3734 -- loop
3735 -- declare
3736 -- x : constant etype := Pos_To_Rep (xP);
3737 -- begin
3738 -- ...
3739 -- end;
3740 -- end loop;
3744 then
3745 New_Id :=
3749 -- If the type has a contiguous representation, successive
3750 -- values can be generated as offsets from the first literal.
3753 Expr :=
3756 Left_Opnd =>
3760 else
3761 -- Use the constructed array Enum_Pos_To_Rep
3763 Expr :=
3765 Prefix =>
3767 Expressions =>
3771 -- Build declaration for loop identifier
3773 Decls :=
3774 New_List (
3785 Iteration_Scheme =>
3787 Loop_Parameter_Specification =>
3792 Discrete_Subtype_Definition =>
3795 Subtype_Mark =>
3798 Constraint =>
3800 Range_Expression =>
3803 Low_Bound =>
3805 Prefix =>
3811 Relocate_Node
3814 High_Bound =>
3816 Prefix =>
3822 Relocate_Node
3823 (Type_High_Bound
3829 Handled_Statement_Sequence =>
3835 -- The loop parameter's entity must be removed from the loop
3836 -- scope's entity list and rendered invisible, since it will
3837 -- now be located in the new block scope. Any other entities
3838 -- already associated with the loop scope, such as the loop
3839 -- parameter's subtype, will remain there.
3841 -- In an element loop, the loop will contain a declaration for
3842 -- a cursor variable; otherwise the loop id is the first entity
3843 -- in the scope constructed for the loop.
3859 -- Nothing to do with other cases of for loops
3861 else
3866 -- Second case, if we have a while loop with Condition_Actions set, then
3867 -- we change it into a plain loop:
3869 -- while C loop
3870 -- ...
3871 -- end loop;
3873 -- changed to:
3875 -- loop
3876 -- <<condition actions>>
3877 -- exit when not C;
3878 -- ...
3879 -- end loop
3884 then
3885 declare
3888 begin
3889 ES :=
3891 Condition =>
3898 -- This is not an implicit loop, since it is generated in response
3899 -- to the loop statement being processed. If this is itself
3900 -- implicit, the restriction has already been checked. If not,
3901 -- it is an explicit loop.
3912 -- Here to deal with iterator case
3916 then
3920 -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
3921 -- is transformed into a conditional block where the original loop is
3922 -- the sole statement. Inspect the statements of the nested loop for
3923 -- controlled objects.
3934 ----------------------------
3935 -- Expand_Predicated_Loop --
3936 ----------------------------
3938 -- Note: the expander can handle generation of loops over predicated
3939 -- subtypes for both the dynamic and static cases. Depending on what
3940 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
3941 -- mode, the semantic analyzer may disallow one or both forms.
3952 begin
3953 -- Case of iteration over non-static predicate, should not be possible
3954 -- since this is not allowed by the semantics and should have been
3955 -- caught during analysis of the loop statement.
3960 -- If the predicate list is empty, that corresponds to a predicate of
3961 -- False, in which case the loop won't run at all, and we rewrite the
3962 -- entire loop as a null statement.
3968 -- For expansion over a static predicate we generate the following
3970 -- declare
3971 -- J : Ltype := min-val;
3972 -- begin
3973 -- loop
3974 -- body
3975 -- case J is
3976 -- when endpoint => J := startpoint;
3977 -- when endpoint => J := startpoint;
3978 -- ...
3979 -- when max-val => exit;
3980 -- when others => J := Lval'Succ (J);
3981 -- end case;
3982 -- end loop;
3983 -- end;
3985 -- To make this a little clearer, let's take a specific example:
3987 -- type Int is range 1 .. 10;
3988 -- subtype L is Int with
3989 -- predicate => L in 3 | 10 | 5 .. 7;
3990 -- ...
3991 -- for L in StaticP loop
3992 -- Put_Line ("static:" & J'Img);
3993 -- end loop;
3995 -- In this case, the loop is transformed into
3997 -- begin
3998 -- J : L := 3;
3999 -- loop
4000 -- body
4001 -- case J is
4002 -- when 3 => J := 5;
4003 -- when 7 => J := 10;
4004 -- when 10 => exit;
4005 -- when others => J := L'Succ (J);
4006 -- end case;
4007 -- end loop;
4008 -- end;
4010 else
4019 -- Given static expression or static range, returns an identifier
4020 -- whose value is the low bound of the expression value or range.
4023 -- Given static expression or static range, returns an identifier
4024 -- whose value is the high bound of the expression value or range.
4026 ------------
4027 -- Hi_Val --
4028 ------------
4031 begin
4034 else
4040 ------------
4041 -- Lo_Val --
4042 ------------
4045 begin
4048 else
4054 -- Start of processing for Static_Predicate
4056 begin
4057 -- Convert loop identifier to normal variable and reanalyze it so
4058 -- that this conversion works. We have to use the same defining
4059 -- identifier, since there may be references in the loop body.
4064 -- In most loops the loop variable is assigned in various
4065 -- alternatives in the body. However, in the rare case when
4066 -- the range specifies a single element, the loop variable
4067 -- may trigger a spurious warning that is could be constant.
4068 -- This warning might as well be suppressed.
4072 -- Loop to create branches of case statement
4079 else
4080 S :=
4095 -- Add others choice
4097 S :=
4100 Expression =>
4113 -- Construct case statement and append to body statements
4115 Cstm :=
4121 -- Rewrite the loop
4123 D :=
4133 Handled_Statement_Sequence =>
4145 ------------------------------
4146 -- Make_Tag_Ctrl_Assignment --
4147 ------------------------------
4160 and then not Comp_Asn
4163 -- Tags are not saved and restored when VM_Target because VM tags are
4164 -- represented implicitly in objects.
4170 begin
4171 -- Finalize the target of the assignment when controlled
4173 -- We have two exceptions here:
4175 -- 1. If we are in an init proc since it is an initialization more
4176 -- than an assignment.
4178 -- 2. If the left-hand side is a temporary that was not initialized
4179 -- (or the parent part of a temporary since it is the case in
4180 -- extension aggregates). Such a temporary does not come from
4181 -- source. We must examine the original node for the prefix, because
4182 -- it may be a component of an entry formal, in which case it has
4183 -- been rewritten and does not appear to come from source either.
4185 -- Case of init proc
4190 -- The left hand side is an uninitialized temporary object
4195 N_Object_Declaration
4197 then
4200 else
4202 Make_Final_Call
4207 -- Save the Tag in a local variable Tag_Id
4216 Expression =>
4219 Selector_Name =>
4222 -- Otherwise Tag_Id is not used
4224 else
4228 -- Save the Prev and Next fields on .NET/JVM. This is not needed on non
4229 -- VM targets since the fields are not part of the object.
4233 then
4237 -- Generate:
4238 -- Pnn : Root_Controlled_Ptr := Root_Controlled (L).Prev;
4243 Object_Definition =>
4245 Expression =>
4247 Prefix =>
4248 Unchecked_Convert_To
4250 Selector_Name =>
4253 -- Generate:
4254 -- Nnn : Root_Controlled_Ptr := Root_Controlled (L).Next;
4259 Object_Definition =>
4261 Expression =>
4263 Prefix =>
4264 Unchecked_Convert_To
4266 Selector_Name =>
4270 -- If the tagged type has a full rep clause, expand the assignment into
4271 -- component-wise assignments. Mark the node as unanalyzed in order to
4272 -- generate the proper code and propagate this scenario by setting a
4273 -- flag to avoid infinite recursion.
4282 -- Restore the tag
4287 Name =>
4290 Selector_Name =>
4295 -- Restore the Prev and Next fields on .NET/JVM
4299 then
4300 -- Generate:
4301 -- Root_Controlled (L).Prev := Prev_Id;
4305 Name =>
4307 Prefix =>
4308 Unchecked_Convert_To
4310 Selector_Name =>
4314 -- Generate:
4315 -- Root_Controlled (L).Next := Next_Id;
4319 Name =>
4321 Prefix =>
4322 Unchecked_Convert_To
4328 -- Adjust the target after the assignment when controlled (not in the
4329 -- init proc since it is an initialization more than an assignment).
4333 Make_Adjust_Call
4340 exception
4342 -- Could use comment here ???