| blob | 2a3ecbfe39bc5a0fa949089ee14a5c369b38a60f |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 5 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
68 procedure Build_Formal_Container_Iteration
75 -- Utility to create declarations and loop statement for both forms
76 -- of formal container iterators.
79 -- Determine if the right hand side of assignment N is a type conversion
80 -- which requires a change of representation. Called only for the array
81 -- and record cases.
84 -- N is an assignment which assigns an array value. This routine process
85 -- the various special cases and checks required for such assignments,
86 -- including change of representation. Rhs is normally simply the right
87 -- hand side of the assignment, except that if the right hand side is a
88 -- type conversion or a qualified expression, then the RHS is the actual
89 -- expression inside any such type conversions or qualifications.
91 function Expand_Assign_Array_Loop
99 -- N is an assignment statement which assigns an array value. This routine
100 -- expands the assignment into a loop (or nested loops for the case of a
101 -- multi-dimensional array) to do the assignment component by component.
102 -- Larray and Rarray are the entities of the actual arrays on the left
103 -- hand and right hand sides. L_Type and R_Type are the types of these
104 -- arrays (which may not be the same, due to either sliding, or to a
105 -- change of representation case). Ndim is the number of dimensions and
106 -- the parameter Rev indicates if the loops run normally (Rev = False),
107 -- or reversed (Rev = True). The value returned is the constructed
108 -- loop statement. Auxiliary declarations are inserted before node N
109 -- using the standard Insert_Actions mechanism.
112 -- N is an assignment of an untagged record value. This routine handles
113 -- the case where the assignment must be made component by component,
114 -- either because the target is not byte aligned, or there is a change
115 -- of representation, or when we have a tagged type with a representation
116 -- clause (this last case is required because holes in the tagged type
117 -- might be filled with components from child types).
120 -- Use the primitives specified in an Iterable aspect to expand a loop
121 -- over a so-called formal container, primarily for SPARK usage.
124 -- Same, for an iterator of the form " For E of C". In this case the
125 -- iterator provides the name of the element, and the cursor is generated
126 -- internally.
129 -- Expand loop over arrays and containers that uses the form "for X of C"
130 -- with an optional subtype mark, or "for Y in C".
132 procedure Expand_Iterator_Loop_Over_Container
138 -- Expand loop over containers that uses the form "for X of C" with an
139 -- optional subtype mark, or "for Y in C". Isc is the iteration scheme.
140 -- I_Spec is the iterator specification and Container is either the
141 -- Container (for OF) or the iterator (for IN).
144 -- Expand for loop over predicated subtype
147 -- Generate the necessary code for controlled and tagged assignment, that
148 -- is to say, finalization of the target before, adjustment of the target
149 -- after and save and restore of the tag and finalization pointers which
150 -- are not 'part of the value' and must not be changed upon assignment. N
151 -- is the original Assignment node.
153 --------------------------------------
154 -- Build_Formal_Container_iteration --
155 --------------------------------------
157 procedure Build_Formal_Container_Iteration
164 is
175 begin
176 -- Declaration for Cursor
178 Init :=
182 Expression =>
188 -- Statement that advances cursor in loop
190 Advance :=
193 Expression =>
200 -- Iterator is rewritten as a while_loop
202 New_Loop :=
204 Iteration_Scheme =>
206 Condition =>
216 ------------------------------
217 -- Change_Of_Representation --
218 ------------------------------
222 begin
223 return
225 and then
229 -------------------------
230 -- Expand_Assign_Array --
231 -------------------------
233 -- There are two issues here. First, do we let Gigi do a block move, or
234 -- do we expand out into a loop? Second, we need to set the two flags
235 -- Forwards_OK and Backwards_OK which show whether the block move (or
236 -- corresponding loops) can be legitimately done in a forwards (low to
237 -- high) or backwards (high to low) manner.
263 -- This switch is set to True if the array move must be done using
264 -- an explicit front end generated loop.
267 -- If the argument is an access to an array, and the assignment is
268 -- converted into a procedure call, apply explicit dereference.
271 -- Test if Exp is a reference to an array whose declaration has
272 -- an address clause, or it is a slice of such an array.
275 -- Test if Exp is a reference to an array which is either a formal
276 -- parameter or a slice of a formal parameter. These are the cases
277 -- where hidden aliasing can occur.
280 -- Determine if Exp is a reference to an array variable which is other
281 -- than an object defined in the current scope, or a slice of such
282 -- an object. Such objects can be aliased to parameters (unlike local
283 -- array references).
285 -----------------------
286 -- Apply_Dereference --
287 -----------------------
291 begin
299 ------------------------
300 -- Has_Address_Clause --
301 ------------------------
304 begin
305 return
308 or else
312 ---------------------
313 -- Is_Formal_Array --
314 ---------------------
317 begin
318 return
320 or else
324 ------------------------
325 -- Is_Non_Local_Array --
326 ------------------------
329 begin
336 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
344 -- Start of processing for Expand_Assign_Array
346 begin
347 -- Deal with length check. Note that the length check is done with
348 -- respect to the right hand side as given, not a possible underlying
349 -- renamed object, since this would generate incorrect extra checks.
353 -- We start by assuming that the move can be done in either direction,
354 -- i.e. that the two sides are completely disjoint.
359 -- Normally it is only the slice case that can lead to overlap, and
360 -- explicit checks for slices are made below. But there is one case
361 -- where the slice can be implicit and invisible to us: when we have a
362 -- one dimensional array, and either both operands are parameters, or
363 -- one is a parameter (which can be a slice passed by reference) and the
364 -- other is a non-local variable. In this case the parameter could be a
365 -- slice that overlaps with the other operand.
367 -- However, if the array subtype is a constrained first subtype in the
368 -- parameter case, then we don't have to worry about overlap, since
369 -- slice assignments aren't possible (other than for a slice denoting
370 -- the whole array).
372 -- Note: No overlap is possible if there is a change of representation,
373 -- so we can exclude this case.
376 and then not Crep
377 and then
379 or else
381 or else
383 and then
386 then
390 -- Note: the bit-packed case is not worrisome here, since if we have
391 -- a slice passed as a parameter, it is always aligned on a byte
392 -- boundary, and if there are no explicit slices, the assignment
393 -- can be performed directly.
396 -- If either operand has an address clause clear Backwards_OK and
397 -- Forwards_OK, since we cannot tell if the operands overlap. We
398 -- exclude this treatment when Rhs is an aggregate, since we know
399 -- that overlap can't occur.
403 then
408 -- We certainly must use a loop for change of representation and also
409 -- we use the operand of the conversion on the right hand side as the
410 -- effective right hand side (the component types must match in this
411 -- situation).
418 -- We require a loop if the left side is possibly bit unaligned
421 or else
423 then
426 -- Arrays with controlled components are expanded into a loop to force
427 -- calls to Adjust at the component level.
432 -- If object is atomic/VFA, we cannot tolerate a loop
435 or else
437 then
440 -- Loop is required if we have atomic components since we have to
441 -- be sure to do any accesses on an element by element basis.
447 then
450 -- Case where no slice is involved
454 -- The following code deals with the case of unconstrained bit packed
455 -- arrays. The problem is that the template for such arrays contains
456 -- the bounds of the actual source level array, but the copy of an
457 -- entire array requires the bounds of the underlying array. It would
458 -- be nice if the back end could take care of this, but right now it
459 -- does not know how, so if we have such a type, then we expand out
460 -- into a loop, which is inefficient but works correctly. If we don't
461 -- do this, we get the wrong length computed for the array to be
462 -- moved. The two cases we need to worry about are:
464 -- Explicit dereference of an unconstrained packed array type as in
465 -- the following example:
467 -- procedure C52 is
468 -- type BITS is array(INTEGER range <>) of BOOLEAN;
469 -- pragma PACK(BITS);
470 -- type A is access BITS;
471 -- P1,P2 : A;
472 -- begin
473 -- P1 := new BITS (1 .. 65_535);
474 -- P2 := new BITS (1 .. 65_535);
475 -- P2.ALL := P1.ALL;
476 -- end C52;
478 -- A formal parameter reference with an unconstrained bit array type
479 -- is the other case we need to worry about (here we assume the same
480 -- BITS type declared above):
482 -- procedure Write_All (File : out BITS; Contents : BITS);
483 -- begin
484 -- File.Storage := Contents;
485 -- end Write_All;
487 -- We expand to a loop in either of these two cases
489 -- Question for future thought. Another potentially more efficient
490 -- approach would be to create the actual subtype, and then do an
491 -- unchecked conversion to this actual subtype ???
496 -- Function to perform required test for the first case, above
497 -- (dereference of an unconstrained bit packed array).
499 -----------------------
500 -- Is_UBPA_Reference --
501 -----------------------
508 begin
512 then
521 else
523 return
528 else
533 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
535 begin
537 or else
539 then
542 -- Here if we do not have the case of a reference to a bit packed
543 -- unconstrained array case. In this case gigi can most certainly
544 -- handle the assignment if a forwards move is allowed.
546 -- (could it handle the backwards case also???)
553 -- The back end can always handle the assignment if the right side is a
554 -- string literal (note that overlap is definitely impossible in this
555 -- case). If the type is packed, a string literal is always converted
556 -- into an aggregate, except in the case of a null slice, for which no
557 -- aggregate can be written. In that case, rewrite the assignment as a
558 -- null statement, a length check has already been emitted to verify
559 -- that the range of the left-hand side is empty.
561 -- Note that this code is not executed if we have an assignment of a
562 -- string literal to a non-bit aligned component of a record, a case
563 -- which cannot be handled by the backend.
568 then
575 -- If either operand is bit packed, then we need a loop, since we can't
576 -- be sure that the slice is byte aligned. Similarly, if either operand
577 -- is a possibly unaligned slice, then we need a loop (since the back
578 -- end cannot handle unaligned slices).
584 then
587 -- If we are not bit-packed, and we have only one slice, then no overlap
588 -- is possible except in the parameter case, so we can let the back end
589 -- handle things.
597 -- If the right-hand side is a string literal, introduce a temporary for
598 -- it, for use in the generated loop that will follow.
601 declare
605 begin
606 Decl :=
618 -- Come here to complete the analysis
620 -- Loop_Required: Set to True if we know that a loop is required
621 -- regardless of overlap considerations.
623 -- Forwards_OK: Set to False if we already know that a forwards
624 -- move is not safe, else set to True.
626 -- Backwards_OK: Set to False if we already know that a backwards
627 -- move is not safe, else set to True
629 -- Our task at this stage is to complete the overlap analysis, which can
630 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
631 -- then generating the final code, either by deciding that it is OK
632 -- after all to let Gigi handle it, or by generating appropriate code
633 -- in the front end.
635 declare
653 begin
654 -- Get the expressions for the arrays. If we are dealing with a
655 -- private type, then convert to the underlying type. We can do
656 -- direct assignments to an array that is a private type, but we
657 -- cannot assign to elements of the array without this extra
658 -- unchecked conversion.
660 -- Note: We propagate Parent to the conversion nodes to generate
661 -- a well-formed subtree.
665 else
669 declare
671 begin
672 Larray :=
673 Unchecked_Convert_To
682 else
686 declare
688 begin
689 Rarray :=
690 Unchecked_Convert_To
697 -- If both sides are slices, we must figure out whether it is safe
698 -- to do the move in one direction or the other. It is always safe
699 -- if there is a change of representation since obviously two arrays
700 -- with different representations cannot possibly overlap.
706 -- If both left and right hand arrays are entity names, and refer
707 -- to different entities, then we know that the move is safe (the
708 -- two storage areas are completely disjoint).
713 then
716 -- Otherwise, we assume the worst, which is that the two arrays
717 -- are the same array. There is no need to check if we know that
718 -- is the case, because if we don't know it, we still have to
719 -- assume it.
721 -- Generally if the same array is involved, then we have an
722 -- overlapping case. We will have to really assume the worst (i.e.
723 -- set neither of the OK flags) unless we can determine the lower
724 -- or upper bounds at compile time and compare them.
726 else
727 Cresult :=
728 Compile_Time_Compare
732 Cresult :=
733 Compile_Time_Compare
746 -- If after that analysis Loop_Required is False, meaning that we
747 -- have not discovered some non-overlap reason for requiring a loop,
748 -- then the outcome depends on the capabilities of the back end.
751 -- Assume the back end can deal with all cases of overlap by
752 -- falling back to memmove if it cannot use a more efficient
753 -- approach.
758 -- At this stage we have to generate an explicit loop, and we have
759 -- the following cases:
761 -- Forwards_OK = True
763 -- Rnn : right_index := right_index'First;
764 -- for Lnn in left-index loop
765 -- left (Lnn) := right (Rnn);
766 -- Rnn := right_index'Succ (Rnn);
767 -- end loop;
769 -- Note: the above code MUST be analyzed with checks off, because
770 -- otherwise the Succ could overflow. But in any case this is more
771 -- efficient.
773 -- Forwards_OK = False, Backwards_OK = True
775 -- Rnn : right_index := right_index'Last;
776 -- for Lnn in reverse left-index loop
777 -- left (Lnn) := right (Rnn);
778 -- Rnn := right_index'Pred (Rnn);
779 -- end loop;
781 -- Note: the above code MUST be analyzed with checks off, because
782 -- otherwise the Pred could overflow. But in any case this is more
783 -- efficient.
785 -- Forwards_OK = Backwards_OK = False
787 -- This only happens if we have the same array on each side. It is
788 -- possible to create situations using overlays that violate this,
789 -- but we simply do not promise to get this "right" in this case.
791 -- There are two possible subcases. If the No_Implicit_Conditionals
792 -- restriction is set, then we generate the following code:
794 -- declare
795 -- T : constant <operand-type> := rhs;
796 -- begin
797 -- lhs := T;
798 -- end;
800 -- If implicit conditionals are permitted, then we generate:
802 -- if Left_Lo <= Right_Lo then
803 -- <code for Forwards_OK = True above>
804 -- else
805 -- <code for Backwards_OK = True above>
806 -- end if;
808 -- In order to detect possible aliasing, we examine the renamed
809 -- expression when the source or target is a renaming. However,
810 -- the renaming may be intended to capture an address that may be
811 -- affected by subsequent code, and therefore we must recover
812 -- the actual entity for the expansion that follows, not the
813 -- object it renames. In particular, if source or target designate
814 -- a portion of a dynamically allocated object, the pointer to it
815 -- may be reassigned but the renaming preserves the proper location.
818 and then
821 then
826 and then
829 then
833 -- Cases where either Forwards_OK or Backwards_OK is true
840 then
841 declare
846 begin
858 New_Occurrence_Of (
867 else
869 Expand_Assign_Array_Loop
874 -- Case of both are false with No_Implicit_Conditionals
877 declare
881 begin
888 Object_Definition =>
892 Handled_Statement_Sequence =>
900 -- Case of both are false with implicit conditionals allowed
902 else
903 -- Before we generate this code, we must ensure that the left and
904 -- right side array types are defined. They may be itypes, and we
905 -- cannot let them be defined inside the if, since the first use
906 -- in the then may not be executed.
911 -- We normally compare addresses to find out which way round to
912 -- do the loop, since this is reliable, and handles the cases of
913 -- parameters, conversions etc. But we can't do that in the bit
914 -- packed case, because addresses don't work there.
917 Condition :=
919 Left_Opnd =>
922 Prefix =>
924 Prefix =>
928 Prefix =>
929 New_Occurrence_Of
934 Right_Opnd =>
937 Prefix =>
939 Prefix =>
943 Prefix =>
944 New_Occurrence_Of
949 -- For the bit packed and VM cases we use the bounds. That's OK,
950 -- because we don't have to worry about parameters, since they
951 -- cannot cause overlap. Perhaps we should worry about weird slice
952 -- conversions ???
954 else
955 -- Copy the bounds
960 -- If the types do not match we add an implicit conversion
961 -- here to ensure proper match
964 Cright_Lo :=
968 -- Reset the Analyzed flag, because the bounds of the index
969 -- type itself may be universal, and must must be reanalyzed
970 -- to acquire the proper type for the back end.
975 Condition :=
985 then
987 -- Call TSS procedure for array assignment, passing the
988 -- explicit bounds of right and left hand sides.
990 declare
995 begin
1016 else
1022 Expand_Assign_Array_Loop
1027 Expand_Assign_Array_Loop
1036 exception
1041 ------------------------------
1042 -- Expand_Assign_Array_Loop --
1043 ------------------------------
1045 -- The following is an example of the loop generated for the case of a
1046 -- two-dimensional array:
1048 -- declare
1049 -- R2b : Tm1X1 := 1;
1050 -- begin
1051 -- for L1b in 1 .. 100 loop
1052 -- declare
1053 -- R4b : Tm1X2 := 1;
1054 -- begin
1055 -- for L3b in 1 .. 100 loop
1056 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
1057 -- R4b := Tm1X2'succ(R4b);
1058 -- end loop;
1059 -- end;
1060 -- R2b := Tm1X1'succ(R2b);
1061 -- end loop;
1062 -- end;
1064 -- Here Rev is False, and Tm1Xn are the subscript types for the right hand
1065 -- side. The declarations of R2b and R4b are inserted before the original
1066 -- assignment statement.
1068 function Expand_Assign_Array_Loop
1076 is
1081 -- Entities used as subscripts on left and right sides
1085 -- Left and right index types
1093 -- The increment step for the index of the right-hand side is written
1094 -- as an attribute reference (Succ or Pred). This function returns
1095 -- the corresponding node, which is placed at the end of the loop body.
1097 ----------------
1098 -- Build_Step --
1099 ----------------
1105 begin
1108 else
1112 Step :=
1115 Expression =>
1117 Prefix =>
1123 -- Note that on the last iteration of the loop, the index is increased
1124 -- (or decreased) past the corresponding bound. This is consistent with
1125 -- the C semantics of the back-end, where such an off-by-one value on a
1126 -- dead index variable is OK. However, in CodePeer mode this leads to
1127 -- spurious warnings, and thus we place a guard around the attribute
1128 -- reference. For obvious reasons we only do this for CodePeer.
1131 Step :=
1133 Condition =>
1136 Right_Opnd =>
1146 -- Start of processing for Expand_Assign_Array_Loop
1148 begin
1152 else
1157 -- Setup index types and subscript entities
1159 declare
1163 begin
1179 -- Now construct the assignment statement
1181 declare
1185 begin
1191 Assign :=
1193 Name =>
1197 Expression =>
1202 -- We set assignment OK, since there are some cases, e.g. in object
1203 -- declarations, where we are actually assigning into a constant.
1204 -- If there really is an illegality, it was caught long before now,
1205 -- and was flagged when the original assignment was analyzed.
1209 -- Propagate the No_Ctrl_Actions flag to individual assignments
1214 -- Now construct the loop from the inside out, with the last subscript
1215 -- varying most rapidly. Note that Assign is first the raw assignment
1216 -- statement, and then subsequently the loop that wraps it up.
1219 Assign :=
1224 Object_Definition =>
1226 Expression =>
1231 Handled_Statement_Sequence =>
1235 Iteration_Scheme =>
1237 Loop_Parameter_Specification =>
1241 Discrete_Subtype_Definition =>
1250 --------------------------
1251 -- Expand_Assign_Record --
1252 --------------------------
1259 begin
1260 -- If change of representation, then extract the real right hand side
1261 -- from the type conversion, and proceed with component-wise assignment,
1262 -- since the two types are not the same as far as the back end is
1263 -- concerned.
1268 -- If this may be a case of a large bit aligned component, then proceed
1269 -- with component-wise assignment, to avoid possible clobbering of other
1270 -- components sharing bits in the first or last byte of the component to
1271 -- be assigned.
1274 or
1276 then
1279 -- If we have a tagged type that has a complete record representation
1280 -- clause, we must do we must do component-wise assignments, since child
1281 -- types may have used gaps for their components, and we might be
1282 -- dealing with a view conversion.
1287 -- If neither condition met, then nothing special to do, the back end
1288 -- can handle assignment of the entire component as a single entity.
1290 else
1294 -- At this stage we know that we must do a component wise assignment
1296 declare
1303 function Find_Component
1306 -- Find the component with the given name in the underlying record
1307 -- declaration for Typ. We need to use the actual entity because the
1308 -- type may be private and resolution by identifier alone would fail.
1310 function Make_Component_List_Assign
1313 -- Returns a sequence of statements to assign the components that
1314 -- are referenced in the given component list. The flag U_U is
1315 -- used to force the usage of the inferred value of the variant
1316 -- part expression as the switch for the generated case statement.
1318 function Make_Field_Assign
1321 -- Given C, the entity for a discriminant or component, build an
1322 -- assignment for the corresponding field values. The flag U_U
1323 -- signals the presence of an Unchecked_Union and forces the usage
1324 -- of the inferred discriminant value of C as the right hand side
1325 -- of the assignment.
1328 -- Given CI, a component items list, construct series of statements
1329 -- for fieldwise assignment of the corresponding components.
1331 --------------------
1332 -- Find_Component --
1333 --------------------
1335 function Find_Component
1338 is
1342 begin
1355 --------------------------------
1356 -- Make_Component_List_Assign --
1357 --------------------------------
1359 function Make_Component_List_Assign
1362 is
1373 begin
1390 Statements =>
1395 -- If we have an Unchecked_Union, use the value of the inferred
1396 -- discriminant of the variant part expression as the switch
1397 -- for the case statement. The case statement may later be
1398 -- folded.
1401 Expr :=
1406 else
1407 Expr :=
1410 Selector_Name =>
1423 -----------------------
1424 -- Make_Field_Assign --
1425 -----------------------
1427 function Make_Field_Assign
1430 is
1434 begin
1435 -- In the case of an Unchecked_Union, use the discriminant
1436 -- constraint value as on the right hand side of the assignment.
1439 Expr :=
1443 else
1444 Expr :=
1450 A :=
1452 Name =>
1455 Selector_Name =>
1459 -- Set Assignment_OK, so discriminants can be assigned
1466 then
1473 ------------------------
1474 -- Make_Field_Assigns --
1475 ------------------------
1481 begin
1487 -- Look for components, but exclude _tag field assignment if
1488 -- the special Componentwise_Assignment flag is set.
1493 then
1494 Append_To
1504 -- Start of processing for Expand_Assign_Record
1506 begin
1507 -- Note that we use the base types for this processing. This results
1508 -- in some extra work in the constrained case, but the change of
1509 -- representation case is so unusual that it is not worth the effort.
1511 -- First copy the discriminants. This is done unconditionally. It
1512 -- is required in the unconstrained left side case, and also in the
1513 -- case where this assignment was constructed during the expansion
1514 -- of a type conversion (since initialization of discriminants is
1515 -- suppressed in this case). It is unnecessary but harmless in
1516 -- other cases.
1522 -- If we are expanding the initialization of a derived record
1523 -- that constrains or renames discriminants of the parent, we
1524 -- must use the corresponding discriminant in the parent.
1526 declare
1529 begin
1530 if Inside_Init_Proc
1532 then
1534 else
1540 -- Within an initialization procedure this is the
1541 -- assignment to an unchecked union component, in which
1542 -- case there is no discriminant to initialize.
1547 else
1548 -- The assignment is part of a conversion from a
1549 -- derived unchecked union type with an inferable
1550 -- discriminant, to a parent type.
1555 else
1564 -- We know the underlying type is a record, but its current view
1565 -- may be private. We must retrieve the usable record declaration.
1568 N_Private_Extension_Declaration)
1570 then
1572 else
1582 then
1586 else
1587 Insert_Actions
1596 -----------------------------------
1597 -- Expand_N_Assignment_Statement --
1598 -----------------------------------
1600 -- This procedure implements various cases where an assignment statement
1601 -- cannot just be passed on to the back end in untransformed state.
1613 begin
1614 -- The assignment statement is Ghost when the left hand side is Ghost.
1615 -- Set the mode now to ensure that any nodes generated during expansion
1616 -- are properly marked as Ghost.
1620 -- Special case to check right away, if the Componentwise_Assignment
1621 -- flag is set, this is a reanalysis from the expansion of the primitive
1622 -- assignment procedure for a tagged type, and all we need to do is to
1623 -- expand to assignment of components, because otherwise, we would get
1624 -- infinite recursion (since this looks like a tagged assignment which
1625 -- would normally try to *call* the primitive assignment procedure).
1633 -- Defend against invalid subscripts on left side if we are in standard
1634 -- validity checking mode. No need to do this if we are checking all
1635 -- subscripts.
1637 -- Note that we do this right away, because there are some early return
1638 -- paths in this procedure, and this is required on all paths.
1640 if Validity_Checks_On
1641 and then Validity_Check_Default
1642 and then not Validity_Check_Subscripts
1643 then
1647 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
1649 -- Rewrite an assignment to X'Priority into a run-time call
1651 -- For example: X'Priority := New_Prio_Expr;
1652 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
1654 -- Note that although X'Priority is notionally an object, it is quite
1655 -- deliberately not defined as an aliased object in the RM. This means
1656 -- that it works fine to rewrite it as a call, without having to worry
1657 -- about complications that would other arise from X'Priority'Access,
1658 -- which is illegal, because of the lack of aliasing.
1661 declare
1668 begin
1669 -- Handle chains of renamings
1675 loop
1679 -- The attribute Priority applied to protected objects has been
1680 -- previously expanded into a call to the Get_Ceiling run-time
1681 -- subprogram. In restricted profiles this is not available.
1685 -- Look for the enclosing concurrent type
1694 -- Generate the first actual of the call
1701 -- Select the appropriate run-time call
1704 RT_Subprg_Name :=
1706 else
1707 RT_Subprg_Name :=
1711 Call :=
1727 -- Deal with assignment checks unless suppressed
1731 -- First deal with generation of range check if required
1737 -- Then generate predicate check if required
1742 -- Check for a special case where a high level transformation is
1743 -- required. If we have either of:
1745 -- P.field := rhs;
1746 -- P (sub) := rhs;
1748 -- where P is a reference to a bit packed array, then we have to unwind
1749 -- the assignment. The exact meaning of being a reference to a bit
1750 -- packed array is as follows:
1752 -- An indexed component whose prefix is a bit packed array is a
1753 -- reference to a bit packed array.
1755 -- An indexed component or selected component whose prefix is a
1756 -- reference to a bit packed array is itself a reference ot a
1757 -- bit packed array.
1759 -- The required transformation is
1761 -- Tnn : prefix_type := P;
1762 -- Tnn.field := rhs;
1763 -- P := Tnn;
1765 -- or
1767 -- Tnn : prefix_type := P;
1768 -- Tnn (subscr) := rhs;
1769 -- P := Tnn;
1771 -- Since P is going to be evaluated more than once, any subscripts
1772 -- in P must have their evaluation forced.
1776 then
1777 declare
1783 begin
1784 -- Insert the post assignment first, because we want to copy the
1785 -- BPAR_Expr tree before it gets analyzed in the context of the
1786 -- pre assignment. Note that we do not analyze the post assignment
1787 -- yet (we cannot till we have completed the analysis of the pre
1788 -- assignment). As usual, the analysis of this post assignment
1789 -- will happen on its own when we "run into" it after finishing
1790 -- the current assignment.
1797 -- At this stage BPAR_Expr is a reference to a bit packed array
1798 -- where the reference was not expanded in the original tree,
1799 -- since it was on the left side of an assignment. But in the
1800 -- pre-assignment statement (the object definition), BPAR_Expr
1801 -- will end up on the right hand side, and must be reexpanded. To
1802 -- achieve this, we reset the analyzed flag of all selected and
1803 -- indexed components down to the actual indexed component for
1804 -- the packed array.
1807 loop
1810 if Nkind_In
1812 then
1814 else
1819 -- Now we can insert and analyze the pre-assignment
1821 -- If the right-hand side requires a transient scope, it has
1822 -- already been placed on the stack. However, the declaration is
1823 -- inserted in the tree outside of this scope, and must reflect
1824 -- the proper scope for its variable. This awkward bit is forced
1825 -- by the stricter scope discipline imposed by GCC 2.97.
1827 declare
1829 Scope_Is_Transient
1832 begin
1844 Pop_Scope;
1848 -- Now fix up the original assignment and continue processing
1853 -- We do not need to reanalyze that assignment, and we do not need
1854 -- to worry about references to the temporary, but we do need to
1855 -- make sure that the temporary is not marked as a true constant
1856 -- since we now have a generated assignment to it.
1862 -- When we have the appropriate type of aggregate in the expression (it
1863 -- has been determined during analysis of the aggregate by setting the
1864 -- delay flag), let's perform in place assignment and thus avoid
1865 -- creating a temporary.
1876 -- Apply discriminant check if required. If Lhs is an access type to a
1877 -- designated type with discriminants, we must always check. If the
1878 -- type has unknown discriminants, more elaborate processing below.
1882 then
1883 -- Skip discriminant check if change of representation. Will be
1884 -- done when the change of representation is expanded out.
1890 -- If the type is private without discriminants, and the full type
1891 -- has discriminants (necessarily with defaults) a check may still be
1892 -- necessary if the Lhs is aliased. The private discriminants must be
1893 -- visible to build the discriminant constraints.
1895 -- Only an explicit dereference that comes from source indicates
1896 -- aliasing. Access to formals of protected operations and entries
1897 -- create dereferences but are not semantic aliasings.
1903 then
1904 declare
1908 begin
1909 -- In the case of an expander-generated record subtype whose base
1910 -- type still appears private, Typ will have been set to that
1911 -- private type rather than the underlying record type (because
1912 -- Underlying type will have returned the record subtype), so it's
1913 -- necessary to apply Underlying_Type again to the base type to
1914 -- get the record type we need for the discriminant check. Such
1915 -- subtypes can be created for assignments in certain cases, such
1916 -- as within an instantiation passed this kind of private type.
1917 -- It would be good to avoid this special test, but making changes
1918 -- to prevent this odd form of record subtype seems difficult. ???
1930 -- If the Lhs has a private type with unknown discriminants, it may
1931 -- have a full view with discriminants, but those are nameable only
1932 -- in the underlying type, so convert the Rhs to it before potential
1933 -- checking. Convert Lhs as well, otherwise the actual subtype might
1934 -- not be constructible. If the discriminants have defaults the type
1935 -- is unconstrained and there is nothing to check.
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
2006 -- If an actual is an out parameter of a null-excluding access
2007 -- type, there is access check on entry, so we set the flag
2008 -- Suppress_Assignment_Checks on the generated statement to
2009 -- assign the actual to the parameter block, and we do not want
2010 -- to generate an additional check at this point.
2013 then
2017 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2018 -- stand-alone obj of an anonymous access type. Do not install the check
2019 -- when the Lhs denotes a container cursor and the Next function employs
2020 -- an access type, because this can never result in a dangling pointer.
2026 then
2027 declare
2029 -- Look through renames to find the underlying entity.
2030 -- For assignment to a rename, we don't care about the
2031 -- Enclosing_Dynamic_Scope of the rename declaration.
2033 ----------------
2034 -- Lhs_Entity --
2035 ----------------
2040 begin
2043 -- Renamed_Object must return an Entity_Name here
2044 -- because of preceding "Present (E_E_A (...))" test.
2052 -- Local Declarations
2056 Condition =>
2058 Left_Opnd =>
2060 Right_Opnd =>
2062 Intval =>
2063 Scope_Depth
2064 (Enclosing_Dynamic_Scope
2070 Name =>
2071 New_Occurrence_Of
2072 (Effective_Extra_Accessibility
2074 Expression =>
2077 begin
2086 -- Case of assignment to a bit packed array element. If there is a
2087 -- change of representation this must be expanded into components,
2088 -- otherwise this is a bit-field assignment.
2092 then
2093 -- Normal case, no change of representation
2100 -- Change of representation case
2102 else
2103 -- Generate the following, to force component-by-component
2104 -- assignments in an efficient way. Otherwise each component
2105 -- will require a temporary and two bit-field manipulations.
2107 -- T1 : Elmt_Type;
2108 -- T1 := RhS;
2109 -- Lhs := T1;
2111 declare
2115 begin
2116 Stats :=
2117 New_List (
2120 Object_Definition =>
2135 -- Build-in-place function call case. Note that we're not yet doing
2136 -- build-in-place for user-written assignment statements (the assignment
2137 -- here came from an aggregate.)
2141 then
2146 then
2151 begin
2152 -- In the controlled case, we ensure that function calls are
2153 -- evaluated before finalizing the target. In all cases, it makes
2154 -- the expansion easier if the side-effects are removed first.
2159 -- Avoid recursion in the mechanism
2163 -- If dispatching assignment, we need to dispatch to _assign
2167 -- If the type is tagged, we may as well use the predefined
2168 -- primitive assignment. This avoids inlining a lot of code
2169 -- and in the class-wide case, the assignment is replaced
2170 -- by a dispatching call to _assign. It is suppressed in the
2171 -- case of assignments created by the expander that correspond
2172 -- to initializations, where we do want to copy the tag
2173 -- (Expand_Ctrl_Actions flag is set False in this case). It is
2174 -- also suppressed if restriction No_Dispatching_Calls is in
2175 -- force because in that case predefined primitives are not
2176 -- generated.
2180 and then Expand_Ctrl_Actions
2181 and then
2183 then
2186 -- This can happen in an instance when the formal is an
2187 -- extension of a limited interface, and the actual is
2188 -- limited. This is an error according to AI05-0087, but
2189 -- is not caught at the point of instantiation in earlier
2190 -- versions.
2192 -- This is wrong, error messages cannot be issued during
2193 -- expansion, since they would be missed in -gnatc mode ???
2200 -- Fetch the primitive op _assign and proper type to call it.
2201 -- Because of possible conflicts between private and full view,
2202 -- fetch the proper type directly from the operation profile.
2204 declare
2209 begin
2210 -- If the assignment is dispatching, make sure to use the
2211 -- proper type.
2219 -- In case of assignment to a class-wide tagged type, before
2220 -- the assignment we generate run-time check to ensure that
2221 -- the tags of source and target match.
2227 then
2228 declare
2232 begin
2234 Lhs_Tag :=
2237 Selector_Name =>
2239 Rhs_Tag :=
2242 Selector_Name =>
2244 else
2245 -- Displace the pointer to the base of the objects
2246 -- applying 'Address, which is later expanded into
2247 -- a call to RE_Base_Address.
2249 Lhs_Tag :=
2251 Prefix =>
2256 Rhs_Tag :=
2258 Prefix =>
2267 Condition =>
2275 declare
2279 begin
2280 -- In order to dispatch the call to _assign the type of
2281 -- the actuals must match. Add conversion (if required).
2300 else
2303 -- We can't afford to have destructive Finalization Actions in
2304 -- the Self assignment case, so if the target and the source
2305 -- are not obviously different, code is generated to avoid the
2306 -- self assignment case:
2308 -- if lhs'address /= rhs'address then
2309 -- <code for controlled and/or tagged assignment>
2310 -- end if;
2312 -- Skip this if Restriction (No_Finalization) is active
2315 and then Expand_Ctrl_Actions
2317 then
2320 Condition =>
2322 Left_Opnd =>
2327 Right_Opnd =>
2335 -- We need to set up an exception handler for implementing
2336 -- 7.6.1(18). The remaining adjustments are tackled by the
2337 -- implementation of adjust for record_controllers (see
2338 -- s-finimp.adb).
2340 -- This is skipped if we have no finalization
2342 if Expand_Ctrl_Actions
2344 then
2347 Handled_Statement_Sequence =>
2357 Handled_Statement_Sequence =>
2360 -- If no restrictions on aborts, protect the whole assignment
2361 -- for controlled objects as per 9.8(11).
2364 and then Expand_Ctrl_Actions
2365 and then Abort_Allowed
2366 then
2367 declare
2369 New_Internal_Entity
2373 begin
2382 -- Present the Abort_Undefer_Direct function to the backend
2383 -- so that it can inline the call to the function.
2387 Expand_At_End_Handler
2392 -- N has been rewritten to a block statement for which it is
2393 -- known by construction that no checks are necessary: analyze
2394 -- it with all checks suppressed.
2401 -- Array types
2404 declare
2407 begin
2409 N_Qualified_Expression)
2410 loop
2419 -- Record types
2426 -- Scalar types. This is where we perform the processing related to the
2427 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
2428 -- scalar values.
2432 -- Case where right side is known valid
2436 -- Here the right side is valid, so it is fine. The case to deal
2437 -- with is when the left side is a local variable reference whose
2438 -- value is not currently known to be valid. If this is the case,
2439 -- and the assignment appears in an unconditional context, then
2440 -- we can mark the left side as now being valid if one of these
2441 -- conditions holds:
2443 -- The expression of the right side has Do_Range_Check set so
2444 -- that we know a range check will be performed. Note that it
2445 -- can be the case that a range check is omitted because we
2446 -- make the assumption that we can assume validity for operands
2447 -- appearing in the right side in determining whether a range
2448 -- check is required
2450 -- The subtype of the right side matches the subtype of the
2451 -- left side. In this case, even though we have not checked
2452 -- the range of the right side, we know it is in range of its
2453 -- subtype if the expression is valid.
2458 then
2461 then
2466 -- Case where right side may be invalid in the sense of the RM
2467 -- reference above. The RM does not require that we check for the
2468 -- validity on an assignment, but it does require that the assignment
2469 -- of an invalid value not cause erroneous behavior.
2471 -- The general approach in GNAT is to use the Is_Known_Valid flag
2472 -- to avoid the need for validity checking on assignments. However
2473 -- in some cases, we have to do validity checking in order to make
2474 -- sure that the setting of this flag is correct.
2476 else
2477 -- Validate right side if we are validating copies
2479 if Validity_Checks_On
2480 and then Validity_Check_Copies
2481 then
2482 -- Skip this if left hand side is an array or record component
2483 -- and elementary component validity checks are suppressed.
2486 and then not Validity_Check_Components
2487 then
2489 else
2493 -- We can propagate this to the left side where appropriate
2498 then
2502 -- Otherwise check to see what should be done
2504 -- If left side is a local variable, then we just set its flag to
2505 -- indicate that its value may no longer be valid, since we are
2506 -- copying a potentially invalid value.
2511 -- Check for case of a nonlocal variable on the left side which
2512 -- is currently known to be valid. In this case, we simply ensure
2513 -- that the right side is valid. We only play the game of copying
2514 -- validity status for local variables, since we are doing this
2515 -- statically, not by tracing the full flow graph.
2519 then
2520 -- Note: If Validity_Checking mode is set to none, we ignore
2521 -- the Ensure_Valid call so don't worry about that case here.
2525 -- In all other cases, we can safely copy an invalid value without
2526 -- worrying about the status of the left side. Since it is not a
2527 -- variable reference it will not be considered
2528 -- as being known to be valid in any case.
2530 else
2538 exception
2544 ------------------------------
2545 -- Expand_N_Block_Statement --
2546 ------------------------------
2548 -- Encode entity names defined in block statement
2551 begin
2555 -----------------------------
2556 -- Expand_N_Case_Statement --
2557 -----------------------------
2568 begin
2569 -- Check for the situation where we know at compile time which branch
2570 -- will be taken.
2572 -- If the value is static but its subtype is predicated and the value
2573 -- does not obey the predicate, the value is marked non-static, and
2574 -- there can be no corresponding static alternative. In that case we
2575 -- replace the case statement with an exception, regardless of whether
2576 -- assertions are enabled or not, unless predicates are ignored.
2582 then
2591 then
2594 -- Do not consider controlled objects found in a case statement which
2595 -- actually models a case expression because their early finalization
2596 -- will affect the result of the expression.
2602 -- Move statements from this alternative after the case statement.
2603 -- They are already analyzed, so will be skipped by the analyzer.
2607 -- That leaves the case statement as a shell. So now we can kill all
2608 -- other alternatives in the case statement.
2612 declare
2615 begin
2616 -- Loop through case alternatives, skipping pragmas, and skipping
2617 -- the one alternative that we select (and therefore retain).
2623 then
2635 -- Here if the choice is not determined at compile time
2637 declare
2646 begin
2650 else
2654 -- First step is to worry about possible invalid argument. The RM
2655 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
2656 -- outside the base range), then Constraint_Error must be raised.
2658 -- Case of validity check required (validity checks are on, the
2659 -- expression is not known to be valid, and the case statement
2660 -- comes from source -- no need to validity check internally
2661 -- generated case statements).
2663 if Validity_Check_Default
2665 then
2669 -- If there is only a single alternative, just replace it with the
2670 -- sequence of statements since obviously that is what is going to
2671 -- be executed in all cases.
2677 -- We still need to evaluate the expression if it has any side
2678 -- effects.
2683 -- Do not consider controlled objects found in a case statement
2684 -- which actually models a case expression because their early
2685 -- finalization will affect the result of the expression.
2693 -- That leaves the case statement as a shell. The alternative that
2694 -- will be executed is reset to a null list. So now we can kill
2695 -- the entire case statement.
2701 -- An optimization. If there are only two alternatives, and only
2702 -- a single choice, then rewrite the whole case statement as an
2703 -- if statement, since this can result in subsequent optimizations.
2704 -- This helps not only with case statements in the source of a
2705 -- simple form, but also with generated code (discriminant check
2706 -- functions in particular).
2708 -- Note: it is OK to do this before expanding out choices for any
2709 -- static predicates, since the if statement processing will handle
2710 -- the static predicate case fine.
2721 -- For TRUE, generate "expression", not expression = true
2725 then
2728 -- For FALSE, generate "expression" and switch then/else
2732 then
2737 -- For a range, generate "expression in range"
2744 then
2745 Cond :=
2750 -- A subtype indication is not a legal operator in a membership
2751 -- test, so retrieve its range.
2754 Cond :=
2757 Right_Opnd =>
2758 Relocate_Node
2761 -- For any other subexpression "expression = value"
2763 else
2764 Cond :=
2770 -- Now rewrite the case as an IF
2782 -- If the last alternative is not an Others choice, replace it with
2783 -- an N_Others_Choice. Note that we do not bother to call Analyze on
2784 -- the modified case statement, since it's only effect would be to
2785 -- compute the contents of the Others_Discrete_Choices which is not
2786 -- needed by the back end anyway.
2788 -- The reason for this is that the back end always needs some default
2789 -- for a switch, so if we have not supplied one in the processing
2790 -- above for validity checking, then we need to supply one here.
2795 -- If Predicates_Ignored is true the value does not satisfy the
2796 -- predicate, and there is no Others choice, Constraint_Error
2797 -- must be raised (4.5.7 (21/3)).
2800 declare
2810 begin
2815 else
2816 Set_Others_Discrete_Choices
2823 -- Deal with possible declarations of controlled objects, and also
2824 -- with rewriting choice sequences for static predicate references.
2829 -- Do not consider controlled objects found in a case statement
2830 -- which actually models a case expression because their early
2831 -- finalization will affect the result of the expression.
2846 -----------------------------
2847 -- Expand_N_Exit_Statement --
2848 -----------------------------
2850 -- The only processing required is to deal with a possible C/Fortran
2851 -- boolean value used as the condition for the exit statement.
2854 begin
2858 ----------------------------------
2859 -- Expand_Formal_Container_Loop --
2860 ----------------------------------
2875 begin
2876 -- The expansion resembles the one for Ada containers, but the
2877 -- primitives mention the domain of iteration explicitly, and
2878 -- function First applied to the container yields a cursor directly.
2880 -- Cursor : Cursor_type := First (Container);
2881 -- while Has_Element (Cursor, Container) loop
2882 -- <original loop statements>
2883 -- Cursor := Next (Container, Cursor);
2884 -- end loop;
2886 Build_Formal_Container_Iteration
2892 -- Build block to capture declaration of cursor entity.
2894 Blk_Nod :=
2897 Handled_Statement_Sequence =>
2905 ------------------------------------------
2906 -- Expand_Formal_Container_Element_Loop --
2907 ------------------------------------------
2931 begin
2932 -- For an element iterator, the Element aspect must be present,
2933 -- (this is checked during analysis) and the expansion takes the form:
2935 -- Cursor : Cursor_type := First (Container);
2936 -- Elmt : Element_Type;
2937 -- while Has_Element (Cursor, Container) loop
2938 -- Elmt := Element (Container, Cursor);
2939 -- <original loop statements>
2940 -- Cursor := Next (Container, Cursor);
2941 -- end loop;
2943 -- However this expansion is not legal if the element is indefinite.
2944 -- In that case we create a block to hold a variable declaration
2945 -- initialized with a call to Element, and generate:
2947 -- Cursor : Cursor_type := First (Container);
2948 -- while Has_Element (Cursor, Container) loop
2949 -- declare
2950 -- Elmt : Element-Type := Element (Container, Cursor);
2951 -- begin
2952 -- <original loop statements>
2953 -- Cursor := Next (Container, Cursor);
2954 -- end;
2955 -- end loop;
2957 Build_Formal_Container_Iteration
2964 -- Declaration for Element.
2966 Elmt_Decl :=
2980 New_List
2983 Handled_Statement_Sequence =>
2987 else
2988 Elmt_Ref :=
2991 Expression =>
3000 -- The element is assignable in the expanded code
3004 -- The loop is rewritten as a block, to hold the element declaration
3006 New_Loop :=
3009 Handled_Statement_Sequence =>
3014 -- The element is only modified in expanded code, so it appears as
3015 -- unassigned to the warning machinery. We must suppress this spurious
3016 -- warning explicitly.
3022 -- The loop parameter is declared by an object declaration, but within
3023 -- the loop we must prevent user assignments to it, so we analyze the
3024 -- declaration and reset the entity kind, before analyzing the rest of
3025 -- the loop;
3033 -----------------------------
3034 -- Expand_N_Goto_Statement --
3035 -----------------------------
3037 -- Add poll before goto if polling active
3040 begin
3044 ---------------------------
3045 -- Expand_N_If_Statement --
3046 ---------------------------
3048 -- First we deal with the case of C and Fortran convention boolean values,
3049 -- with zero/non-zero semantics.
3051 -- Second, we deal with the obvious rewriting for the cases where the
3052 -- condition of the IF is known at compile time to be True or False.
3054 -- Third, we remove elsif parts which have non-empty Condition_Actions and
3055 -- rewrite as independent if statements. For example:
3057 -- if x then xs
3058 -- elsif y then ys
3059 -- ...
3060 -- end if;
3062 -- becomes
3063 --
3064 -- if x then xs
3065 -- else
3066 -- <<condition actions of y>>
3067 -- if y then ys
3068 -- ...
3069 -- end if;
3070 -- end if;
3072 -- This rewriting is needed if at least one elsif part has a non-empty
3073 -- Condition_Actions list. We also do the same processing if there is a
3074 -- constant condition in an elsif part (in conjunction with the first
3075 -- processing step mentioned above, for the recursive call made to deal
3076 -- with the created inner if, this deals with properly optimizing the
3077 -- cases of constant elsif conditions).
3087 -- Indicates whether we want warnings when we delete branches of the
3088 -- if statement based on constant condition analysis. We never want
3089 -- these warnings for expander generated code.
3091 begin
3092 -- Do not consider controlled objects found in an if statement which
3093 -- actually models an if expression because their early finalization
3094 -- will affect the result of the expression.
3102 -- The following loop deals with constant conditions for the IF. We
3103 -- need a loop because as we eliminate False conditions, we grab the
3104 -- first elsif condition and use it as the primary condition.
3108 -- If condition is True, we can simply rewrite the if statement now
3109 -- by replacing it by the series of then statements.
3113 -- All the else parts can be killed
3123 -- If condition is False, then we can delete the condition and
3124 -- the Then statements
3126 else
3127 -- We do not delete the condition if constant condition warnings
3128 -- are enabled, since otherwise we end up deleting the desired
3129 -- warning. Of course the backend will get rid of this True/False
3130 -- test anyway, so nothing is lost here.
3138 -- If there are no elsif statements, then we simply replace the
3139 -- entire if statement by the sequence of else statements.
3144 then
3147 else
3155 -- If there are elsif statements, the first of them becomes the
3156 -- if/then section of the rebuilt if statement This is the case
3157 -- where we loop to reprocess this copied condition.
3159 else
3165 -- Hed might have been captured as the condition determining
3166 -- the current value for an entity. Now it is detached from
3167 -- the tree, so a Current_Value pointer in the condition might
3168 -- need to be updated.
3179 -- Loop through elsif parts, dealing with constant conditions and
3180 -- possible condition actions that are present.
3186 -- Do not consider controlled objects found in an if statement
3187 -- which actually models an if expression because their early
3188 -- finalization will affect the result of the expression.
3196 -- If there are condition actions, then rewrite the if statement
3197 -- as indicated above. We also do the same rewrite for a True or
3198 -- False condition. The further processing of this constant
3199 -- condition is then done by the recursive call to expand the
3200 -- newly created if statement
3204 then
3205 -- Note this is not an implicit if statement, since it is part
3206 -- of an explicit if statement in the source (or of an implicit
3207 -- if statement that has already been tested).
3209 New_If :=
3216 -- Elsif parts for new if come from remaining elsif's of parent
3241 -- No special processing for that elsif part, move to next
3243 else
3249 -- Some more optimizations applicable if we still have an IF statement
3255 -- Another optimization, special cases that can be simplified
3257 -- if expression then
3258 -- return true;
3259 -- else
3260 -- return false;
3261 -- end if;
3263 -- can be changed to:
3265 -- return expression;
3267 -- and
3269 -- if expression then
3270 -- return false;
3271 -- else
3272 -- return true;
3273 -- end if;
3275 -- can be changed to:
3277 -- return not (expression);
3279 -- Only do these optimizations if we are at least at -O1 level and
3280 -- do not do them if control flow optimizations are suppressed.
3284 then
3290 then
3291 declare
3295 begin
3297 and then
3299 then
3300 declare
3304 begin
3306 and then
3308 then
3311 then
3320 then
3323 Expression =>
3325 Right_Opnd =>
3338 --------------------------
3339 -- Expand_Iterator_Loop --
3340 --------------------------
3349 begin
3350 -- Processing for arrays
3359 else
3363 -- Processing for containers
3365 else
3366 Expand_Iterator_Loop_Over_Container
3371 -------------------------------------
3372 -- Expand_Iterator_Loop_Over_Array --
3373 -------------------------------------
3389 -- Start of processing for Expand_Iterator_Loop_Over_Array
3391 begin
3392 -- for Element of Array loop
3394 -- It requires an internally generated cursor to iterate over the array
3400 -- Generate:
3401 -- Element : Component_Type renames Array (Iterator);
3402 -- Iterator is the index value, or a list of index values
3403 -- in the case of a multidimensional array.
3405 Ind_Comp :=
3413 Subtype_Mark =>
3417 -- Mark the loop variable as needing debug info, so that expansion
3418 -- of the renaming will result in Materialize_Entity getting set via
3419 -- Debug_Renaming_Declaration. (This setting is needed here because
3420 -- the setting in Freeze_Entity comes after the expansion, which is
3421 -- too late. ???)
3425 -- Generate:
3427 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
3428 -- Element : Component_Type renames Array (Iterator);
3429 -- <original loop statements>
3430 -- end loop;
3432 -- If this is an iteration over a multidimensional array, the
3433 -- innermost loop is over the last dimension in Ada, and over
3434 -- the first dimension in Fortran.
3438 else
3442 Core_Loop :=
3444 Iteration_Scheme =>
3446 Loop_Parameter_Specification =>
3449 Discrete_Subtype_Definition =>
3459 -- Processing for multidimensional array. The body of each loop is
3460 -- a loop over a previous dimension, going in decreasing order in Ada
3461 -- and in increasing order in Fortran.
3467 else
3473 -- Generate the dimension loops starting from the innermost one
3475 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
3476 -- <core loop>
3477 -- end loop;
3479 Core_Loop :=
3481 Iteration_Scheme =>
3483 Loop_Parameter_Specification =>
3486 Discrete_Subtype_Definition =>
3496 -- Update the previously created object renaming declaration with
3497 -- the new iterator, by adding the index of the next loop to the
3498 -- indexed component, in the order that corresponds to the
3499 -- convention.
3504 else
3511 -- Inherit the loop identifier from the original loop. This ensures that
3512 -- the scope stack is consistent after the rewriting.
3522 -----------------------------------------
3523 -- Expand_Iterator_Loop_Over_Container --
3524 -----------------------------------------
3526 -- For a 'for ... in' loop, such as:
3528 -- for Cursor in Iterator_Function (...) loop
3529 -- ...
3530 -- end loop;
3532 -- we generate:
3534 -- Iter : Iterator_Type := Iterator_Function (...);
3535 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
3536 -- while Has_Element (Cursor) loop
3537 -- ...
3538 --
3539 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3540 -- end loop;
3542 -- For a 'for ... of' loop, such as:
3544 -- for X of Container loop
3545 -- ...
3546 -- end loop;
3548 -- the RM implies the generation of:
3550 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
3551 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
3552 -- while Has_Element (Cursor) loop
3553 -- declare
3554 -- X : Element_Type renames Element (Cursor).Element.all;
3555 -- -- or Constant_Element
3556 -- begin
3557 -- ...
3558 -- end;
3559 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3560 -- end loop;
3562 -- In the general case, we do what the RM says. However, the operations
3563 -- Element and Iter.Next are slow, which is bad inside a loop, because they
3564 -- involve dispatching via interfaces, secondary stack manipulation,
3565 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
3566 -- predefined containers, we use an equivalent but optimized expansion.
3568 -- In the optimized case, we make use of these:
3570 -- procedure Next (Position : in out Cursor); -- instead of Iter.Next
3572 -- function Pseudo_Reference
3573 -- (Container : aliased Vector'Class) return Reference_Control_Type;
3575 -- type Element_Access is access all Element_Type;
3577 -- function Get_Element_Access
3578 -- (Position : Cursor) return not null Element_Access;
3580 -- Next is declared in the visible part of the container packages.
3581 -- The other three are added in the private part. (We're not supposed to
3582 -- pollute the namespace for clients. The compiler has no trouble breaking
3583 -- privacy to call things in the private part of an instance.)
3585 -- Source:
3587 -- for X of My_Vector loop
3588 -- X.Count := X.Count + 1;
3589 -- ...
3590 -- end loop;
3592 -- The compiler will generate:
3594 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector);
3595 -- -- Reversible_Iterator is an interface. Iterate is the
3596 -- -- Default_Iterator aspect of Vector. This increments Lock,
3597 -- -- disallowing tampering with cursors. Unfortunately, it does not
3598 -- -- increment Busy. The result of Iterate is Limited_Controlled;
3599 -- -- finalization will decrement Lock. This is a build-in-place
3600 -- -- dispatching call to Iterate.
3602 -- Cur : Cursor := First (Iter); -- or Last
3603 -- -- Dispatching call via interface.
3605 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
3606 -- -- Pseudo_Reference increments Busy, to detect tampering with
3607 -- -- elements, as required by RM. Also redundantly increment
3608 -- -- Lock. Finalization of Control will decrement both Busy and
3609 -- -- Lock. Pseudo_Reference returns a record containing a pointer to
3610 -- -- My_Vector, used by Finalize.
3611 -- --
3612 -- -- Control is not used below, except to finalize it -- it's purely
3613 -- -- an RAII thing. This is needed because we are eliminating the
3614 -- -- call to Reference within the loop.
3616 -- while Has_Element (Cur) loop
3617 -- declare
3618 -- X : My_Element renames Get_Element_Access (Cur).all;
3619 -- -- Get_Element_Access returns a pointer to the element
3620 -- -- designated by Cur. No dispatching here, and no horsing
3621 -- -- around with access discriminants. This is instead of the
3622 -- -- existing
3623 -- --
3624 -- -- X : My_Element renames Reference (Cur).Element.all;
3625 -- --
3626 -- -- which creates a controlled object.
3627 -- begin
3628 -- -- Any attempt to tamper with My_Vector here in the loop
3629 -- -- will correctly raise Program_Error, because of the
3630 -- -- Control.
3631 --
3632 -- X.Count := X.Count + 1;
3633 -- ...
3634 --
3635 -- Next (Cur); -- or Prev
3636 -- -- This is instead of "Cur := Next (Iter, Cur);"
3637 -- end;
3638 -- -- No finalization here
3639 -- end loop;
3640 -- Finalize Iter and Control here, decrementing Lock twice and Busy
3641 -- once.
3643 -- This optimization makes "for ... of" loops over 30 times faster in cases
3644 -- measured.
3646 procedure Expand_Iterator_Loop_Over_Container
3652 is
3669 -- Only for optimized version of "for ... of"
3672 -- The package in which the iterator interface is instantiated. This is
3673 -- typically an instance within the container package.
3676 -- The package in which the container type is declared
3678 begin
3679 -- Determine the advancement and initialization steps for the cursor.
3680 -- Analysis of the expanded loop will verify that the container has a
3681 -- reverse iterator.
3686 else
3691 -- The type of the iterator is the return type of the Iterate function
3692 -- used. For the "of" form this is the default iterator for the type,
3693 -- otherwise it is the type of the explicit function used in the
3694 -- iterator specification. The most common case will be an Iterate
3695 -- function in the container package.
3697 -- The Iterator type is declared in an instance within the container
3698 -- package itself, for example:
3700 -- package Vector_Iterator_Interfaces is new
3701 -- Ada.Iterator_Interfaces (Cursor, Has_Element);
3703 -- If the container type is a derived type, the cursor type is found in
3704 -- the package of the ultimate ancestor type.
3708 else
3716 function Get_Default_Iterator
3718 -- If the container is a derived type, the aspect holds the parent
3719 -- operation. The required one is a primitive of the derived type
3720 -- and is either inherited or overridden. Also sets Container_Arg.
3722 --------------------------
3723 -- Get_Default_Iterator --
3724 --------------------------
3726 function Get_Default_Iterator
3728 is
3734 begin
3737 -- A previous version of GNAT allowed indexing aspects to
3738 -- be redefined on derived container types, while the
3739 -- default iterator was inherited from the parent type.
3740 -- This non-standard extension is preserved temporarily for
3741 -- use by the modelling project under debug flag d.X.
3746 then
3747 Container_Arg :=
3749 Subtype_Mark =>
3750 New_Occurrence_Of
3759 -- The default iterator must be a primitive operation of the
3760 -- type, at the same dispatch slot position.
3768 then
3775 -- Default iterator must exist
3779 -- Otherwise not a derived type
3781 else
3786 -- Local variables
3794 -- Start of processing for Handle_Of
3796 begin
3798 Default_Iter :=
3800 else
3806 -- For a container element iterator, the iterator type is obtained
3807 -- from the corresponding aspect, whose return type is descended
3808 -- from the corresponding interface type in some instance of
3809 -- Ada.Iterator_Interfaces. The actuals of that instantiation
3810 -- are Cursor and Has_Element.
3814 -- The iterator type, which is a class-wide type, may itself be
3815 -- derived locally, so the desired instantiation is the scope of
3816 -- the root type of the iterator type.
3820 -- Find declarations needed for "for ... of" optimization
3829 then
3844 then
3848 Object_Definition =>
3850 Expression =>
3852 Name =>
3854 Parameter_Associations =>
3858 -- Rewrite domain of iteration as a call to the default iterator
3859 -- for the container type. The formal may be an access parameter
3860 -- in which case we must build a reference to the container.
3862 declare
3864 begin
3866 Arg :=
3870 else
3876 Name =>
3883 -- Find cursor type in proper iterator package, which is an
3884 -- instantiation of Iterator_Interfaces.
3897 Decl :=
3900 Subtype_Mark =>
3902 Name =>
3904 Prefix =>
3906 Name =>
3908 Parameter_Associations =>
3911 else
3912 Decl :=
3915 Subtype_Mark =>
3917 Name =>
3920 Expressions =>
3924 -- The defining identifier in the iterator is user-visible and
3925 -- must be visible in the debugger.
3929 -- If the container does not have a variable indexing aspect,
3930 -- the element is a constant in the loop. The container itself
3931 -- may be constant, in which case the element is a constant as
3932 -- well. The container has been rewritten as a call to Iterate,
3933 -- so examine original node.
3938 then
3945 -- X in Iterate (S) : type of iterator is type of explicitly given
3946 -- Iterate function, and the loop variable is the cursor. It will be
3947 -- assigned in the loop and must be a variable.
3949 else
3952 -- The iterator type, which is a class-wide type, may itself be
3953 -- derived locally, so the desired instantiation is the scope of
3954 -- the root type of the iterator type, as in the "of" case.
3962 -- For both iterator forms, add a call to the step operation to advance
3963 -- the cursor. Generate:
3965 -- Cursor := Iterator.Next (Cursor);
3967 -- or else
3969 -- Cursor := Next (Cursor);
3972 declare
3976 begin
3977 Step_Call :=
3979 Name =>
3987 else
3988 declare
3991 begin
3992 Rhs :=
3994 Name =>
4009 -- Generate:
4010 -- while Has_Element (Cursor) loop
4011 -- <Stats>
4012 -- end loop;
4014 -- Has_Element is the second actual in the iterator package
4016 New_Loop :=
4018 Iteration_Scheme =>
4020 Condition =>
4022 Name =>
4023 New_Occurrence_Of
4031 -- If present, preserve identifier of loop, which can be used in an exit
4032 -- statement in the body.
4038 -- Create the declarations for Iterator and cursor and insert them
4039 -- before the source loop. Given that the domain of iteration is already
4040 -- an entity, the iterator is just a renaming of that entity. Possible
4041 -- optimization ???
4049 -- Create declaration for cursor
4051 declare
4055 Object_Definition =>
4057 Expression =>
4059 Prefix =>
4061 Selector_Name =>
4064 begin
4065 -- The cursor is only modified in expanded code, so it appears
4066 -- as unassigned to the warning machinery. We must suppress this
4067 -- spurious warning explicitly. The cursor's kind is that of the
4068 -- original loop parameter (it is a constant if the domain of
4069 -- iteration is constant).
4078 -- If the range of iteration is given by a function call that returns
4079 -- a container, the finalization actions have been saved in the
4080 -- Condition_Actions of the iterator. Insert them now at the head of
4081 -- the loop.
4091 -----------------------------
4092 -- Expand_N_Loop_Statement --
4093 -----------------------------
4095 -- 1. Remove null loop entirely
4096 -- 2. Deal with while condition for C/Fortran boolean
4097 -- 3. Deal with loops with a non-standard enumeration type range
4098 -- 4. Deal with while loops where Condition_Actions is set
4099 -- 5. Deal with loops over predicated subtypes
4100 -- 6. Deal with loops with iterators over arrays and containers
4101 -- 7. Insert polling call if required
4108 begin
4109 -- Delete null loop
4116 -- Deal with condition for C/Fortran Boolean
4122 -- Generate polling call
4128 -- Nothing more to do for plain loop with no iteration scheme
4133 -- Case of for loop (Loop_Parameter_Specification present)
4135 -- Note: we do not have to worry about validity checking of the for loop
4136 -- range bounds here, since they were frozen with constant declarations
4137 -- and it is during that process that the validity checking is done.
4140 declare
4150 begin
4151 -- Deal with loop over predicates
4155 then
4158 -- Handle the case where we have a for loop with the range type
4159 -- being an enumeration type with non-standard representation.
4160 -- In this case we expand:
4162 -- for x in [reverse] a .. b loop
4163 -- ...
4164 -- end loop;
4166 -- to
4168 -- for xP in [reverse] integer
4169 -- range etype'Pos (a) .. etype'Pos (b)
4170 -- loop
4171 -- declare
4172 -- x : constant etype := Pos_To_Rep (xP);
4173 -- begin
4174 -- ...
4175 -- end;
4176 -- end loop;
4180 then
4181 New_Id :=
4185 -- If the type has a contiguous representation, successive
4186 -- values can be generated as offsets from the first literal.
4189 Expr :=
4192 Left_Opnd =>
4196 else
4197 -- Use the constructed array Enum_Pos_To_Rep
4199 Expr :=
4201 Prefix =>
4203 Expressions =>
4207 -- Build declaration for loop identifier
4209 Decls :=
4210 New_List (
4221 Iteration_Scheme =>
4223 Loop_Parameter_Specification =>
4228 Discrete_Subtype_Definition =>
4231 Subtype_Mark =>
4234 Constraint =>
4236 Range_Expression =>
4239 Low_Bound =>
4241 Prefix =>
4247 Relocate_Node
4250 High_Bound =>
4252 Prefix =>
4258 Relocate_Node
4259 (Type_High_Bound
4265 Handled_Statement_Sequence =>
4271 -- The loop parameter's entity must be removed from the loop
4272 -- scope's entity list and rendered invisible, since it will
4273 -- now be located in the new block scope. Any other entities
4274 -- already associated with the loop scope, such as the loop
4275 -- parameter's subtype, will remain there.
4277 -- In an element loop, the loop will contain a declaration for
4278 -- a cursor variable; otherwise the loop id is the first entity
4279 -- in the scope constructed for the loop.
4295 -- Nothing to do with other cases of for loops
4297 else
4302 -- Second case, if we have a while loop with Condition_Actions set, then
4303 -- we change it into a plain loop:
4305 -- while C loop
4306 -- ...
4307 -- end loop;
4309 -- changed to:
4311 -- loop
4312 -- <<condition actions>>
4313 -- exit when not C;
4314 -- ...
4315 -- end loop
4320 then
4321 declare
4324 begin
4325 ES :=
4327 Condition =>
4334 -- This is not an implicit loop, since it is generated in response
4335 -- to the loop statement being processed. If this is itself
4336 -- implicit, the restriction has already been checked. If not,
4337 -- it is an explicit loop.
4348 -- Here to deal with iterator case
4352 then
4355 -- An iterator loop may generate renaming declarations for elements
4356 -- that require debug information. This is the case in particular
4357 -- with element iterators, where debug information must be generated
4358 -- for the temporary that holds the element value. These temporaries
4359 -- are created within a transient block whose local declarations are
4360 -- transferred to the loop, which now has nontrivial local objects.
4364 then
4369 -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
4370 -- is transformed into a conditional block where the original loop is
4371 -- the sole statement. Inspect the statements of the nested loop for
4372 -- controlled objects.
4383 ----------------------------
4384 -- Expand_Predicated_Loop --
4385 ----------------------------
4387 -- Note: the expander can handle generation of loops over predicated
4388 -- subtypes for both the dynamic and static cases. Depending on what
4389 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
4390 -- mode, the semantic analyzer may disallow one or both forms.
4401 begin
4402 -- Case of iteration over non-static predicate, should not be possible
4403 -- since this is not allowed by the semantics and should have been
4404 -- caught during analysis of the loop statement.
4409 -- If the predicate list is empty, that corresponds to a predicate of
4410 -- False, in which case the loop won't run at all, and we rewrite the
4411 -- entire loop as a null statement.
4417 -- For expansion over a static predicate we generate the following
4419 -- declare
4420 -- J : Ltype := min-val;
4421 -- begin
4422 -- loop
4423 -- body
4424 -- case J is
4425 -- when endpoint => J := startpoint;
4426 -- when endpoint => J := startpoint;
4427 -- ...
4428 -- when max-val => exit;
4429 -- when others => J := Lval'Succ (J);
4430 -- end case;
4431 -- end loop;
4432 -- end;
4434 -- with min-val replaced by max-val and Succ replaced by Pred if the
4435 -- loop parameter specification carries a Reverse indicator.
4437 -- To make this a little clearer, let's take a specific example:
4439 -- type Int is range 1 .. 10;
4440 -- subtype StaticP is Int with
4441 -- predicate => StaticP in 3 | 10 | 5 .. 7;
4442 -- ...
4443 -- for L in StaticP loop
4444 -- Put_Line ("static:" & J'Img);
4445 -- end loop;
4447 -- In this case, the loop is transformed into
4449 -- begin
4450 -- J : L := 3;
4451 -- loop
4452 -- body
4453 -- case J is
4454 -- when 3 => J := 5;
4455 -- when 7 => J := 10;
4456 -- when 10 => exit;
4457 -- when others => J := L'Succ (J);
4458 -- end case;
4459 -- end loop;
4460 -- end;
4462 else
4471 -- Given static expression or static range, returns an identifier
4472 -- whose value is the low bound of the expression value or range.
4475 -- Given static expression or static range, returns an identifier
4476 -- whose value is the high bound of the expression value or range.
4478 ------------
4479 -- Hi_Val --
4480 ------------
4483 begin
4486 else
4492 ------------
4493 -- Lo_Val --
4494 ------------
4497 begin
4500 else
4506 -- Start of processing for Static_Predicate
4508 begin
4509 -- Convert loop identifier to normal variable and reanalyze it so
4510 -- that this conversion works. We have to use the same defining
4511 -- identifier, since there may be references in the loop body.
4516 -- In most loops the loop variable is assigned in various
4517 -- alternatives in the body. However, in the rare case when
4518 -- the range specifies a single element, the loop variable
4519 -- may trigger a spurious warning that is could be constant.
4520 -- This warning might as well be suppressed.
4524 -- Loop to create branches of case statement
4530 -- Initial value is largest value in predicate.
4532 D :=
4542 else
4543 S :=
4558 else
4560 -- Initial value is smallest value in predicate.
4562 D :=
4572 else
4573 S :=
4589 -- Add others choice
4591 declare
4594 begin
4597 else
4601 S :=
4604 Expression =>
4618 -- Construct case statement and append to body statements
4620 Cstm :=
4626 -- Rewrite the loop
4633 Handled_Statement_Sequence =>
4645 ------------------------------
4646 -- Make_Tag_Ctrl_Assignment --
4647 ------------------------------
4660 and then not Comp_Asn
4665 begin
4666 -- Finalize the target of the assignment when controlled
4668 -- We have two exceptions here:
4670 -- 1. If we are in an init proc since it is an initialization more
4671 -- than an assignment.
4673 -- 2. If the left-hand side is a temporary that was not initialized
4674 -- (or the parent part of a temporary since it is the case in
4675 -- extension aggregates). Such a temporary does not come from
4676 -- source. We must examine the original node for the prefix, because
4677 -- it may be a component of an entry formal, in which case it has
4678 -- been rewritten and does not appear to come from source either.
4680 -- Case of init proc
4685 -- The left hand side is an uninitialized temporary object
4690 N_Object_Declaration
4692 then
4695 else
4697 Make_Final_Call
4702 -- Save the Tag in a local variable Tag_Id
4711 Expression =>
4714 Selector_Name =>
4717 -- Otherwise Tag_Id is not used
4719 else
4723 -- If the tagged type has a full rep clause, expand the assignment into
4724 -- component-wise assignments. Mark the node as unanalyzed in order to
4725 -- generate the proper code and propagate this scenario by setting a
4726 -- flag to avoid infinite recursion.
4735 -- Restore the tag
4740 Name =>
4743 Selector_Name =>
4748 -- Adjust the target after the assignment when controlled (not in the
4749 -- init proc since it is an initialization more than an assignment).
4753 Make_Adjust_Call
4760 exception
4762 -- Could use comment here ???