| blob | 5377b95086b782e71798a75cb18501deefbf31b9 |
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 may 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.
2581 then
2590 then
2593 -- Do not consider controlled objects found in a case statement which
2594 -- actually models a case expression because their early finalization
2595 -- will affect the result of the expression.
2601 -- Move statements from this alternative after the case statement.
2602 -- They are already analyzed, so will be skipped by the analyzer.
2606 -- That leaves the case statement as a shell. So now we can kill all
2607 -- other alternatives in the case statement.
2611 declare
2614 begin
2615 -- Loop through case alternatives, skipping pragmas, and skipping
2616 -- the one alternative that we select (and therefore retain).
2622 then
2634 -- Here if the choice is not determined at compile time
2636 declare
2645 begin
2649 else
2653 -- First step is to worry about possible invalid argument. The RM
2654 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
2655 -- outside the base range), then Constraint_Error must be raised.
2657 -- Case of validity check required (validity checks are on, the
2658 -- expression is not known to be valid, and the case statement
2659 -- comes from source -- no need to validity check internally
2660 -- generated case statements).
2666 -- If there is only a single alternative, just replace it with the
2667 -- sequence of statements since obviously that is what is going to
2668 -- be executed in all cases.
2674 -- We still need to evaluate the expression if it has any side
2675 -- effects.
2680 -- Do not consider controlled objects found in a case statement
2681 -- which actually models a case expression because their early
2682 -- finalization will affect the result of the expression.
2690 -- That leaves the case statement as a shell. The alternative that
2691 -- will be executed is reset to a null list. So now we can kill
2692 -- the entire case statement.
2698 -- An optimization. If there are only two alternatives, and only
2699 -- a single choice, then rewrite the whole case statement as an
2700 -- if statement, since this can result in subsequent optimizations.
2701 -- This helps not only with case statements in the source of a
2702 -- simple form, but also with generated code (discriminant check
2703 -- functions in particular).
2705 -- Note: it is OK to do this before expanding out choices for any
2706 -- static predicates, since the if statement processing will handle
2707 -- the static predicate case fine.
2718 -- For TRUE, generate "expression", not expression = true
2722 then
2725 -- For FALSE, generate "expression" and switch then/else
2729 then
2734 -- For a range, generate "expression in range"
2741 then
2742 Cond :=
2747 -- A subtype indication is not a legal operator in a membership
2748 -- test, so retrieve its range.
2751 Cond :=
2754 Right_Opnd =>
2755 Relocate_Node
2758 -- For any other subexpression "expression = value"
2760 else
2761 Cond :=
2767 -- Now rewrite the case as an IF
2779 -- If the last alternative is not an Others choice, replace it with
2780 -- an N_Others_Choice. Note that we do not bother to call Analyze on
2781 -- the modified case statement, since it's only effect would be to
2782 -- compute the contents of the Others_Discrete_Choices which is not
2783 -- needed by the back end anyway.
2785 -- The reason for this is that the back end always needs some default
2786 -- for a switch, so if we have not supplied one in the processing
2787 -- above for validity checking, then we need to supply one here.
2791 Set_Others_Discrete_Choices
2796 -- Deal with possible declarations of controlled objects, and also
2797 -- with rewriting choice sequences for static predicate references.
2802 -- Do not consider controlled objects found in a case statement
2803 -- which actually models a case expression because their early
2804 -- finalization will affect the result of the expression.
2819 -----------------------------
2820 -- Expand_N_Exit_Statement --
2821 -----------------------------
2823 -- The only processing required is to deal with a possible C/Fortran
2824 -- boolean value used as the condition for the exit statement.
2827 begin
2831 ----------------------------------
2832 -- Expand_Formal_Container_Loop --
2833 ----------------------------------
2848 begin
2849 -- The expansion resembles the one for Ada containers, but the
2850 -- primitives mention the domain of iteration explicitly, and
2851 -- function First applied to the container yields a cursor directly.
2853 -- Cursor : Cursor_type := First (Container);
2854 -- while Has_Element (Cursor, Container) loop
2855 -- <original loop statements>
2856 -- Cursor := Next (Container, Cursor);
2857 -- end loop;
2859 Build_Formal_Container_Iteration
2865 -- Build block to capture declaration of cursor entity.
2867 Blk_Nod :=
2870 Handled_Statement_Sequence =>
2878 ------------------------------------------
2879 -- Expand_Formal_Container_Element_Loop --
2880 ------------------------------------------
2904 begin
2905 -- For an element iterator, the Element aspect must be present,
2906 -- (this is checked during analysis) and the expansion takes the form:
2908 -- Cursor : Cursor_type := First (Container);
2909 -- Elmt : Element_Type;
2910 -- while Has_Element (Cursor, Container) loop
2911 -- Elmt := Element (Container, Cursor);
2912 -- <original loop statements>
2913 -- Cursor := Next (Container, Cursor);
2914 -- end loop;
2916 -- However this expansion is not legal if the element is indefinite.
2917 -- In that case we create a block to hold a variable declaration
2918 -- initialized with a call to Element, and generate:
2920 -- Cursor : Cursor_type := First (Container);
2921 -- while Has_Element (Cursor, Container) loop
2922 -- declare
2923 -- Elmt : Element-Type := Element (Container, Cursor);
2924 -- begin
2925 -- <original loop statements>
2926 -- Cursor := Next (Container, Cursor);
2927 -- end;
2928 -- end loop;
2930 Build_Formal_Container_Iteration
2937 -- Declaration for Element.
2939 Elmt_Decl :=
2953 New_List
2956 Handled_Statement_Sequence =>
2960 else
2961 Elmt_Ref :=
2964 Expression =>
2973 -- The element is assignable in the expanded code
2977 -- The loop is rewritten as a block, to hold the element declaration
2979 New_Loop :=
2982 Handled_Statement_Sequence =>
2987 -- The element is only modified in expanded code, so it appears as
2988 -- unassigned to the warning machinery. We must suppress this spurious
2989 -- warning explicitly.
2995 -- The loop parameter is declared by an object declaration, but within
2996 -- the loop we must prevent user assignments to it, so we analyze the
2997 -- declaration and reset the entity kind, before analyzing the rest of
2998 -- the loop;
3006 -----------------------------
3007 -- Expand_N_Goto_Statement --
3008 -----------------------------
3010 -- Add poll before goto if polling active
3013 begin
3017 ---------------------------
3018 -- Expand_N_If_Statement --
3019 ---------------------------
3021 -- First we deal with the case of C and Fortran convention boolean values,
3022 -- with zero/non-zero semantics.
3024 -- Second, we deal with the obvious rewriting for the cases where the
3025 -- condition of the IF is known at compile time to be True or False.
3027 -- Third, we remove elsif parts which have non-empty Condition_Actions and
3028 -- rewrite as independent if statements. For example:
3030 -- if x then xs
3031 -- elsif y then ys
3032 -- ...
3033 -- end if;
3035 -- becomes
3036 --
3037 -- if x then xs
3038 -- else
3039 -- <<condition actions of y>>
3040 -- if y then ys
3041 -- ...
3042 -- end if;
3043 -- end if;
3045 -- This rewriting is needed if at least one elsif part has a non-empty
3046 -- Condition_Actions list. We also do the same processing if there is a
3047 -- constant condition in an elsif part (in conjunction with the first
3048 -- processing step mentioned above, for the recursive call made to deal
3049 -- with the created inner if, this deals with properly optimizing the
3050 -- cases of constant elsif conditions).
3060 -- Indicates whether we want warnings when we delete branches of the
3061 -- if statement based on constant condition analysis. We never want
3062 -- these warnings for expander generated code.
3064 begin
3065 -- Do not consider controlled objects found in an if statement which
3066 -- actually models an if expression because their early finalization
3067 -- will affect the result of the expression.
3075 -- The following loop deals with constant conditions for the IF. We
3076 -- need a loop because as we eliminate False conditions, we grab the
3077 -- first elsif condition and use it as the primary condition.
3081 -- If condition is True, we can simply rewrite the if statement now
3082 -- by replacing it by the series of then statements.
3086 -- All the else parts can be killed
3096 -- If condition is False, then we can delete the condition and
3097 -- the Then statements
3099 else
3100 -- We do not delete the condition if constant condition warnings
3101 -- are enabled, since otherwise we end up deleting the desired
3102 -- warning. Of course the backend will get rid of this True/False
3103 -- test anyway, so nothing is lost here.
3111 -- If there are no elsif statements, then we simply replace the
3112 -- entire if statement by the sequence of else statements.
3117 then
3120 else
3128 -- If there are elsif statements, the first of them becomes the
3129 -- if/then section of the rebuilt if statement This is the case
3130 -- where we loop to reprocess this copied condition.
3132 else
3138 -- Hed might have been captured as the condition determining
3139 -- the current value for an entity. Now it is detached from
3140 -- the tree, so a Current_Value pointer in the condition might
3141 -- need to be updated.
3152 -- Loop through elsif parts, dealing with constant conditions and
3153 -- possible condition actions that are present.
3159 -- Do not consider controlled objects found in an if statement
3160 -- which actually models an if expression because their early
3161 -- finalization will affect the result of the expression.
3169 -- If there are condition actions, then rewrite the if statement
3170 -- as indicated above. We also do the same rewrite for a True or
3171 -- False condition. The further processing of this constant
3172 -- condition is then done by the recursive call to expand the
3173 -- newly created if statement
3177 then
3178 -- Note this is not an implicit if statement, since it is part
3179 -- of an explicit if statement in the source (or of an implicit
3180 -- if statement that has already been tested).
3182 New_If :=
3189 -- Elsif parts for new if come from remaining elsif's of parent
3214 -- No special processing for that elsif part, move to next
3216 else
3222 -- Some more optimizations applicable if we still have an IF statement
3228 -- Another optimization, special cases that can be simplified
3230 -- if expression then
3231 -- return true;
3232 -- else
3233 -- return false;
3234 -- end if;
3236 -- can be changed to:
3238 -- return expression;
3240 -- and
3242 -- if expression then
3243 -- return false;
3244 -- else
3245 -- return true;
3246 -- end if;
3248 -- can be changed to:
3250 -- return not (expression);
3252 -- Only do these optimizations if we are at least at -O1 level and
3253 -- do not do them if control flow optimizations are suppressed.
3257 then
3263 then
3264 declare
3268 begin
3270 and then
3272 then
3273 declare
3277 begin
3279 and then
3281 then
3284 then
3293 then
3296 Expression =>
3298 Right_Opnd =>
3311 --------------------------
3312 -- Expand_Iterator_Loop --
3313 --------------------------
3322 begin
3323 -- Processing for arrays
3332 else
3336 -- Processing for containers
3338 else
3339 Expand_Iterator_Loop_Over_Container
3344 -------------------------------------
3345 -- Expand_Iterator_Loop_Over_Array --
3346 -------------------------------------
3362 -- Start of processing for Expand_Iterator_Loop_Over_Array
3364 begin
3365 -- for Element of Array loop
3367 -- It requires an internally generated cursor to iterate over the array
3373 -- Generate:
3374 -- Element : Component_Type renames Array (Iterator);
3375 -- Iterator is the index value, or a list of index values
3376 -- in the case of a multidimensional array.
3378 Ind_Comp :=
3386 Subtype_Mark =>
3390 -- Mark the loop variable as needing debug info, so that expansion
3391 -- of the renaming will result in Materialize_Entity getting set via
3392 -- Debug_Renaming_Declaration. (This setting is needed here because
3393 -- the setting in Freeze_Entity comes after the expansion, which is
3394 -- too late. ???)
3398 -- Generate:
3400 -- for Iterator in [reverse] Array'Range (Array_Dim) loop
3401 -- Element : Component_Type renames Array (Iterator);
3402 -- <original loop statements>
3403 -- end loop;
3405 -- If this is an iteration over a multidimensional array, the
3406 -- innermost loop is over the last dimension in Ada, and over
3407 -- the first dimension in Fortran.
3411 else
3415 Core_Loop :=
3417 Iteration_Scheme =>
3419 Loop_Parameter_Specification =>
3422 Discrete_Subtype_Definition =>
3432 -- Processing for multidimensional array. The body of each loop is
3433 -- a loop over a previous dimension, going in decreasing order in Ada
3434 -- and in increasing order in Fortran.
3440 else
3446 -- Generate the dimension loops starting from the innermost one
3448 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
3449 -- <core loop>
3450 -- end loop;
3452 Core_Loop :=
3454 Iteration_Scheme =>
3456 Loop_Parameter_Specification =>
3459 Discrete_Subtype_Definition =>
3469 -- Update the previously created object renaming declaration with
3470 -- the new iterator, by adding the index of the next loop to the
3471 -- indexed component, in the order that corresponds to the
3472 -- convention.
3477 else
3484 -- Inherit the loop identifier from the original loop. This ensures that
3485 -- the scope stack is consistent after the rewriting.
3495 -----------------------------------------
3496 -- Expand_Iterator_Loop_Over_Container --
3497 -----------------------------------------
3499 -- For a 'for ... in' loop, such as:
3501 -- for Cursor in Iterator_Function (...) loop
3502 -- ...
3503 -- end loop;
3505 -- we generate:
3507 -- Iter : Iterator_Type := Iterator_Function (...);
3508 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
3509 -- while Has_Element (Cursor) loop
3510 -- ...
3511 --
3512 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3513 -- end loop;
3515 -- For a 'for ... of' loop, such as:
3517 -- for X of Container loop
3518 -- ...
3519 -- end loop;
3521 -- the RM implies the generation of:
3523 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
3524 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
3525 -- while Has_Element (Cursor) loop
3526 -- declare
3527 -- X : Element_Type renames Element (Cursor).Element.all;
3528 -- -- or Constant_Element
3529 -- begin
3530 -- ...
3531 -- end;
3532 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3533 -- end loop;
3535 -- In the general case, we do what the RM says. However, the operations
3536 -- Element and Iter.Next are slow, which is bad inside a loop, because they
3537 -- involve dispatching via interfaces, secondary stack manipulation,
3538 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
3539 -- predefined containers, we use an equivalent but optimized expansion.
3541 -- In the optimized case, we make use of these:
3543 -- procedure Next (Position : in out Cursor); -- instead of Iter.Next
3545 -- function Pseudo_Reference
3546 -- (Container : aliased Vector'Class) return Reference_Control_Type;
3548 -- type Element_Access is access all Element_Type;
3550 -- function Get_Element_Access
3551 -- (Position : Cursor) return not null Element_Access;
3553 -- Next is declared in the visible part of the container packages.
3554 -- The other three are added in the private part. (We're not supposed to
3555 -- pollute the namespace for clients. The compiler has no trouble breaking
3556 -- privacy to call things in the private part of an instance.)
3558 -- Source:
3560 -- for X of My_Vector loop
3561 -- X.Count := X.Count + 1;
3562 -- ...
3563 -- end loop;
3565 -- The compiler will generate:
3567 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector);
3568 -- -- Reversible_Iterator is an interface. Iterate is the
3569 -- -- Default_Iterator aspect of Vector. This increments Lock,
3570 -- -- disallowing tampering with cursors. Unfortunately, it does not
3571 -- -- increment Busy. The result of Iterate is Limited_Controlled;
3572 -- -- finalization will decrement Lock. This is a build-in-place
3573 -- -- dispatching call to Iterate.
3575 -- Cur : Cursor := First (Iter); -- or Last
3576 -- -- Dispatching call via interface.
3578 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
3579 -- -- Pseudo_Reference increments Busy, to detect tampering with
3580 -- -- elements, as required by RM. Also redundantly increment
3581 -- -- Lock. Finalization of Control will decrement both Busy and
3582 -- -- Lock. Pseudo_Reference returns a record containing a pointer to
3583 -- -- My_Vector, used by Finalize.
3584 -- --
3585 -- -- Control is not used below, except to finalize it -- it's purely
3586 -- -- an RAII thing. This is needed because we are eliminating the
3587 -- -- call to Reference within the loop.
3589 -- while Has_Element (Cur) loop
3590 -- declare
3591 -- X : My_Element renames Get_Element_Access (Cur).all;
3592 -- -- Get_Element_Access returns a pointer to the element
3593 -- -- designated by Cur. No dispatching here, and no horsing
3594 -- -- around with access discriminants. This is instead of the
3595 -- -- existing
3596 -- --
3597 -- -- X : My_Element renames Reference (Cur).Element.all;
3598 -- --
3599 -- -- which creates a controlled object.
3600 -- begin
3601 -- -- Any attempt to tamper with My_Vector here in the loop
3602 -- -- will correctly raise Program_Error, because of the
3603 -- -- Control.
3604 --
3605 -- X.Count := X.Count + 1;
3606 -- ...
3607 --
3608 -- Next (Cur); -- or Prev
3609 -- -- This is instead of "Cur := Next (Iter, Cur);"
3610 -- end;
3611 -- -- No finalization here
3612 -- end loop;
3613 -- Finalize Iter and Control here, decrementing Lock twice and Busy
3614 -- once.
3616 -- This optimization makes "for ... of" loops over 30 times faster in cases
3617 -- measured.
3619 procedure Expand_Iterator_Loop_Over_Container
3625 is
3642 -- Only for optimized version of "for ... of"
3645 -- The package in which the iterator interface is instantiated. This is
3646 -- typically an instance within the container package.
3649 -- The package in which the container type is declared
3651 begin
3652 -- Determine the advancement and initialization steps for the cursor.
3653 -- Analysis of the expanded loop will verify that the container has a
3654 -- reverse iterator.
3659 else
3664 -- The type of the iterator is the return type of the Iterate function
3665 -- used. For the "of" form this is the default iterator for the type,
3666 -- otherwise it is the type of the explicit function used in the
3667 -- iterator specification. The most common case will be an Iterate
3668 -- function in the container package.
3670 -- The Iterator type is declared in an instance within the container
3671 -- package itself, for example:
3673 -- package Vector_Iterator_Interfaces is new
3674 -- Ada.Iterator_Interfaces (Cursor, Has_Element);
3676 -- If the container type is a derived type, the cursor type is found in
3677 -- the package of the ultimate ancestor type.
3681 else
3689 function Get_Default_Iterator
3691 -- If the container is a derived type, the aspect holds the parent
3692 -- operation. The required one is a primitive of the derived type
3693 -- and is either inherited or overridden. Also sets Container_Arg.
3695 --------------------------
3696 -- Get_Default_Iterator --
3697 --------------------------
3699 function Get_Default_Iterator
3701 is
3707 begin
3710 -- A previous version of GNAT allowed indexing aspects to
3711 -- be redefined on derived container types, while the
3712 -- default iterator was inherited from the parent type.
3713 -- This non-standard extension is preserved temporarily for
3714 -- use by the modelling project under debug flag d.X.
3719 then
3720 Container_Arg :=
3722 Subtype_Mark =>
3723 New_Occurrence_Of
3732 -- The default iterator must be a primitive operation of the
3733 -- type, at the same dispatch slot position.
3741 then
3748 -- Default iterator must exist
3752 -- Otherwise not a derived type
3754 else
3759 -- Local variables
3767 -- Start of processing for Handle_Of
3769 begin
3771 Default_Iter :=
3773 else
3779 -- For a container element iterator, the iterator type is obtained
3780 -- from the corresponding aspect, whose return type is descended
3781 -- from the corresponding interface type in some instance of
3782 -- Ada.Iterator_Interfaces. The actuals of that instantiation
3783 -- are Cursor and Has_Element.
3787 -- The iterator type, which is a class-wide type, may itself be
3788 -- derived locally, so the desired instantiation is the scope of
3789 -- the root type of the iterator type.
3793 -- Find declarations needed for "for ... of" optimization
3802 then
3817 then
3821 Object_Definition =>
3823 Expression =>
3825 Name =>
3827 Parameter_Associations =>
3831 -- Rewrite domain of iteration as a call to the default iterator
3832 -- for the container type. The formal may be an access parameter
3833 -- in which case we must build a reference to the container.
3835 declare
3837 begin
3839 Arg :=
3843 else
3849 Name =>
3856 -- Find cursor type in proper iterator package, which is an
3857 -- instantiation of Iterator_Interfaces.
3870 Decl :=
3873 Subtype_Mark =>
3875 Name =>
3877 Prefix =>
3879 Name =>
3881 Parameter_Associations =>
3884 else
3885 Decl :=
3888 Subtype_Mark =>
3890 Name =>
3893 Expressions =>
3897 -- The defining identifier in the iterator is user-visible and
3898 -- must be visible in the debugger.
3902 -- If the container does not have a variable indexing aspect,
3903 -- the element is a constant in the loop. The container itself
3904 -- may be constant, in which case the element is a constant as
3905 -- well. The container has been rewritten as a call to Iterate,
3906 -- so examine original node.
3911 then
3918 -- X in Iterate (S) : type of iterator is type of explicitly given
3919 -- Iterate function, and the loop variable is the cursor. It will be
3920 -- assigned in the loop and must be a variable.
3922 else
3925 -- The iterator type, which is a class-wide type, may itself be
3926 -- derived locally, so the desired instantiation is the scope of
3927 -- the root type of the iterator type, as in the "of" case.
3935 -- For both iterator forms, add a call to the step operation to advance
3936 -- the cursor. Generate:
3938 -- Cursor := Iterator.Next (Cursor);
3940 -- or else
3942 -- Cursor := Next (Cursor);
3945 declare
3949 begin
3950 Step_Call :=
3952 Name =>
3960 else
3961 declare
3964 begin
3965 Rhs :=
3967 Name =>
3982 -- Generate:
3983 -- while Has_Element (Cursor) loop
3984 -- <Stats>
3985 -- end loop;
3987 -- Has_Element is the second actual in the iterator package
3989 New_Loop :=
3991 Iteration_Scheme =>
3993 Condition =>
3995 Name =>
3996 New_Occurrence_Of
4004 -- If present, preserve identifier of loop, which can be used in an exit
4005 -- statement in the body.
4011 -- Create the declarations for Iterator and cursor and insert them
4012 -- before the source loop. Given that the domain of iteration is already
4013 -- an entity, the iterator is just a renaming of that entity. Possible
4014 -- optimization ???
4022 -- Create declaration for cursor
4024 declare
4028 Object_Definition =>
4030 Expression =>
4032 Prefix =>
4034 Selector_Name =>
4037 begin
4038 -- The cursor is only modified in expanded code, so it appears
4039 -- as unassigned to the warning machinery. We must suppress this
4040 -- spurious warning explicitly. The cursor's kind is that of the
4041 -- original loop parameter (it is a constant if the domain of
4042 -- iteration is constant).
4051 -- If the range of iteration is given by a function call that returns
4052 -- a container, the finalization actions have been saved in the
4053 -- Condition_Actions of the iterator. Insert them now at the head of
4054 -- the loop.
4064 -----------------------------
4065 -- Expand_N_Loop_Statement --
4066 -----------------------------
4068 -- 1. Remove null loop entirely
4069 -- 2. Deal with while condition for C/Fortran boolean
4070 -- 3. Deal with loops with a non-standard enumeration type range
4071 -- 4. Deal with while loops where Condition_Actions is set
4072 -- 5. Deal with loops over predicated subtypes
4073 -- 6. Deal with loops with iterators over arrays and containers
4074 -- 7. Insert polling call if required
4081 begin
4082 -- Delete null loop
4089 -- Deal with condition for C/Fortran Boolean
4095 -- Generate polling call
4101 -- Nothing more to do for plain loop with no iteration scheme
4106 -- Case of for loop (Loop_Parameter_Specification present)
4108 -- Note: we do not have to worry about validity checking of the for loop
4109 -- range bounds here, since they were frozen with constant declarations
4110 -- and it is during that process that the validity checking is done.
4113 declare
4123 begin
4124 -- Deal with loop over predicates
4128 then
4131 -- Handle the case where we have a for loop with the range type
4132 -- being an enumeration type with non-standard representation.
4133 -- In this case we expand:
4135 -- for x in [reverse] a .. b loop
4136 -- ...
4137 -- end loop;
4139 -- to
4141 -- for xP in [reverse] integer
4142 -- range etype'Pos (a) .. etype'Pos (b)
4143 -- loop
4144 -- declare
4145 -- x : constant etype := Pos_To_Rep (xP);
4146 -- begin
4147 -- ...
4148 -- end;
4149 -- end loop;
4153 then
4154 New_Id :=
4158 -- If the type has a contiguous representation, successive
4159 -- values can be generated as offsets from the first literal.
4162 Expr :=
4165 Left_Opnd =>
4169 else
4170 -- Use the constructed array Enum_Pos_To_Rep
4172 Expr :=
4174 Prefix =>
4176 Expressions =>
4180 -- Build declaration for loop identifier
4182 Decls :=
4183 New_List (
4194 Iteration_Scheme =>
4196 Loop_Parameter_Specification =>
4201 Discrete_Subtype_Definition =>
4204 Subtype_Mark =>
4207 Constraint =>
4209 Range_Expression =>
4212 Low_Bound =>
4214 Prefix =>
4220 Relocate_Node
4223 High_Bound =>
4225 Prefix =>
4231 Relocate_Node
4232 (Type_High_Bound
4238 Handled_Statement_Sequence =>
4244 -- The loop parameter's entity must be removed from the loop
4245 -- scope's entity list and rendered invisible, since it will
4246 -- now be located in the new block scope. Any other entities
4247 -- already associated with the loop scope, such as the loop
4248 -- parameter's subtype, will remain there.
4250 -- In an element loop, the loop will contain a declaration for
4251 -- a cursor variable; otherwise the loop id is the first entity
4252 -- in the scope constructed for the loop.
4268 -- Nothing to do with other cases of for loops
4270 else
4275 -- Second case, if we have a while loop with Condition_Actions set, then
4276 -- we change it into a plain loop:
4278 -- while C loop
4279 -- ...
4280 -- end loop;
4282 -- changed to:
4284 -- loop
4285 -- <<condition actions>>
4286 -- exit when not C;
4287 -- ...
4288 -- end loop
4293 then
4294 declare
4297 begin
4298 ES :=
4300 Condition =>
4307 -- This is not an implicit loop, since it is generated in response
4308 -- to the loop statement being processed. If this is itself
4309 -- implicit, the restriction has already been checked. If not,
4310 -- it is an explicit loop.
4321 -- Here to deal with iterator case
4325 then
4328 -- An iterator loop may generate renaming declarations for elements
4329 -- that require debug information. This is the case in particular
4330 -- with element iterators, where debug information must be generated
4331 -- for the temporary that holds the element value. These temporaries
4332 -- are created within a transient block whose local declarations are
4333 -- transferred to the loop, which now has nontrivial local objects.
4337 then
4342 -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
4343 -- is transformed into a conditional block where the original loop is
4344 -- the sole statement. Inspect the statements of the nested loop for
4345 -- controlled objects.
4356 ----------------------------
4357 -- Expand_Predicated_Loop --
4358 ----------------------------
4360 -- Note: the expander can handle generation of loops over predicated
4361 -- subtypes for both the dynamic and static cases. Depending on what
4362 -- we decide is allowed in Ada 2012 mode and/or extensions allowed
4363 -- mode, the semantic analyzer may disallow one or both forms.
4374 begin
4375 -- Case of iteration over non-static predicate, should not be possible
4376 -- since this is not allowed by the semantics and should have been
4377 -- caught during analysis of the loop statement.
4382 -- If the predicate list is empty, that corresponds to a predicate of
4383 -- False, in which case the loop won't run at all, and we rewrite the
4384 -- entire loop as a null statement.
4390 -- For expansion over a static predicate we generate the following
4392 -- declare
4393 -- J : Ltype := min-val;
4394 -- begin
4395 -- loop
4396 -- body
4397 -- case J is
4398 -- when endpoint => J := startpoint;
4399 -- when endpoint => J := startpoint;
4400 -- ...
4401 -- when max-val => exit;
4402 -- when others => J := Lval'Succ (J);
4403 -- end case;
4404 -- end loop;
4405 -- end;
4407 -- with min-val replaced by max-val and Succ replaced by Pred if the
4408 -- loop parameter specification carries a Reverse indicator.
4410 -- To make this a little clearer, let's take a specific example:
4412 -- type Int is range 1 .. 10;
4413 -- subtype StaticP is Int with
4414 -- predicate => StaticP in 3 | 10 | 5 .. 7;
4415 -- ...
4416 -- for L in StaticP loop
4417 -- Put_Line ("static:" & J'Img);
4418 -- end loop;
4420 -- In this case, the loop is transformed into
4422 -- begin
4423 -- J : L := 3;
4424 -- loop
4425 -- body
4426 -- case J is
4427 -- when 3 => J := 5;
4428 -- when 7 => J := 10;
4429 -- when 10 => exit;
4430 -- when others => J := L'Succ (J);
4431 -- end case;
4432 -- end loop;
4433 -- end;
4435 else
4444 -- Given static expression or static range, returns an identifier
4445 -- whose value is the low bound of the expression value or range.
4448 -- Given static expression or static range, returns an identifier
4449 -- whose value is the high bound of the expression value or range.
4451 ------------
4452 -- Hi_Val --
4453 ------------
4456 begin
4459 else
4465 ------------
4466 -- Lo_Val --
4467 ------------
4470 begin
4473 else
4479 -- Start of processing for Static_Predicate
4481 begin
4482 -- Convert loop identifier to normal variable and reanalyze it so
4483 -- that this conversion works. We have to use the same defining
4484 -- identifier, since there may be references in the loop body.
4489 -- In most loops the loop variable is assigned in various
4490 -- alternatives in the body. However, in the rare case when
4491 -- the range specifies a single element, the loop variable
4492 -- may trigger a spurious warning that is could be constant.
4493 -- This warning might as well be suppressed.
4497 -- Loop to create branches of case statement
4503 -- Initial value is largest value in predicate.
4505 D :=
4515 else
4516 S :=
4531 else
4533 -- Initial value is smallest value in predicate.
4535 D :=
4545 else
4546 S :=
4562 -- Add others choice
4564 declare
4567 begin
4570 else
4574 S :=
4577 Expression =>
4591 -- Construct case statement and append to body statements
4593 Cstm :=
4599 -- Rewrite the loop
4606 Handled_Statement_Sequence =>
4618 ------------------------------
4619 -- Make_Tag_Ctrl_Assignment --
4620 ------------------------------
4633 and then not Comp_Asn
4638 begin
4639 -- Finalize the target of the assignment when controlled
4641 -- We have two exceptions here:
4643 -- 1. If we are in an init proc since it is an initialization more
4644 -- than an assignment.
4646 -- 2. If the left-hand side is a temporary that was not initialized
4647 -- (or the parent part of a temporary since it is the case in
4648 -- extension aggregates). Such a temporary does not come from
4649 -- source. We must examine the original node for the prefix, because
4650 -- it may be a component of an entry formal, in which case it has
4651 -- been rewritten and does not appear to come from source either.
4653 -- Case of init proc
4658 -- The left hand side is an uninitialized temporary object
4663 N_Object_Declaration
4665 then
4668 else
4670 Make_Final_Call
4675 -- Save the Tag in a local variable Tag_Id
4684 Expression =>
4687 Selector_Name =>
4690 -- Otherwise Tag_Id is not used
4692 else
4696 -- If the tagged type has a full rep clause, expand the assignment into
4697 -- component-wise assignments. Mark the node as unanalyzed in order to
4698 -- generate the proper code and propagate this scenario by setting a
4699 -- flag to avoid infinite recursion.
4708 -- Restore the tag
4713 Name =>
4716 Selector_Name =>
4721 -- Adjust the target after the assignment when controlled (not in the
4722 -- init proc since it is an initialization more than an assignment).
4726 Make_Adjust_Call
4733 exception
4735 -- Could use comment here ???