| blob | 8760cb7aae251579c8e96a4e2002f427206cd474 |
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-2010, 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 -- Determine if the right hand side of the assignment N is a type
69 -- conversion which requires a change of representation. Called
70 -- only for the array and record cases.
73 -- N is an assignment which assigns an array value. This routine process
74 -- the various special cases and checks required for such assignments,
75 -- including change of representation. Rhs is normally simply the right
76 -- hand side of the assignment, except that if the right hand side is
77 -- a type conversion or a qualified expression, then the Rhs is the
78 -- actual expression inside any such type conversions or qualifications.
80 function Expand_Assign_Array_Loop
88 -- N is an assignment statement which assigns an array value. This routine
89 -- expands the assignment into a loop (or nested loops for the case of a
90 -- multi-dimensional array) to do the assignment component by component.
91 -- Larray and Rarray are the entities of the actual arrays on the left
92 -- hand and right hand sides. L_Type and R_Type are the types of these
93 -- arrays (which may not be the same, due to either sliding, or to a
94 -- change of representation case). Ndim is the number of dimensions and
95 -- the parameter Rev indicates if the loops run normally (Rev = False),
96 -- or reversed (Rev = True). The value returned is the constructed
97 -- loop statement. Auxiliary declarations are inserted before node N
98 -- using the standard Insert_Actions mechanism.
101 -- N is an assignment of a non-tagged record value. This routine handles
102 -- the case where the assignment must be made component by component,
103 -- either because the target is not byte aligned, or there is a change
104 -- of representation, or when we have a tagged type with a representation
105 -- clause (this last case is required because holes in the tagged type
106 -- might be filled with components from child types).
109 -- Called by Expand_N_Simple_Return_Statement in case we're returning from
110 -- a procedure body, entry body, accept statement, or extended return
111 -- statement. Note that all non-function returns are simple return
112 -- statements.
115 -- Expand simple return from function. In the case where we are returning
116 -- from a function body this is called by Expand_N_Simple_Return_Statement.
119 -- Generate the necessary code for controlled and tagged assignment, that
120 -- is to say, finalization of the target before, adjustment of the target
121 -- after and save and restore of the tag and finalization pointers which
122 -- are not 'part of the value' and must not be changed upon assignment. N
123 -- is the original Assignment node.
125 ------------------------------
126 -- Change_Of_Representation --
127 ------------------------------
131 begin
132 return
134 and then
138 -------------------------
139 -- Expand_Assign_Array --
140 -------------------------
142 -- There are two issues here. First, do we let Gigi do a block move, or
143 -- do we expand out into a loop? Second, we need to set the two flags
144 -- Forwards_OK and Backwards_OK which show whether the block move (or
145 -- corresponding loops) can be legitimately done in a forwards (low to
146 -- high) or backwards (high to low) manner.
172 -- This switch is set to True if the array move must be done using
173 -- an explicit front end generated loop.
176 -- If the argument is an access to an array, and the assignment is
177 -- converted into a procedure call, apply explicit dereference.
180 -- Test if Exp is a reference to an array whose declaration has
181 -- an address clause, or it is a slice of such an array.
184 -- Test if Exp is a reference to an array which is either a formal
185 -- parameter or a slice of a formal parameter. These are the cases
186 -- where hidden aliasing can occur.
189 -- Determine if Exp is a reference to an array variable which is other
190 -- than an object defined in the current scope, or a slice of such
191 -- an object. Such objects can be aliased to parameters (unlike local
192 -- array references).
194 -----------------------
195 -- Apply_Dereference --
196 -----------------------
200 begin
208 ------------------------
209 -- Has_Address_Clause --
210 ------------------------
213 begin
214 return
217 or else
221 ---------------------
222 -- Is_Formal_Array --
223 ---------------------
226 begin
227 return
229 or else
233 ------------------------
234 -- Is_Non_Local_Array --
235 ------------------------
238 begin
245 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
253 -- Start of processing for Expand_Assign_Array
255 begin
256 -- Deal with length check. Note that the length check is done with
257 -- respect to the right hand side as given, not a possible underlying
258 -- renamed object, since this would generate incorrect extra checks.
262 -- We start by assuming that the move can be done in either direction,
263 -- i.e. that the two sides are completely disjoint.
268 -- Normally it is only the slice case that can lead to overlap, and
269 -- explicit checks for slices are made below. But there is one case
270 -- where the slice can be implicit and invisible to us: when we have a
271 -- one dimensional array, and either both operands are parameters, or
272 -- one is a parameter (which can be a slice passed by reference) and the
273 -- other is a non-local variable. In this case the parameter could be a
274 -- slice that overlaps with the other operand.
276 -- However, if the array subtype is a constrained first subtype in the
277 -- parameter case, then we don't have to worry about overlap, since
278 -- slice assignments aren't possible (other than for a slice denoting
279 -- the whole array).
281 -- Note: No overlap is possible if there is a change of representation,
282 -- so we can exclude this case.
285 and then not Crep
286 and then
288 or else
290 or else
292 and then
296 -- In the case of compiling for the Java or .NET Virtual Machine,
297 -- slices are always passed by making a copy, so we don't have to
298 -- worry about overlap. We also want to prevent generation of "<"
299 -- comparisons for array addresses, since that's a meaningless
300 -- operation on the VM.
303 then
307 -- Note: the bit-packed case is not worrisome here, since if we have
308 -- a slice passed as a parameter, it is always aligned on a byte
309 -- boundary, and if there are no explicit slices, the assignment
310 -- can be performed directly.
313 -- If either operand has an address clause clear Backwards_OK and
314 -- Forwards_OK, since we cannot tell if the operands overlap. We
315 -- exclude this treatment when Rhs is an aggregate, since we know
316 -- that overlap can't occur.
320 then
325 -- We certainly must use a loop for change of representation and also
326 -- we use the operand of the conversion on the right hand side as the
327 -- effective right hand side (the component types must match in this
328 -- situation).
335 -- We require a loop if the left side is possibly bit unaligned
338 or else
340 then
343 -- Arrays with controlled components are expanded into a loop to force
344 -- calls to Adjust at the component level.
349 -- If object is atomic, we cannot tolerate a loop
352 or else
354 then
357 -- Loop is required if we have atomic components since we have to
358 -- be sure to do any accesses on an element by element basis.
364 then
367 -- Case where no slice is involved
371 -- The following code deals with the case of unconstrained bit packed
372 -- arrays. The problem is that the template for such arrays contains
373 -- the bounds of the actual source level array, but the copy of an
374 -- entire array requires the bounds of the underlying array. It would
375 -- be nice if the back end could take care of this, but right now it
376 -- does not know how, so if we have such a type, then we expand out
377 -- into a loop, which is inefficient but works correctly. If we don't
378 -- do this, we get the wrong length computed for the array to be
379 -- moved. The two cases we need to worry about are:
381 -- Explicit dereference of an unconstrained packed array type as in
382 -- the following example:
384 -- procedure C52 is
385 -- type BITS is array(INTEGER range <>) of BOOLEAN;
386 -- pragma PACK(BITS);
387 -- type A is access BITS;
388 -- P1,P2 : A;
389 -- begin
390 -- P1 := new BITS (1 .. 65_535);
391 -- P2 := new BITS (1 .. 65_535);
392 -- P2.ALL := P1.ALL;
393 -- end C52;
395 -- A formal parameter reference with an unconstrained bit array type
396 -- is the other case we need to worry about (here we assume the same
397 -- BITS type declared above):
399 -- procedure Write_All (File : out BITS; Contents : BITS);
400 -- begin
401 -- File.Storage := Contents;
402 -- end Write_All;
404 -- We expand to a loop in either of these two cases
406 -- Question for future thought. Another potentially more efficient
407 -- approach would be to create the actual subtype, and then do an
408 -- unchecked conversion to this actual subtype ???
413 -- Function to perform required test for the first case, above
414 -- (dereference of an unconstrained bit packed array).
416 -----------------------
417 -- Is_UBPA_Reference --
418 -----------------------
425 begin
429 then
438 else
440 return
445 else
450 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
452 begin
454 or else
456 then
459 -- Here if we do not have the case of a reference to a bit packed
460 -- unconstrained array case. In this case gigi can most certainly
461 -- handle the assignment if a forwards move is allowed.
463 -- (could it handle the backwards case also???)
470 -- The back end can always handle the assignment if the right side is a
471 -- string literal (note that overlap is definitely impossible in this
472 -- case). If the type is packed, a string literal is always converted
473 -- into an aggregate, except in the case of a null slice, for which no
474 -- aggregate can be written. In that case, rewrite the assignment as a
475 -- null statement, a length check has already been emitted to verify
476 -- that the range of the left-hand side is empty.
478 -- Note that this code is not executed if we have an assignment of a
479 -- string literal to a non-bit aligned component of a record, a case
480 -- which cannot be handled by the backend.
485 then
492 -- If either operand is bit packed, then we need a loop, since we can't
493 -- be sure that the slice is byte aligned. Similarly, if either operand
494 -- is a possibly unaligned slice, then we need a loop (since the back
495 -- end cannot handle unaligned slices).
501 then
504 -- If we are not bit-packed, and we have only one slice, then no overlap
505 -- is possible except in the parameter case, so we can let the back end
506 -- handle things.
514 -- If the right-hand side is a string literal, introduce a temporary for
515 -- it, for use in the generated loop that will follow.
518 declare
522 begin
523 Decl :=
535 -- Come here to complete the analysis
537 -- Loop_Required: Set to True if we know that a loop is required
538 -- regardless of overlap considerations.
540 -- Forwards_OK: Set to False if we already know that a forwards
541 -- move is not safe, else set to True.
543 -- Backwards_OK: Set to False if we already know that a backwards
544 -- move is not safe, else set to True
546 -- Our task at this stage is to complete the overlap analysis, which can
547 -- result in possibly setting Forwards_OK or Backwards_OK to False, and
548 -- then generating the final code, either by deciding that it is OK
549 -- after all to let Gigi handle it, or by generating appropriate code
550 -- in the front end.
552 declare
570 begin
571 -- Get the expressions for the arrays. If we are dealing with a
572 -- private type, then convert to the underlying type. We can do
573 -- direct assignments to an array that is a private type, but we
574 -- cannot assign to elements of the array without this extra
575 -- unchecked conversion.
579 else
583 Larray :=
584 Unchecked_Convert_To
591 else
595 Rarray :=
596 Unchecked_Convert_To
601 -- If both sides are slices, we must figure out whether it is safe
602 -- to do the move in one direction or the other. It is always safe
603 -- if there is a change of representation since obviously two arrays
604 -- with different representations cannot possibly overlap.
610 -- If both left and right hand arrays are entity names, and refer
611 -- to different entities, then we know that the move is safe (the
612 -- two storage areas are completely disjoint).
617 then
620 -- Otherwise, we assume the worst, which is that the two arrays
621 -- are the same array. There is no need to check if we know that
622 -- is the case, because if we don't know it, we still have to
623 -- assume it!
625 -- Generally if the same array is involved, then we have an
626 -- overlapping case. We will have to really assume the worst (i.e.
627 -- set neither of the OK flags) unless we can determine the lower
628 -- or upper bounds at compile time and compare them.
630 else
631 Cresult :=
632 Compile_Time_Compare
636 Cresult :=
637 Compile_Time_Compare
650 -- If after that analysis Loop_Required is False, meaning that we
651 -- have not discovered some non-overlap reason for requiring a loop,
652 -- then the outcome depends on the capabilities of the back end.
656 -- The GCC back end can deal with all cases of overlap by falling
657 -- back to memmove if it cannot use a more efficient approach.
662 -- Assume other back ends can handle it if Forwards_OK is set
667 -- If Forwards_OK is not set, the back end will need something
668 -- like memmove to handle the move. For now, this processing is
669 -- activated using the .s debug flag (-gnatd.s).
676 -- At this stage we have to generate an explicit loop, and we have
677 -- the following cases:
679 -- Forwards_OK = True
681 -- Rnn : right_index := right_index'First;
682 -- for Lnn in left-index loop
683 -- left (Lnn) := right (Rnn);
684 -- Rnn := right_index'Succ (Rnn);
685 -- end loop;
687 -- Note: the above code MUST be analyzed with checks off, because
688 -- otherwise the Succ could overflow. But in any case this is more
689 -- efficient!
691 -- Forwards_OK = False, Backwards_OK = True
693 -- Rnn : right_index := right_index'Last;
694 -- for Lnn in reverse left-index loop
695 -- left (Lnn) := right (Rnn);
696 -- Rnn := right_index'Pred (Rnn);
697 -- end loop;
699 -- Note: the above code MUST be analyzed with checks off, because
700 -- otherwise the Pred could overflow. But in any case this is more
701 -- efficient!
703 -- Forwards_OK = Backwards_OK = False
705 -- This only happens if we have the same array on each side. It is
706 -- possible to create situations using overlays that violate this,
707 -- but we simply do not promise to get this "right" in this case.
709 -- There are two possible subcases. If the No_Implicit_Conditionals
710 -- restriction is set, then we generate the following code:
712 -- declare
713 -- T : constant <operand-type> := rhs;
714 -- begin
715 -- lhs := T;
716 -- end;
718 -- If implicit conditionals are permitted, then we generate:
720 -- if Left_Lo <= Right_Lo then
721 -- <code for Forwards_OK = True above>
722 -- else
723 -- <code for Backwards_OK = True above>
724 -- end if;
726 -- In order to detect possible aliasing, we examine the renamed
727 -- expression when the source or target is a renaming. However,
728 -- the renaming may be intended to capture an address that may be
729 -- affected by subsequent code, and therefore we must recover
730 -- the actual entity for the expansion that follows, not the
731 -- object it renames. In particular, if source or target designate
732 -- a portion of a dynamically allocated object, the pointer to it
733 -- may be reassigned but the renaming preserves the proper location.
736 and then
739 then
744 and then
747 then
751 -- Cases where either Forwards_OK or Backwards_OK is true
758 then
759 declare
764 begin
776 New_Occurrence_Of (
785 else
787 Expand_Assign_Array_Loop
792 -- Case of both are false with No_Implicit_Conditionals
795 declare
799 begin
806 Object_Definition =>
810 Handled_Statement_Sequence =>
818 -- Case of both are false with implicit conditionals allowed
820 else
821 -- Before we generate this code, we must ensure that the left and
822 -- right side array types are defined. They may be itypes, and we
823 -- cannot let them be defined inside the if, since the first use
824 -- in the then may not be executed.
829 -- We normally compare addresses to find out which way round to
830 -- do the loop, since this is reliable, and handles the cases of
831 -- parameters, conversions etc. But we can't do that in the bit
832 -- packed case or the VM case, because addresses don't work there.
835 Condition :=
837 Left_Opnd =>
840 Prefix =>
842 Prefix =>
846 Prefix =>
847 New_Reference_To
852 Right_Opnd =>
855 Prefix =>
857 Prefix =>
861 Prefix =>
862 New_Reference_To
867 -- For the bit packed and VM cases we use the bounds. That's OK,
868 -- because we don't have to worry about parameters, since they
869 -- cannot cause overlap. Perhaps we should worry about weird slice
870 -- conversions ???
872 else
873 -- Copy the bounds
878 -- If the types do not match we add an implicit conversion
879 -- here to ensure proper match
882 Cright_Lo :=
886 -- Reset the Analyzed flag, because the bounds of the index
887 -- type itself may be universal, and must must be reaanalyzed
888 -- to acquire the proper type for the back end.
893 Condition :=
903 then
905 -- Call TSS procedure for array assignment, passing the
906 -- explicit bounds of right and left hand sides.
908 declare
913 begin
934 else
940 Expand_Assign_Array_Loop
945 Expand_Assign_Array_Loop
954 exception
959 ------------------------------
960 -- Expand_Assign_Array_Loop --
961 ------------------------------
963 -- The following is an example of the loop generated for the case of a
964 -- two-dimensional array:
966 -- declare
967 -- R2b : Tm1X1 := 1;
968 -- begin
969 -- for L1b in 1 .. 100 loop
970 -- declare
971 -- R4b : Tm1X2 := 1;
972 -- begin
973 -- for L3b in 1 .. 100 loop
974 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
975 -- R4b := Tm1X2'succ(R4b);
976 -- end loop;
977 -- end;
978 -- R2b := Tm1X1'succ(R2b);
979 -- end loop;
980 -- end;
982 -- Here Rev is False, and Tm1Xn are the subscript types for the right hand
983 -- side. The declarations of R2b and R4b are inserted before the original
984 -- assignment statement.
986 function Expand_Assign_Array_Loop
994 is
999 -- Entities used as subscripts on left and right sides
1003 -- Left and right index types
1011 -- The increment step for the index of the right-hand side is written
1012 -- as an attribute reference (Succ or Pred). This function returns
1013 -- the corresponding node, which is placed at the end of the loop body.
1015 ----------------
1016 -- Build_Step --
1017 ----------------
1023 begin
1026 else
1030 Step :=
1033 Expression =>
1035 Prefix =>
1041 -- Note that on the last iteration of the loop, the index is increased
1042 -- (or decreased) past the corresponding bound. This is consistent with
1043 -- the C semantics of the back-end, where such an off-by-one value on a
1044 -- dead index variable is OK. However, in CodePeer mode this leads to
1045 -- spurious warnings, and thus we place a guard around the attribute
1046 -- reference. For obvious reasons we only do this for CodePeer.
1049 Step :=
1051 Condition =>
1054 Right_Opnd =>
1064 begin
1068 else
1073 -- Setup index types and subscript entities
1075 declare
1079 begin
1095 -- Now construct the assignment statement
1097 declare
1101 begin
1107 Assign :=
1109 Name =>
1113 Expression =>
1118 -- We set assignment OK, since there are some cases, e.g. in object
1119 -- declarations, where we are actually assigning into a constant.
1120 -- If there really is an illegality, it was caught long before now,
1121 -- and was flagged when the original assignment was analyzed.
1125 -- Propagate the No_Ctrl_Actions flag to individual assignments
1130 -- Now construct the loop from the inside out, with the last subscript
1131 -- varying most rapidly. Note that Assign is first the raw assignment
1132 -- statement, and then subsequently the loop that wraps it up.
1135 Assign :=
1140 Object_Definition =>
1142 Expression =>
1147 Handled_Statement_Sequence =>
1151 Iteration_Scheme =>
1153 Loop_Parameter_Specification =>
1157 Discrete_Subtype_Definition =>
1166 --------------------------
1167 -- Expand_Assign_Record --
1168 --------------------------
1175 begin
1176 -- If change of representation, then extract the real right hand side
1177 -- from the type conversion, and proceed with component-wise assignment,
1178 -- since the two types are not the same as far as the back end is
1179 -- concerned.
1184 -- If this may be a case of a large bit aligned component, then proceed
1185 -- with component-wise assignment, to avoid possible clobbering of other
1186 -- components sharing bits in the first or last byte of the component to
1187 -- be assigned.
1190 or
1192 then
1195 -- If we have a tagged type that has a complete record representation
1196 -- clause, we must do we must do component-wise assignments, since child
1197 -- types may have used gaps for their components, and we might be
1198 -- dealing with a view conversion.
1203 -- If neither condition met, then nothing special to do, the back end
1204 -- can handle assignment of the entire component as a single entity.
1206 else
1210 -- At this stage we know that we must do a component wise assignment
1212 declare
1219 function Find_Component
1222 -- Find the component with the given name in the underlying record
1223 -- declaration for Typ. We need to use the actual entity because the
1224 -- type may be private and resolution by identifier alone would fail.
1226 function Make_Component_List_Assign
1229 -- Returns a sequence of statements to assign the components that
1230 -- are referenced in the given component list. The flag U_U is
1231 -- used to force the usage of the inferred value of the variant
1232 -- part expression as the switch for the generated case statement.
1234 function Make_Field_Assign
1237 -- Given C, the entity for a discriminant or component, build an
1238 -- assignment for the corresponding field values. The flag U_U
1239 -- signals the presence of an Unchecked_Union and forces the usage
1240 -- of the inferred discriminant value of C as the right hand side
1241 -- of the assignment.
1244 -- Given CI, a component items list, construct series of statements
1245 -- for fieldwise assignment of the corresponding components.
1247 --------------------
1248 -- Find_Component --
1249 --------------------
1251 function Find_Component
1254 is
1258 begin
1271 --------------------------------
1272 -- Make_Component_List_Assign --
1273 --------------------------------
1275 function Make_Component_List_Assign
1278 is
1289 begin
1306 Statements =>
1311 -- If we have an Unchecked_Union, use the value of the inferred
1312 -- discriminant of the variant part expression as the switch
1313 -- for the case statement. The case statement may later be
1314 -- folded.
1317 Expr :=
1322 else
1323 Expr :=
1326 Selector_Name =>
1339 -----------------------
1340 -- Make_Field_Assign --
1341 -----------------------
1343 function Make_Field_Assign
1346 is
1350 begin
1351 -- In the case of an Unchecked_Union, use the discriminant
1352 -- constraint value as on the right hand side of the assignment.
1355 Expr :=
1359 else
1360 Expr :=
1366 A :=
1368 Name =>
1371 Selector_Name =>
1375 -- Set Assignment_OK, so discriminants can be assigned
1382 then
1389 ------------------------
1390 -- Make_Field_Assigns --
1391 ------------------------
1397 begin
1402 -- Look for components, but exclude _tag field assignment if
1403 -- the special Componentwise_Assignment flag is set.
1408 then
1409 Append_To
1419 -- Start of processing for Expand_Assign_Record
1421 begin
1422 -- Note that we use the base types for this processing. This results
1423 -- in some extra work in the constrained case, but the change of
1424 -- representation case is so unusual that it is not worth the effort.
1426 -- First copy the discriminants. This is done unconditionally. It
1427 -- is required in the unconstrained left side case, and also in the
1428 -- case where this assignment was constructed during the expansion
1429 -- of a type conversion (since initialization of discriminants is
1430 -- suppressed in this case). It is unnecessary but harmless in
1431 -- other cases.
1437 -- If we are expanding the initialization of a derived record
1438 -- that constrains or renames discriminants of the parent, we
1439 -- must use the corresponding discriminant in the parent.
1441 declare
1444 begin
1445 if Inside_Init_Proc
1447 then
1449 else
1455 else
1464 -- We know the underlying type is a record, but its current view
1465 -- may be private. We must retrieve the usable record declaration.
1468 N_Private_Extension_Declaration)
1470 then
1472 else
1482 then
1486 else
1487 Insert_Actions
1496 -----------------------------------
1497 -- Expand_N_Assignment_Statement --
1498 -----------------------------------
1500 -- This procedure implements various cases where an assignment statement
1501 -- cannot just be passed on to the back end in untransformed state.
1510 begin
1511 -- Special case to check right away, if the Componentwise_Assignment
1512 -- flag is set, this is a reanalysis from the expansion of the primitive
1513 -- assignment procedure for a tagged type, and all we need to do is to
1514 -- expand to assignment of components, because otherwise, we would get
1515 -- infinite recursion (since this looks like a tagged assignment which
1516 -- would normally try to *call* the primitive assignment procedure).
1523 -- Defend against invalid subscripts on left side if we are in standard
1524 -- validity checking mode. No need to do this if we are checking all
1525 -- subscripts.
1527 -- Note that we do this right away, because there are some early return
1528 -- paths in this procedure, and this is required on all paths.
1530 if Validity_Checks_On
1531 and then Validity_Check_Default
1532 and then not Validity_Check_Subscripts
1533 then
1537 -- Ada 2005 (AI-327): Handle assignment to priority of protected object
1539 -- Rewrite an assignment to X'Priority into a run-time call
1541 -- For example: X'Priority := New_Prio_Expr;
1542 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
1544 -- Note that although X'Priority is notionally an object, it is quite
1545 -- deliberately not defined as an aliased object in the RM. This means
1546 -- that it works fine to rewrite it as a call, without having to worry
1547 -- about complications that would other arise from X'Priority'Access,
1548 -- which is illegal, because of the lack of aliasing.
1551 declare
1558 begin
1559 -- Handle chains of renamings
1565 loop
1569 -- The attribute Priority applied to protected objects has been
1570 -- previously expanded into a call to the Get_Ceiling run-time
1571 -- subprogram.
1575 or else
1577 then
1578 -- Look for the enclosing concurrent type
1587 -- Generate the first actual of the call
1594 -- Select the appropriate run-time call
1597 RT_Subprg_Name :=
1599 else
1600 RT_Subprg_Name :=
1604 Call :=
1618 -- First deal with generation of range check if required
1625 -- Check for a special case where a high level transformation is
1626 -- required. If we have either of:
1628 -- P.field := rhs;
1629 -- P (sub) := rhs;
1631 -- where P is a reference to a bit packed array, then we have to unwind
1632 -- the assignment. The exact meaning of being a reference to a bit
1633 -- packed array is as follows:
1635 -- An indexed component whose prefix is a bit packed array is a
1636 -- reference to a bit packed array.
1638 -- An indexed component or selected component whose prefix is a
1639 -- reference to a bit packed array is itself a reference ot a
1640 -- bit packed array.
1642 -- The required transformation is
1644 -- Tnn : prefix_type := P;
1645 -- Tnn.field := rhs;
1646 -- P := Tnn;
1648 -- or
1650 -- Tnn : prefix_type := P;
1651 -- Tnn (subscr) := rhs;
1652 -- P := Tnn;
1654 -- Since P is going to be evaluated more than once, any subscripts
1655 -- in P must have their evaluation forced.
1659 then
1660 declare
1666 begin
1667 -- Insert the post assignment first, because we want to copy the
1668 -- BPAR_Expr tree before it gets analyzed in the context of the
1669 -- pre assignment. Note that we do not analyze the post assignment
1670 -- yet (we cannot till we have completed the analysis of the pre
1671 -- assignment). As usual, the analysis of this post assignment
1672 -- will happen on its own when we "run into" it after finishing
1673 -- the current assignment.
1680 -- At this stage BPAR_Expr is a reference to a bit packed array
1681 -- where the reference was not expanded in the original tree,
1682 -- since it was on the left side of an assignment. But in the
1683 -- pre-assignment statement (the object definition), BPAR_Expr
1684 -- will end up on the right hand side, and must be reexpanded. To
1685 -- achieve this, we reset the analyzed flag of all selected and
1686 -- indexed components down to the actual indexed component for
1687 -- the packed array.
1690 loop
1693 if Nkind_In
1695 then
1697 else
1702 -- Now we can insert and analyze the pre-assignment
1704 -- If the right-hand side requires a transient scope, it has
1705 -- already been placed on the stack. However, the declaration is
1706 -- inserted in the tree outside of this scope, and must reflect
1707 -- the proper scope for its variable. This awkward bit is forced
1708 -- by the stricter scope discipline imposed by GCC 2.97.
1710 declare
1712 Scope_Is_Transient
1715 begin
1727 Pop_Scope;
1731 -- Now fix up the original assignment and continue processing
1736 -- We do not need to reanalyze that assignment, and we do not need
1737 -- to worry about references to the temporary, but we do need to
1738 -- make sure that the temporary is not marked as a true constant
1739 -- since we now have a generated assignment to it!
1745 -- When we have the appropriate type of aggregate in the expression (it
1746 -- has been determined during analysis of the aggregate by setting the
1747 -- delay flag), let's perform in place assignment and thus avoid
1748 -- creating a temporary.
1757 -- Apply discriminant check if required. If Lhs is an access type to a
1758 -- designated type with discriminants, we must always check.
1762 -- Skip discriminant check if change of representation. Will be
1763 -- done when the change of representation is expanded out.
1769 -- If the type is private without discriminants, and the full type
1770 -- has discriminants (necessarily with defaults) a check may still be
1771 -- necessary if the Lhs is aliased. The private determinants must be
1772 -- visible to build the discriminant constraints.
1774 -- Only an explicit dereference that comes from source indicates
1775 -- aliasing. Access to formals of protected operations and entries
1776 -- create dereferences but are not semantic aliasings.
1782 then
1783 declare
1785 begin
1792 -- If the Lhs has a private type with unknown discriminants, it
1793 -- may have a full view with discriminants, but those are nameable
1794 -- only in the underlying type, so convert the Rhs to it before
1795 -- potential checking.
1799 then
1803 -- In the access type case, we need the same discriminant check, and
1804 -- also range checks if we have an access to constrained array.
1808 then
1811 -- Skip discriminant check if change of representation. Will be
1812 -- done when the change of representation is expanded out.
1826 declare
1830 begin
1831 C_Es :=
1832 Get_Range_Checks
1834 Target_Typ,
1837 Insert_Range_Checks
1839 N,
1840 Target_Typ,
1842 Lhs);
1847 -- Apply range check for access type case
1852 then
1854 Apply_Range_Check
1858 -- Ada 2005 (AI-231): Generate the run-time check
1863 then
1867 -- Case of assignment to a bit packed array element
1871 then
1875 -- Build-in-place function call case. Note that we're not yet doing
1876 -- build-in-place for user-written assignment statements (the assignment
1877 -- here came from an aggregate.)
1881 then
1886 -- Nothing to do for valuetypes
1887 -- ??? Set_Scope_Is_Transient (False);
1893 then
1898 begin
1899 -- In the controlled case, we ensure that function calls are
1900 -- evaluated before finalizing the target. In all cases, it makes
1901 -- the expansion easier if the side-effects are removed first.
1906 -- Avoid recursion in the mechanism
1910 -- If dispatching assignment, we need to dispatch to _assign
1914 -- If the type is tagged, we may as well use the predefined
1915 -- primitive assignment. This avoids inlining a lot of code
1916 -- and in the class-wide case, the assignment is replaced by
1917 -- dispatch call to _assign. Note that this cannot be done when
1918 -- discriminant checks are locally suppressed (as in extension
1919 -- aggregate expansions) because otherwise the discriminant
1920 -- check will be performed within the _assign call. It is also
1921 -- suppressed for assignments created by the expander that
1922 -- correspond to initializations, where we do want to copy the
1923 -- tag (No_Ctrl_Actions flag set True) by the expander and we
1924 -- do not need to mess with tags ever (Expand_Ctrl_Actions flag
1925 -- is set True in this case).
1930 and then Expand_Ctrl_Actions
1932 then
1933 -- Fetch the primitive op _assign and proper type to call it.
1934 -- Because of possible conflicts between private and full view,
1935 -- fetch the proper type directly from the operation profile.
1937 declare
1942 begin
1943 -- If the assignment is dispatching, make sure to use the
1944 -- proper type.
1952 -- In case of assignment to a class-wide tagged type, before
1953 -- the assignment we generate run-time check to ensure that
1954 -- the tags of source and target match.
1959 then
1962 Condition =>
1964 Left_Opnd =>
1967 Selector_Name =>
1970 Right_Opnd =>
1973 Selector_Name =>
1989 else
1992 -- We can't afford to have destructive Finalization Actions in
1993 -- the Self assignment case, so if the target and the source
1994 -- are not obviously different, code is generated to avoid the
1995 -- self assignment case:
1997 -- if lhs'address /= rhs'address then
1998 -- <code for controlled and/or tagged assignment>
1999 -- end if;
2001 -- Skip this if Restriction (No_Finalization) is active
2004 and then Expand_Ctrl_Actions
2006 then
2009 Condition =>
2011 Left_Opnd =>
2016 Right_Opnd =>
2024 -- We need to set up an exception handler for implementing
2025 -- 7.6.1(18). The remaining adjustments are tackled by the
2026 -- implementation of adjust for record_controllers (see
2027 -- s-finimp.adb).
2029 -- This is skipped if we have no finalization
2031 if Expand_Ctrl_Actions
2033 then
2036 Handled_Statement_Sequence =>
2046 Handled_Statement_Sequence =>
2049 -- If no restrictions on aborts, protect the whole assignment
2050 -- for controlled objects as per 9.8(11).
2053 and then Expand_Ctrl_Actions
2054 and then Abort_Allowed
2055 then
2056 declare
2058 New_Internal_Entity
2061 begin
2069 Expand_At_End_Handler
2074 -- N has been rewritten to a block statement for which it is
2075 -- known by construction that no checks are necessary: analyze
2076 -- it with all checks suppressed.
2082 -- Array types
2085 declare
2088 begin
2090 N_Qualified_Expression)
2091 loop
2099 -- Record types
2105 -- Scalar types. This is where we perform the processing related to the
2106 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
2107 -- scalar values.
2111 -- Case where right side is known valid
2115 -- Here the right side is valid, so it is fine. The case to deal
2116 -- with is when the left side is a local variable reference whose
2117 -- value is not currently known to be valid. If this is the case,
2118 -- and the assignment appears in an unconditional context, then
2119 -- we can mark the left side as now being valid if one of these
2120 -- conditions holds:
2122 -- The expression of the right side has Do_Range_Check set so
2123 -- that we know a range check will be performed. Note that it
2124 -- can be the case that a range check is omitted because we
2125 -- make the assumption that we can assume validity for operands
2126 -- appearing in the right side in determining whether a range
2127 -- check is required
2129 -- The subtype of the right side matches the subtype of the
2130 -- left side. In this case, even though we have not checked
2131 -- the range of the right side, we know it is in range of its
2132 -- subtype if the expression is valid.
2137 then
2140 then
2145 -- Case where right side may be invalid in the sense of the RM
2146 -- reference above. The RM does not require that we check for the
2147 -- validity on an assignment, but it does require that the assignment
2148 -- of an invalid value not cause erroneous behavior.
2150 -- The general approach in GNAT is to use the Is_Known_Valid flag
2151 -- to avoid the need for validity checking on assignments. However
2152 -- in some cases, we have to do validity checking in order to make
2153 -- sure that the setting of this flag is correct.
2155 else
2156 -- Validate right side if we are validating copies
2158 if Validity_Checks_On
2159 and then Validity_Check_Copies
2160 then
2161 -- Skip this if left hand side is an array or record component
2162 -- and elementary component validity checks are suppressed.
2165 and then not Validity_Check_Components
2166 then
2168 else
2172 -- We can propagate this to the left side where appropriate
2177 then
2181 -- Otherwise check to see what should be done
2183 -- If left side is a local variable, then we just set its flag to
2184 -- indicate that its value may no longer be valid, since we are
2185 -- copying a potentially invalid value.
2190 -- Check for case of a nonlocal variable on the left side which
2191 -- is currently known to be valid. In this case, we simply ensure
2192 -- that the right side is valid. We only play the game of copying
2193 -- validity status for local variables, since we are doing this
2194 -- statically, not by tracing the full flow graph.
2198 then
2199 -- Note: If Validity_Checking mode is set to none, we ignore
2200 -- the Ensure_Valid call so don't worry about that case here.
2204 -- In all other cases, we can safely copy an invalid value without
2205 -- worrying about the status of the left side. Since it is not a
2206 -- variable reference it will not be considered
2207 -- as being known to be valid in any case.
2209 else
2215 exception
2220 ------------------------------
2221 -- Expand_N_Block_Statement --
2222 ------------------------------
2224 -- Encode entity names defined in block statement
2227 begin
2231 -----------------------------
2232 -- Expand_N_Case_Statement --
2233 -----------------------------
2244 begin
2245 -- Check for the situation where we know at compile time which branch
2246 -- will be taken
2251 -- Move statements from this alternative after the case statement.
2252 -- They are already analyzed, so will be skipped by the analyzer.
2256 -- That leaves the case statement as a shell. So now we can kill all
2257 -- other alternatives in the case statement.
2261 declare
2264 begin
2265 -- Loop through case alternatives, skipping pragmas, and skipping
2266 -- the one alternative that we select (and therefore retain).
2272 then
2284 -- Here if the choice is not determined at compile time
2286 declare
2295 begin
2299 else
2303 -- First step is to worry about possible invalid argument. The RM
2304 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
2305 -- outside the base range), then Constraint_Error must be raised.
2307 -- Case of validity check required (validity checks are on, the
2308 -- expression is not known to be valid, and the case statement
2309 -- comes from source -- no need to validity check internally
2310 -- generated case statements).
2316 -- If there is only a single alternative, just replace it with the
2317 -- sequence of statements since obviously that is what is going to
2318 -- be executed in all cases.
2323 -- We still need to evaluate the expression if it has any
2324 -- side effects.
2330 -- That leaves the case statement as a shell. The alternative that
2331 -- will be executed is reset to a null list. So now we can kill
2332 -- the entire case statement.
2339 -- An optimization. If there are only two alternatives, and only
2340 -- a single choice, then rewrite the whole case statement as an
2341 -- if statement, since this can result in subsequent optimizations.
2342 -- This helps not only with case statements in the source of a
2343 -- simple form, but also with generated code (discriminant check
2344 -- functions in particular)
2355 -- For TRUE, generate "expression", not expression = true
2359 then
2362 -- For FALSE, generate "expression" and switch then/else
2366 then
2371 -- For a range, generate "expression in range"
2379 then
2380 Cond :=
2385 -- For any other subexpression "expression = value"
2387 else
2388 Cond :=
2394 -- Now rewrite the case as an IF
2406 -- If the last alternative is not an Others choice, replace it with
2407 -- an N_Others_Choice. Note that we do not bother to call Analyze on
2408 -- the modified case statement, since it's only effect would be to
2409 -- compute the contents of the Others_Discrete_Choices which is not
2410 -- needed by the back end anyway.
2412 -- The reason we do this is that the back end always needs some
2413 -- default for a switch, so if we have not supplied one in the
2414 -- processing above for validity checking, then we need to supply
2415 -- one here.
2419 Set_Others_Discrete_Choices
2426 -----------------------------
2427 -- Expand_N_Exit_Statement --
2428 -----------------------------
2430 -- The only processing required is to deal with a possible C/Fortran
2431 -- boolean value used as the condition for the exit statement.
2434 begin
2438 ----------------------------------------
2439 -- Expand_N_Extended_Return_Statement --
2440 ----------------------------------------
2442 -- If there is a Handled_Statement_Sequence, we rewrite this:
2444 -- return Result : T := <expression> do
2445 -- <handled_seq_of_stms>
2446 -- end return;
2448 -- to be:
2450 -- declare
2451 -- Result : T := <expression>;
2452 -- begin
2453 -- <handled_seq_of_stms>
2454 -- return Result;
2455 -- end;
2457 -- Otherwise (no Handled_Statement_Sequence), we rewrite this:
2459 -- return Result : T := <expression>;
2461 -- to be:
2463 -- return <expression>;
2465 -- unless it's build-in-place or there's no <expression>, in which case
2466 -- we generate:
2468 -- declare
2469 -- Result : T := <expression>;
2470 -- begin
2471 -- return Result;
2472 -- end;
2474 -- Note that this case could have been written by the user as an extended
2475 -- return statement, or could have been transformed to this from a simple
2476 -- return statement.
2478 -- That is, we need to have a reified return object if there are statements
2479 -- (which might refer to it) or if we're doing build-in-place (so we can
2480 -- set its address to the final resting place or if there is no expression
2481 -- (in which case default initial values might need to be set).
2503 -- Determine whether type Typ is controlled or contains a controlled
2504 -- subcomponent.
2507 -- Construct a call to System.Tasking.Stages.Move_Activation_Chain
2508 -- with parameters:
2509 -- From current activation chain
2510 -- To activation chain passed in by the caller
2511 -- New_Master master passed in by the caller
2514 -- Construct call to System.Finalization_Implementation.Move_Final_List
2515 -- with parameters:
2516 --
2517 -- From finalization list of the return statement
2518 -- To finalization list passed in by the caller
2520 --------------------------
2521 -- Has_Controlled_Parts --
2522 --------------------------
2525 begin
2526 return
2531 ---------------------------
2532 -- Move_Activation_Chain --
2533 ---------------------------
2537 Build_In_Place_Formal
2540 New_Reference_To
2543 Build_In_Place_Formal
2551 begin
2557 From :=
2561 -- ??? Not clear why "Make_Identifier (Loc, Name_uChain)" doesn't
2562 -- work, instead of "New_Reference_To (Chain_Entity, Loc)" above.
2564 return
2570 ---------------------
2571 -- Move_Final_List --
2572 ---------------------
2581 Build_In_Place_Formal
2586 begin
2587 -- Catch cases where a finalization chain entity has not been
2588 -- associated with the return statement entity.
2592 -- Build required call
2594 return
2596 Condition =>
2600 Then_Statements =>
2601 New_List (
2607 -- Start of processing for Expand_N_Extended_Return_Statement
2609 begin
2612 else
2618 -- Build a simple_return_statement that returns the return object when
2619 -- there is a statement sequence, or no expression, or the result will
2620 -- be built in place. Note however that we currently do this for all
2621 -- composite cases, even though nonlimited composite results are not yet
2622 -- built in place (though we plan to do so eventually).
2627 then
2631 -- If the extended return has a handled statement sequence, then wrap
2632 -- it in a block and use the block as the first statement.
2634 else
2635 Statements :=
2641 -- If control gets past the above Statements, we have successfully
2642 -- completed the return statement. If the result type has controlled
2643 -- parts and the return is for a build-in-place function, then we
2644 -- call Move_Final_List to transfer responsibility for finalization
2645 -- of the return object to the caller. An alternative would be to
2646 -- declare a Success flag in the function, initialize it to False,
2647 -- and set it to True here. Then move the Move_Final_List call into
2648 -- the cleanup code, and check Success. If Success then make a call
2649 -- to Move_Final_List else do finalization. Then we can remove the
2650 -- abort-deferral and the nulling-out of the From parameter from
2651 -- Move_Final_List. Note that the current method is not quite correct
2652 -- in the rather obscure case of a select-then-abort statement whose
2653 -- abortable part contains the return statement.
2655 -- Check the type of the function to determine whether to move the
2656 -- finalization list. A special case arises when processing a simple
2657 -- return statement which has been rewritten as an extended return.
2658 -- In that case check the type of the returned object or the original
2659 -- expression.
2661 if Is_Build_In_Place
2662 and then
2665 and then
2670 then
2674 -- Similarly to the above Move_Final_List, if the result type
2675 -- contains tasks, we call Move_Activation_Chain. Later, the cleanup
2676 -- code will call Complete_Master, which will terminate any
2677 -- unactivated tasks belonging to the return statement master. But
2678 -- Move_Activation_Chain updates their master to be that of the
2679 -- caller, so they will not be terminated unless the return statement
2680 -- completes unsuccessfully due to exception, abort, goto, or exit.
2681 -- As a formality, we test whether the function requires the result
2682 -- to be built in place, though that's necessarily true for the case
2683 -- of result types with task parts.
2689 -- Build a simple_return_statement that returns the return object
2691 Return_Stm :=
2696 Handled_Stm_Seq :=
2700 -- Case where we build a block
2703 Result :=
2708 -- We set the entity of the new block statement to be that of the
2709 -- return statement. This is necessary so that various fields, such
2710 -- as Finalization_Chain_Entity carry over from the return statement
2711 -- to the block. Note that this block is unusual, in that its entity
2712 -- is an E_Return_Statement rather than an E_Block.
2714 Set_Identifier
2717 -- If the object decl was already rewritten as a renaming, then
2718 -- we don't want to do the object allocation and transformation of
2719 -- of the return object declaration to a renaming. This case occurs
2720 -- when the return object is initialized by a call to another
2721 -- build-in-place function, and that function is responsible for the
2722 -- allocation of the return object.
2724 if Is_Build_In_Place
2725 and then
2727 then
2729 N_Object_Declaration
2730 and then Is_Build_In_Place_Function_Call
2737 -- Locate the implicit access parameter associated with the
2738 -- caller-supplied return object and convert the return
2739 -- statement's return object declaration to a renaming of a
2740 -- dereference of the access parameter. If the return object's
2741 -- declaration includes an expression that has not already been
2742 -- expanded as separate assignments, then add an assignment
2743 -- statement to ensure the return object gets initialized.
2745 -- declare
2746 -- Result : T [:= <expression>];
2747 -- begin
2748 -- ...
2750 -- is converted to
2752 -- declare
2753 -- Result : T renames FuncRA.all;
2754 -- [Result := <expression;]
2755 -- begin
2756 -- ...
2758 declare
2773 begin
2774 -- Build-in-place results must be returned by reference
2778 -- Retrieve the implicit access parameter passed by the caller
2780 Object_Access :=
2783 -- If the return object's declaration includes an expression
2784 -- and the declaration isn't marked as No_Initialization, then
2785 -- we need to generate an assignment to the object and insert
2786 -- it after the declaration before rewriting it as a renaming
2787 -- (otherwise we'll lose the initialization). The case where
2788 -- the result type is an interface (or class-wide interface)
2789 -- is also excluded because the context of the function call
2790 -- must be unconstrained, so the initialization will always
2791 -- be done as part of an allocator evaluation (storage pool
2792 -- or secondary stack), never to a constrained target object
2793 -- passed in by the caller. Besides the assignment being
2794 -- unneeded in this case, it avoids problems with trying to
2795 -- generate a dispatching assignment when the return expression
2796 -- is a nonlimited descendant of a limited interface (the
2797 -- interface has no assignment operation).
2802 then
2803 Init_Assignment :=
2817 and then not Is_Class_Wide_Type
2819 then
2822 Subtype_Mark =>
2823 New_Occurrence_Of
2825 Expression =>
2829 -- In the case of functions where the calling context can
2830 -- determine the form of allocation needed, initialization
2831 -- is done with each part of the if statement that handles
2832 -- the different forms of allocation (this is true for
2833 -- unconstrained and tagged result subtypes).
2835 if Constr_Result
2837 then
2842 -- When the function's subtype is unconstrained, a run-time
2843 -- test is needed to determine the form of allocation to use
2844 -- for the return object. The function has an implicit formal
2845 -- parameter indicating this. If the BIP_Alloc_Form formal has
2846 -- the value one, then the caller has passed access to an
2847 -- existing object for use as the return object. If the value
2848 -- is two, then the return object must be allocated on the
2849 -- secondary stack. Otherwise, the object must be allocated in
2850 -- a storage pool (currently only supported for the global
2851 -- heap, user-defined storage pools TBD ???). We generate an
2852 -- if statement to test the implicit allocation formal and
2853 -- initialize a local access value appropriately, creating
2854 -- allocators in the secondary stack and global heap cases.
2855 -- The special formal also exists and must be tested when the
2856 -- function has a tagged result, even when the result subtype
2857 -- is constrained, because in general such functions can be
2858 -- called in dispatching contexts and must be handled similarly
2859 -- to functions with a class-wide result.
2861 if not Constr_Result
2863 then
2864 Obj_Alloc_Formal :=
2867 declare
2876 begin
2877 -- Reuse the itype created for the function's implicit
2878 -- access formal. This avoids the need to create a new
2879 -- access type here, plus it allows assigning the access
2880 -- formal directly without applying a conversion.
2882 -- Ref_Type := Etype (Object_Access);
2884 -- Create an access type designating the function's
2885 -- result subtype.
2889 Ptr_Type_Decl :=
2892 Type_Definition =>
2895 Subtype_Indication =>
2900 -- Create an access object that will be initialized to an
2901 -- access value denoting the return object, either coming
2902 -- from an implicit access value passed in by the caller
2903 -- or from the result of an allocator.
2908 Alloc_Obj_Decl :=
2911 Object_Definition => New_Reference_To
2916 -- Create allocators for both the secondary stack and
2917 -- global heap. If there's an initialization expression,
2918 -- then create these as initialized allocators.
2922 then
2923 -- Always use the type of the expression for the
2924 -- qualified expression, rather than the result type.
2925 -- In general we cannot always use the result type
2926 -- for the allocator, because the expression might be
2927 -- of a specific type, such as in the case of an
2928 -- aggregate or even a nonlimited object when the
2929 -- result type is a limited class-wide interface type.
2931 Heap_Allocator :=
2933 Expression =>
2935 Subtype_Mark =>
2936 New_Reference_To
2938 Expression =>
2941 else
2942 -- If the function returns a class-wide type we cannot
2943 -- use the return type for the allocator. Instead we
2944 -- use the type of the expression, which must be an
2945 -- aggregate of a definite type.
2948 Heap_Allocator :=
2950 Expression =>
2951 New_Reference_To
2953 else
2954 Heap_Allocator :=
2956 Expression =>
2960 -- If the object requires default initialization then
2961 -- that will happen later following the elaboration of
2962 -- the object renaming. If we don't turn it off here
2963 -- then the object will be default initialized twice.
2968 -- If the No_Allocators restriction is active, then only
2969 -- an allocator for secondary stack allocation is needed.
2970 -- It's OK for such allocators to have Comes_From_Source
2971 -- set to False, because gigi knows not to flag them as
2972 -- being a violation of No_Implicit_Heap_Allocations.
2978 -- Otherwise the heap allocator may be needed, so we make
2979 -- another allocator for secondary stack allocation.
2981 else
2984 -- The heap allocator is marked Comes_From_Source
2985 -- since it corresponds to an explicit user-written
2986 -- allocator (that is, it will only be executed on
2987 -- behalf of callers that call the function as
2988 -- initialization for such an allocator). This
2989 -- prevents errors when No_Implicit_Heap_Allocations
2990 -- is in force.
2995 -- The allocator is returned on the secondary stack. We
2996 -- don't do this on VM targets, since the SS is not used.
3000 Set_Procedure_To_Call
3003 -- The allocator is returned on the secondary stack,
3004 -- so indicate that the function return, as well as
3005 -- the block that encloses the allocator, must not
3006 -- release it. The flags must be set now because the
3007 -- decision to use the secondary stack is done very
3008 -- late in the course of expanding the return
3009 -- statement, past the point where these flags are
3010 -- normally set.
3013 Set_Sec_Stack_Needed_For_Return
3019 -- Create an if statement to test the BIP_Alloc_Form
3020 -- formal and initialize the access object to either the
3021 -- BIP_Object_Access formal (BIP_Alloc_Form = 0), the
3022 -- result of allocating the object in the secondary stack
3023 -- (BIP_Alloc_Form = 1), or else an allocator to create
3024 -- the return object in the heap (BIP_Alloc_Form = 2).
3026 -- ??? An unchecked type conversion must be made in the
3027 -- case of assigning the access object formal to the
3028 -- local access object, because a normal conversion would
3029 -- be illegal in some cases (such as converting access-
3030 -- to-unconstrained to access-to-constrained), but the
3031 -- the unchecked conversion will presumably fail to work
3032 -- right in just such cases. It's not clear at all how to
3033 -- handle this. ???
3035 Alloc_If_Stmt :=
3037 Condition =>
3039 Left_Opnd =>
3041 Right_Opnd =>
3045 Then_Statements =>
3047 Name =>
3048 New_Reference_To
3050 Expression =>
3052 Subtype_Mark =>
3054 Expression =>
3055 New_Reference_To
3057 Elsif_Parts =>
3059 Condition =>
3061 Left_Opnd =>
3062 New_Reference_To
3064 Right_Opnd =>
3066 UI_From_Int (
3067 BIP_Allocation_Form'Pos
3069 Then_Statements =>
3070 New_List
3072 Name =>
3073 New_Reference_To
3075 Expression =>
3076 SS_Allocator)))),
3077 Else_Statements =>
3079 Name =>
3080 New_Reference_To
3082 Expression =>
3083 Heap_Allocator)));
3085 -- If a separate initialization assignment was created
3086 -- earlier, append that following the assignment of the
3087 -- implicit access formal to the access object, to ensure
3088 -- that the return object is initialized in that case.
3089 -- In this situation, the target of the assignment must
3090 -- be rewritten to denote a dereference of the access to
3091 -- the return object passed in by the caller.
3097 Set_Etype
3100 Append_To
3102 Init_Assignment);
3107 -- Remember the local access object for use in the
3108 -- dereference of the renaming created below.
3114 -- Replace the return object declaration with a renaming of a
3115 -- dereference of the access value designating the return
3116 -- object.
3118 Obj_Acc_Deref :=
3126 Subtype_Mark => New_Occurrence_Of
3134 -- Case where we do not build a block
3136 else
3137 -- We're about to drop Return_Object_Declarations on the floor, so
3138 -- we need to insert it, in case it got expanded into useful code.
3142 -- Build simple_return_statement that returns the expression directly
3149 -- Set the flag to prevent infinite recursion
3157 -----------------------------
3158 -- Expand_N_Goto_Statement --
3159 -----------------------------
3161 -- Add poll before goto if polling active
3164 begin
3168 ---------------------------
3169 -- Expand_N_If_Statement --
3170 ---------------------------
3172 -- First we deal with the case of C and Fortran convention boolean values,
3173 -- with zero/non-zero semantics.
3175 -- Second, we deal with the obvious rewriting for the cases where the
3176 -- condition of the IF is known at compile time to be True or False.
3178 -- Third, we remove elsif parts which have non-empty Condition_Actions and
3179 -- rewrite as independent if statements. For example:
3181 -- if x then xs
3182 -- elsif y then ys
3183 -- ...
3184 -- end if;
3186 -- becomes
3187 --
3188 -- if x then xs
3189 -- else
3190 -- <<condition actions of y>>
3191 -- if y then ys
3192 -- ...
3193 -- end if;
3194 -- end if;
3196 -- This rewriting is needed if at least one elsif part has a non-empty
3197 -- Condition_Actions list. We also do the same processing if there is a
3198 -- constant condition in an elsif part (in conjunction with the first
3199 -- processing step mentioned above, for the recursive call made to deal
3200 -- with the created inner if, this deals with properly optimizing the
3201 -- cases of constant elsif conditions).
3211 -- Indicates whether we want warnings when we delete branches of the
3212 -- if statement based on constant condition analysis. We never want
3213 -- these warnings for expander generated code.
3215 begin
3218 -- The following loop deals with constant conditions for the IF. We
3219 -- need a loop because as we eliminate False conditions, we grab the
3220 -- first elsif condition and use it as the primary condition.
3224 -- If condition is True, we can simply rewrite the if statement now
3225 -- by replacing it by the series of then statements.
3229 -- All the else parts can be killed
3239 -- If condition is False, then we can delete the condition and
3240 -- the Then statements
3242 else
3243 -- We do not delete the condition if constant condition warnings
3244 -- are enabled, since otherwise we end up deleting the desired
3245 -- warning. Of course the backend will get rid of this True/False
3246 -- test anyway, so nothing is lost here.
3254 -- If there are no elsif statements, then we simply replace the
3255 -- entire if statement by the sequence of else statements.
3260 then
3263 else
3271 -- If there are elsif statements, the first of them becomes the
3272 -- if/then section of the rebuilt if statement This is the case
3273 -- where we loop to reprocess this copied condition.
3275 else
3281 -- Hed might have been captured as the condition determining
3282 -- the current value for an entity. Now it is detached from
3283 -- the tree, so a Current_Value pointer in the condition might
3284 -- need to be updated.
3295 -- Loop through elsif parts, dealing with constant conditions and
3296 -- possible expression actions that are present.
3303 -- If there are condition actions, then rewrite the if statement
3304 -- as indicated above. We also do the same rewrite for a True or
3305 -- False condition. The further processing of this constant
3306 -- condition is then done by the recursive call to expand the
3307 -- newly created if statement
3311 then
3312 -- Note this is not an implicit if statement, since it is part
3313 -- of an explicit if statement in the source (or of an implicit
3314 -- if statement that has already been tested).
3316 New_If :=
3323 -- Elsif parts for new if come from remaining elsif's of parent
3348 -- No special processing for that elsif part, move to next
3350 else
3356 -- Some more optimizations applicable if we still have an IF statement
3362 -- Another optimization, special cases that can be simplified
3364 -- if expression then
3365 -- return true;
3366 -- else
3367 -- return false;
3368 -- end if;
3370 -- can be changed to:
3372 -- return expression;
3374 -- and
3376 -- if expression then
3377 -- return false;
3378 -- else
3379 -- return true;
3380 -- end if;
3382 -- can be changed to:
3384 -- return not (expression);
3386 -- Only do these optimizations if we are at least at -O1 level and
3387 -- do not do them if control flow optimizations are suppressed.
3391 then
3397 then
3398 declare
3402 begin
3404 and then
3406 then
3407 declare
3411 begin
3413 and then
3415 then
3418 then
3427 then
3430 Expression =>
3432 Right_Opnd =>
3445 -----------------------------
3446 -- Expand_N_Loop_Statement --
3447 -----------------------------
3449 -- 1. Remove null loop entirely
3450 -- 2. Deal with while condition for C/Fortran boolean
3451 -- 3. Deal with loops with a non-standard enumeration type range
3452 -- 4. Deal with while loops where Condition_Actions is set
3453 -- 5. Insert polling call if required
3459 begin
3460 -- Delete null loop
3467 -- Deal with condition for C/Fortran Boolean
3473 -- Generate polling call
3479 -- Nothing more to do for plain loop with no iteration scheme
3485 -- Note: we do not have to worry about validity checking of the for loop
3486 -- range bounds here, since they were frozen with constant declarations
3487 -- and it is during that process that the validity checking is done.
3489 -- Handle the case where we have a for loop with the range type being an
3490 -- enumeration type with non-standard representation. In this case we
3491 -- expand:
3493 -- for x in [reverse] a .. b loop
3494 -- ...
3495 -- end loop;
3497 -- to
3499 -- for xP in [reverse] integer
3500 -- range etype'Pos (a) .. etype'Pos (b) loop
3501 -- declare
3502 -- x : constant etype := Pos_To_Rep (xP);
3503 -- begin
3504 -- ...
3505 -- end;
3506 -- end loop;
3509 declare
3517 begin
3520 then
3524 New_Id :=
3528 -- If the type has a contiguous representation, successive values
3529 -- can be generated as offsets from the first literal.
3532 Expr :=
3535 Left_Opnd =>
3539 else
3540 -- Use the constructed array Enum_Pos_To_Rep
3542 Expr :=
3552 Iteration_Scheme =>
3554 Loop_Parameter_Specification =>
3559 Discrete_Subtype_Definition =>
3562 Subtype_Mark =>
3565 Constraint =>
3567 Range_Expression =>
3570 Low_Bound =>
3572 Prefix =>
3578 Relocate_Node
3581 High_Bound =>
3583 Prefix =>
3589 Relocate_Node
3601 Handled_Statement_Sequence =>
3609 -- Second case, if we have a while loop with Condition_Actions set, then
3610 -- we change it into a plain loop:
3612 -- while C loop
3613 -- ...
3614 -- end loop;
3616 -- changed to:
3618 -- loop
3619 -- <<condition actions>>
3620 -- exit when not C;
3621 -- ...
3622 -- end loop
3626 then
3627 declare
3630 begin
3631 ES :=
3633 Condition =>
3640 -- This is not an implicit loop, since it is generated in response
3641 -- to the loop statement being processed. If this is itself
3642 -- implicit, the restriction has already been checked. If not,
3643 -- it is an explicit loop.
3656 --------------------------------------
3657 -- Expand_N_Simple_Return_Statement --
3658 --------------------------------------
3661 begin
3662 -- Defend against previous errors (i.e. the return statement calls a
3663 -- function that is not available in configurable runtime).
3667 then
3671 -- Distinguish the function and non-function cases:
3675 when E_Function |
3676 E_Generic_Function =>
3679 when E_Procedure |
3680 E_Generic_Procedure |
3681 E_Entry |
3682 E_Entry_Family |
3683 E_Return_Statement =>
3690 exception
3695 --------------------------------
3696 -- Expand_Non_Function_Return --
3697 --------------------------------
3711 begin
3712 -- Call _Postconditions procedure if procedure with active
3713 -- postconditions. Here, we use the Postcondition_Proc attribute, which
3714 -- is needed for implicitly-generated returns. Functions never
3715 -- have implicitly-generated returns, and there's no room for
3716 -- Postcondition_Proc in E_Function, so we look up the identifier
3717 -- Name_uPostconditions for function returns (see
3718 -- Expand_Simple_Function_Return).
3722 then
3729 -- If it is a return from a procedure do no extra steps
3734 -- If it is a nested return within an extended one, replace it with a
3735 -- return of the previously declared return object.
3740 Expression =>
3750 -- Look at the enclosing block to see whether the return is from an
3751 -- accept statement or an entry body.
3758 -- If it is a return from accept statement it is expanded as call to
3759 -- RTS Complete_Rendezvous and a goto to the end of the accept body.
3761 -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept,
3762 -- Expand_N_Accept_Alternative in exp_ch9.adb)
3766 Call :=
3770 -- why not insert actions here???
3782 Name => New_Occurrence_Of
3790 -- If it is a return from an entry body, put a Complete_Entry_Body call
3791 -- in front of the return.
3794 Call :=
3796 Name =>
3800 Prefix =>
3801 New_Reference_To
3803 Attribute_Name =>
3804 Name_Unchecked_Access)));
3811 -----------------------------------
3812 -- Expand_Simple_Function_Return --
3813 -----------------------------------
3815 -- The "simple" comes from the syntax rule simple_return_statement.
3816 -- The semantics are not at all simple!
3823 -- The function we are returning from
3826 -- The result type of the function
3834 -- The type of the expression (not necessarily the same as R_Type)
3837 -- If the result type of the function is class-wide and the
3838 -- expression has a specific type, then we use the expression's
3839 -- type as the type of the return object. In cases where the
3840 -- expression is an aggregate that is built in place, this avoids
3841 -- the need for an expensive conversion of the return object to
3842 -- the specific type on assignments to the individual components.
3844 begin
3847 then
3849 else
3853 -- For the case of a simple return that does not come from an extended
3854 -- return, in the case of Ada 2005 where we are returning a limited
3855 -- type, we rewrite "return <expression>;" to be:
3857 -- return _anon_ : <return_subtype> := <expression>
3859 -- The expansion produced by Expand_N_Extended_Return_Statement will
3860 -- contain simple return statements (for example, a block containing
3861 -- simple return of the return object), which brings us back here with
3862 -- Comes_From_Extended_Return_Statement set. The reason for the barrier
3863 -- checking for a simple return that does not come from an extended
3864 -- return is to avoid this infinite recursion.
3866 -- The reason for this design is that for Ada 2005 limited returns, we
3867 -- need to reify the return object, so we can build it "in place", and
3868 -- we need a block statement to hang finalization and tasking stuff.
3870 -- ??? In order to avoid disruption, we avoid translating to extended
3871 -- return except in the cases where we really need to (Ada 2005 for
3872 -- inherently limited). We might prefer to do this translation in all
3873 -- cases (except perhaps for the case of Ada 95 inherently limited),
3874 -- in order to fully exercise the Expand_N_Extended_Return_Statement
3875 -- code. This would also allow us to do the build-in-place optimization
3876 -- for efficiency even in cases where it is semantically not required.
3878 -- As before, we check the type of the return expression rather than the
3879 -- return type of the function, because the latter may be a limited
3880 -- class-wide interface type, which is not a limited type, even though
3881 -- the type of the expression may be.
3886 and then not Debug_Flag_Dot_L
3887 then
3888 declare
3899 -- Do not perform this high-level optimization if the result type
3900 -- is an interface because the "this" pointer must be displaced.
3902 begin
3909 -- Here we have a simple return statement that is part of the expansion
3910 -- of an extended return statement (either written by the user, or
3911 -- generated by the above code).
3913 -- Always normalize C/Fortran boolean result. This is not always needed,
3914 -- but it seems a good idea to minimize the passing around of non-
3915 -- normalized values, and in any case this handles the processing of
3916 -- barrier functions for protected types, which turn the condition into
3917 -- a return statement.
3921 then
3926 -- Do validity check if enabled for returns
3928 if Validity_Checks_On
3929 and then Validity_Check_Returns
3930 then
3934 -- Check the result expression of a scalar function against the subtype
3935 -- of the function by inserting a conversion. This conversion must
3936 -- eventually be performed for other classes of types, but for now it's
3937 -- only done for scalars.
3938 -- ???
3943 -- The expression is resolved to ensure that the conversion gets
3944 -- expanded to generate a possible constraint check.
3949 -- Deal with returning variable length objects and controlled types
3951 -- Nothing to do if we are returning by reference, or this is not a
3952 -- type that requires special processing (indicated by the fact that
3953 -- it requires a cleanup scope for the secondary stack case).
3957 then
3962 -- Mutable records with no variable length components are not
3963 -- returned on the sec-stack, so we need to make sure that the
3964 -- backend will only copy back the size of the actual value, and not
3965 -- the maximum size. We create an actual subtype for this purpose.
3967 declare
3971 begin
3975 then
3984 -- Here if secondary stack is used
3986 else
3987 -- Make sure that no surrounding block will reclaim the secondary
3988 -- stack on which we are going to put the result. Not only may this
3989 -- introduce secondary stack leaks but worse, if the reclamation is
3990 -- done too early, then the result we are returning may get
3991 -- clobbered.
3993 declare
3995 begin
4003 -- Optimize the case where the result is a function call. In this
4004 -- case either the result is already on the secondary stack, or is
4005 -- already being returned with the stack pointer depressed and no
4006 -- further processing is required except to set the By_Ref flag to
4007 -- ensure that gigi does not attempt an extra unnecessary copy.
4008 -- (actually not just unnecessary but harmfully wrong in the case
4009 -- of a controlled type, where gigi does not know how to do a copy).
4010 -- To make up for a gcc 2.8.1 deficiency (???), we perform
4011 -- the copy for array types if the constrained status of the
4012 -- target type is different from that of the expression.
4015 and then
4020 then
4023 -- Remove side effects from the expression now so that other parts
4024 -- of the expander do not have to reanalyze this node without this
4025 -- optimization
4029 -- For controlled types, do the allocation on the secondary stack
4030 -- manually in order to call adjust at the right time:
4032 -- type Anon1 is access R_Type;
4033 -- for Anon1'Storage_pool use ss_pool;
4034 -- Anon2 : anon1 := new R_Type'(expr);
4035 -- return Anon2.all;
4037 -- We do the same for classwide types that are not potentially
4038 -- controlled (by the virtue of restriction No_Finalization) because
4039 -- gigi is not able to properly allocate class-wide types.
4042 declare
4048 begin
4053 -- This is an allocator for the secondary stack, and it's fine
4054 -- to have Comes_From_Source set False on it, as gigi knows not
4055 -- to flag it as a violation of No_Implicit_Heap_Allocations.
4057 Alloc_Node :=
4059 Expression =>
4064 -- We do not want discriminant checks on the declaration,
4065 -- given that it gets its value from the allocator.
4074 Type_Definition =>
4090 -- Otherwise use the gigi mechanism to allocate result on the
4091 -- secondary stack.
4093 else
4097 -- If we are generating code for the VM do not use
4098 -- SS_Allocate since everything is heap-allocated anyway.
4106 -- Implement the rules of 6.5(8-10), which require a tag check in the
4107 -- case of a limited tagged return type, and tag reassignment for
4108 -- nonlimited tagged results. These actions are needed when the return
4109 -- type is a specific tagged type and the result expression is a
4110 -- conversion or a formal parameter, because in that case the tag of the
4111 -- expression might differ from the tag of the specific result type.
4116 N_Unchecked_Type_Conversion)
4119 then
4120 -- When the return type is limited, perform a check that the
4121 -- tag of the result is the same as the tag of the return type.
4126 Condition =>
4128 Left_Opnd =>
4131 Selector_Name =>
4133 Right_Opnd =>
4135 New_Reference_To
4138 Loc))),
4141 -- If the result type is a specific nonlimited tagged type, then we
4142 -- have to ensure that the tag of the result is that of the result
4143 -- type. This is handled by making a copy of the expression in the
4144 -- case where it might have a different tag, namely when the
4145 -- expression is a conversion or a formal parameter. We create a new
4146 -- object of the result type and initialize it from the expression,
4147 -- which will implicitly force the tag to be set appropriately.
4149 else
4150 declare
4159 Object_Definition =>
4164 begin
4173 -- Ada 2005 (AI-344): If the result type is class-wide, then insert
4174 -- a check that the level of the return expression's underlying type
4175 -- is not deeper than the level of the master enclosing the function.
4176 -- Always generate the check when the type of the return expression
4177 -- is class-wide, when it's a type conversion, or when it's a formal
4178 -- parameter. Otherwise, suppress the check in the case where the
4179 -- return expression has a specific type whose level is known not to
4180 -- be statically deeper than the function's result type.
4182 -- Note: accessibility check is skipped in the VM case, since there
4183 -- does not seem to be any practical way to implement this check.
4186 and then Tagged_Type_Expansion
4189 and then
4192 N_Unchecked_Type_Conversion)
4197 then
4198 declare
4201 begin
4202 -- Ada 2005 (AI-251): In class-wide interface objects we displace
4203 -- "this" to reference the base of the object --- required to get
4204 -- access to the TSD of the object.
4209 then
4210 Tag_Node :=
4218 else
4219 Tag_Node :=
4227 Condition =>
4229 Left_Opnd =>
4231 Right_Opnd =>
4238 -- If we are returning an object that may not be bit-aligned, then copy
4239 -- the value into a temporary first. This copy may need to expand to a
4240 -- loop of component operations.
4244 then
4245 declare
4248 begin
4260 -- Generate call to postcondition checks if they are present
4264 then
4265 -- We are going to reference the returned value twice in this case,
4266 -- once in the call to _Postconditions, and once in the actual return
4267 -- statement, but we can't have side effects happening twice, and in
4268 -- any case for efficiency we don't want to do the computation twice.
4270 -- If the returned expression is an entity name, we don't need to
4271 -- worry since it is efficient and safe to reference it twice, that's
4272 -- also true for literals other than string literals, and for the
4273 -- case of X.all where X is an entity name.
4277 N_Integer_Literal,
4278 N_Real_Literal)
4281 then
4284 -- Otherwise we are going to need a temporary to capture the value
4286 else
4287 declare
4291 begin
4292 -- For a complex expression of an elementary type, capture
4293 -- value in the temporary and use it as the reference.
4306 -- If we have something we can rename, generate a renaming of
4307 -- the object and replace the expression with a reference
4319 -- Otherwise we have something like a string literal or an
4320 -- aggregate. We could copy the value, but that would be
4321 -- inefficient. Instead we make a reference to the value and
4322 -- capture this reference with a renaming, the expression is
4323 -- then replaced by a dereference of this renaming.
4325 else
4326 -- For now, copy the value, since the code below does not
4327 -- seem to work correctly ???
4339 -- Insert_Action (Exp,
4340 -- Make_Object_Renaming_Declaration (Loc,
4341 -- Defining_Identifier => Tnn,
4342 -- Access_Definition =>
4343 -- Make_Access_Definition (Loc,
4344 -- All_Present => True,
4345 -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)),
4346 -- Name =>
4347 -- Make_Reference (Loc,
4348 -- Prefix => Relocate_Node (Exp))),
4349 -- Suppress => All_Checks);
4351 -- Rewrite (Exp,
4352 -- Make_Explicit_Dereference (Loc,
4353 -- Prefix => New_Occurrence_Of (Tnn, Loc)));
4358 -- Generate call to _postconditions
4366 -- Ada 2005 (AI-251): If this return statement corresponds with an
4367 -- simple return statement associated with an extended return statement
4368 -- and the type of the returned object is an interface then generate an
4369 -- implicit conversion to force displacement of the "this" pointer.
4376 then
4382 ------------------------------
4383 -- Make_Tag_Ctrl_Assignment --
4384 ------------------------------
4398 and then not Component_Assign
4401 -- Tags are not saved and restored when VM_Target because VM tags are
4402 -- represented implicitly in objects.
4411 begin
4414 -- Finalize the target of the assignment when controlled
4416 -- We have two exceptions here:
4418 -- 1. If we are in an init proc since it is an initialization more
4419 -- than an assignment.
4421 -- 2. If the left-hand side is a temporary that was not initialized
4422 -- (or the parent part of a temporary since it is the case in
4423 -- extension aggregates). Such a temporary does not come from
4424 -- source. We must examine the original node for the prefix, because
4425 -- it may be a component of an entry formal, in which case it has
4426 -- been rewritten and does not appear to come from source either.
4428 -- Case of init proc
4433 -- The left hand side is an uninitialized temporary object
4438 N_Object_Declaration
4440 then
4443 else
4445 Make_Final_Call
4451 -- Save the Tag in a local variable Tag_Tmp
4460 Expression =>
4464 Loc))));
4466 -- Otherwise Tag_Tmp not used
4468 else
4475 -- Cannot assign part of the object in a VM context, so instead
4476 -- fallback to the previous mechanism, even though it is not
4477 -- completely correct ???
4479 -- Save the Finalization Pointers in local variables Prev_Tmp and
4480 -- Next_Tmp. For objects with Has_Controlled_Component set, these
4481 -- pointers are in the Record_Controller
4486 Ctrl_Ref :=
4489 Selector_Name =>
4499 Object_Definition =>
4502 Expression =>
4504 Prefix =>
4514 Object_Definition =>
4517 Expression =>
4519 Prefix =>
4524 -- Do the Assignment
4528 else
4529 -- Regular (non VM) processing for controlled types and types with
4530 -- controlled components
4532 -- Variables of such types contain pointers used to chain them in
4533 -- finalization lists, in addition to user data. These pointers
4534 -- are specific to each object of the type, not to the value being
4535 -- assigned.
4537 -- Thus they need to be left intact during the assignment. We
4538 -- achieve this by constructing a Storage_Array subtype, and by
4539 -- overlaying objects of this type on the source and target of the
4540 -- assignment. The assignment is then rewritten to assignments of
4541 -- slices of these arrays, copying the user data, and leaving the
4542 -- pointers untouched.
4546 -- A reference to the Prev component of the record controller
4549 -- Index of first byte to be copied (used to skip
4550 -- Root_Controlled in controlled objects).
4553 -- Index of last byte to be copied before outermost record
4554 -- controller data.
4557 -- Length of record controller data (Prev and Next pointers)
4560 -- Index of first byte to be copied after outermost record
4561 -- controller data.
4565 -- Used for computation of the size of the data to be copied
4570 function Build_Slice
4574 -- Build and return a slice of an array of type S overlaid on
4575 -- object Rec, with bounds specified by Lo and Hi. If either
4576 -- bound is empty, a default of S'First (respectively S'Last)
4577 -- is used.
4579 -----------------
4580 -- Build_Slice --
4581 -----------------
4583 function Build_Slice
4587 is
4596 -- Access value designating an opaque storage array of type
4597 -- S overlaid on record Rec.
4599 begin
4600 -- Compute slice bounds using S'First (1) and S'Last as
4601 -- default values when not specified by the caller.
4605 else
4613 else
4618 Prefix =>
4619 Opaque,
4624 -- Start of processing for Controlled_Actions
4626 begin
4627 -- Create a constrained subtype of Storage_Array whose size
4628 -- corresponds to the value being assigned.
4630 -- subtype G is Storage_Offset range
4631 -- 1 .. (Expr'Size + Storage_Unit - 1) / Storage_Unit
4643 then
4649 Source_Size :=
4651 Left_Opnd =>
4653 Prefix =>
4656 Right_Opnd =>
4660 Source_Size :=
4663 Right_Opnd =>
4672 Subtype_Indication =>
4674 Subtype_Mark =>
4677 Range_Expression =>
4682 -- subtype S is Storage_Array (G)
4687 Subtype_Indication =>
4689 Subtype_Mark =>
4691 Constraint =>
4693 Constraints =>
4696 -- type A is access S
4703 Type_Definition =>
4705 Subtype_Indication =>
4706 New_Occurrence_Of (
4709 -- Generate appropriate slice assignments
4713 -- For controlled object, skip Root_Controlled part
4716 First_After_Root :=
4718 First_After_Root,
4721 Prefix =>
4727 -- For the case of a record with controlled components, skip
4728 -- record controller Prev/Next components. These components
4729 -- constitute a 'hole' in the middle of the data to be copied.
4732 Prev_Ref :=
4734 Prefix =>
4737 Selector_Name =>
4741 -- Last index before hole: determined by position of the
4742 -- _Controller.Prev component.
4752 Expression =>
4761 -- Hole length: size of the Prev and Next components
4763 Hole_Length :=
4766 Right_Opnd =>
4768 Left_Opnd =>
4772 Right_Opnd =>
4776 -- First index after hole
4786 Expression =>
4788 Left_Opnd =>
4790 Left_Opnd =>
4795 Last_Before_Hole :=
4797 First_After_Hole :=
4801 -- Assign the first slice (possibly skipping Root_Controlled,
4802 -- up to the beginning of the record controller if present,
4803 -- up to the end of the object if not).
4818 -- If a record controller is present, copy the second slice,
4819 -- from right after the _Controller.Next component up to the
4820 -- end of the object.
4835 -- Not controlled case
4837 else
4838 declare
4841 begin
4842 -- If this is the case of a tagged type with a full rep clause,
4843 -- we must expand it into component assignments, so we mark the
4844 -- node as unanalyzed, to get it reanalyzed, but flag it has
4845 -- requiring component-wise assignment so we don't get infinite
4846 -- recursion.
4857 -- Restore the tag
4862 Name =>
4866 Loc)),
4872 -- Restore the finalization pointers
4876 Name =>
4878 Prefix =>
4886 Name =>
4888 Prefix =>
4895 -- Adjust the target after the assignment when controlled (not in the
4896 -- init proc since it is an initialization more than an assignment).
4899 Make_Adjust_Call (
4908 exception
4909 -- Could use comment here ???