1 -----------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 with Atree; use Atree;
30 with Checks; use Checks;
31 with Einfo; use Einfo;
32 with Exp_Aggr; use Exp_Aggr;
33 with Exp_Ch7; use Exp_Ch7;
34 with Exp_Ch11; use Exp_Ch11;
35 with Exp_Dbug; use Exp_Dbug;
36 with Exp_Pakd; use Exp_Pakd;
37 with Exp_Util; use Exp_Util;
38 with Hostparm; use Hostparm;
39 with Nlists; use Nlists;
40 with Nmake; use Nmake;
42 with Restrict; use Restrict;
43 with Rtsfind; use Rtsfind;
44 with Sinfo; use Sinfo;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Ch13; use Sem_Ch13;
48 with Sem_Eval; use Sem_Eval;
49 with Sem_Res; use Sem_Res;
50 with Sem_Util; use Sem_Util;
51 with Snames; use Snames;
52 with Stand; use Stand;
53 with Tbuild; use Tbuild;
54 with Ttypes; use Ttypes;
55 with Uintp; use Uintp;
56 with Validsw; use Validsw;
58 package body Exp_Ch5 is
60 function Change_Of_Representation (N : Node_Id) return Boolean;
61 -- Determine if the right hand side of the assignment N is a type
62 -- conversion which requires a change of representation. Called
63 -- only for the array and record cases.
65 procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id);
66 -- N is an assignment which assigns an array value. This routine process
67 -- the various special cases and checks required for such assignments,
68 -- including change of representation. Rhs is normally simply the right
69 -- hand side of the assignment, except that if the right hand side is
70 -- a type conversion or a qualified expression, then the Rhs is the
71 -- actual expression inside any such type conversions or qualifications.
73 function Expand_Assign_Array_Loop
82 -- N is an assignment statement which assigns an array value. This routine
83 -- expands the assignment into a loop (or nested loops for the case of a
84 -- multi-dimensional array) to do the assignment component by component.
85 -- Larray and Rarray are the entities of the actual arrays on the left
86 -- hand and right hand sides. L_Type and R_Type are the types of these
87 -- arrays (which may not be the same, due to either sliding, or to a
88 -- change of representation case). Ndim is the number of dimensions and
89 -- the parameter Rev indicates if the loops run normally (Rev = False),
90 -- or reversed (Rev = True). The value returned is the constructed
91 -- loop statement. Auxiliary declarations are inserted before node N
92 -- using the standard Insert_Actions mechanism.
94 procedure Expand_Assign_Record (N : Node_Id);
95 -- N is an assignment of a non-tagged record value. This routine handles
96 -- the special cases and checks required for such assignments, including
97 -- change of representation.
99 function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
100 -- Generate the necessary code for controlled and Tagged assignment,
101 -- that is to say, finalization of the target before, adjustement of
102 -- the target after and save and restore of the tag and finalization
103 -- pointers which are not 'part of the value' and must not be changed
104 -- upon assignment. N is the original Assignment node.
106 ------------------------------
107 -- Change_Of_Representation --
108 ------------------------------
110 function Change_Of_Representation (N : Node_Id) return Boolean is
111 Rhs : constant Node_Id := Expression (N);
115 Nkind (Rhs) = N_Type_Conversion
117 not Same_Representation (Etype (Rhs), Etype (Expression (Rhs)));
118 end Change_Of_Representation;
120 -------------------------
121 -- Expand_Assign_Array --
122 -------------------------
124 -- There are two issues here. First, do we let Gigi do a block move, or
125 -- do we expand out into a loop? Second, we need to set the two flags
126 -- Forwards_OK and Backwards_OK which show whether the block move (or
127 -- corresponding loops) can be legitimately done in a forwards (low to
128 -- high) or backwards (high to low) manner.
130 procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id) is
131 Loc : constant Source_Ptr := Sloc (N);
133 Lhs : constant Node_Id := Name (N);
135 Act_Lhs : constant Node_Id := Get_Referenced_Object (Lhs);
136 Act_Rhs : Node_Id := Get_Referenced_Object (Rhs);
138 L_Type : constant Entity_Id :=
139 Underlying_Type (Get_Actual_Subtype (Act_Lhs));
140 R_Type : Entity_Id :=
141 Underlying_Type (Get_Actual_Subtype (Act_Rhs));
143 L_Slice : constant Boolean := Nkind (Act_Lhs) = N_Slice;
144 R_Slice : constant Boolean := Nkind (Act_Rhs) = N_Slice;
146 Crep : constant Boolean := Change_Of_Representation (N);
151 Ndim : constant Pos := Number_Dimensions (L_Type);
153 Loop_Required : Boolean := False;
154 -- This switch is set to True if the array move must be done using
155 -- an explicit front end generated loop.
157 function Has_Address_Clause (Exp : Node_Id) return Boolean;
158 -- Test if Exp is a reference to an array whose declaration has
159 -- an address clause, or it is a slice of such an array.
161 function Is_Formal_Array (Exp : Node_Id) return Boolean;
162 -- Test if Exp is a reference to an array which is either a formal
163 -- parameter or a slice of a formal parameter. These are the cases
164 -- where hidden aliasing can occur.
166 function Is_Non_Local_Array (Exp : Node_Id) return Boolean;
167 -- Determine if Exp is a reference to an array variable which is other
168 -- than an object defined in the current scope, or a slice of such
169 -- an object. Such objects can be aliased to parameters (unlike local
170 -- array references).
172 function Possible_Unaligned_Slice (Arg : Node_Id) return Boolean;
173 -- Returns True if Arg (either the left or right hand side of the
174 -- assignment) is a slice that could be unaligned wrt the array type.
175 -- This is true if Arg is a component of a packed record, or is
176 -- a record component to which a component clause applies. This
177 -- is a little pessimistic, but the result of an unnecessary
178 -- decision that something is possibly unaligned is only to
179 -- generate a front end loop, which is not so terrible.
180 -- It would really be better if backend handled this ???
182 ------------------------
183 -- Has_Address_Clause --
184 ------------------------
186 function Has_Address_Clause (Exp : Node_Id) return Boolean is
189 (Is_Entity_Name (Exp) and then
190 Present (Address_Clause (Entity (Exp))))
192 (Nkind (Exp) = N_Slice and then Has_Address_Clause (Prefix (Exp)));
193 end Has_Address_Clause;
195 ---------------------
196 -- Is_Formal_Array --
197 ---------------------
199 function Is_Formal_Array (Exp : Node_Id) return Boolean is
202 (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp)))
204 (Nkind (Exp) = N_Slice and then Is_Formal_Array (Prefix (Exp)));
207 ------------------------
208 -- Is_Non_Local_Array --
209 ------------------------
211 function Is_Non_Local_Array (Exp : Node_Id) return Boolean is
213 return (Is_Entity_Name (Exp)
214 and then Scope (Entity (Exp)) /= Current_Scope)
215 or else (Nkind (Exp) = N_Slice
216 and then Is_Non_Local_Array (Prefix (Exp)));
217 end Is_Non_Local_Array;
219 ------------------------------
220 -- Possible_Unaligned_Slice --
221 ------------------------------
223 function Possible_Unaligned_Slice (Arg : Node_Id) return Boolean is
225 -- No issue if this is not a slice, or else strict alignment
226 -- is not required in any case.
228 if Nkind (Arg) /= N_Slice
229 or else not Target_Strict_Alignment
234 -- No issue if the component type is a byte or byte aligned
237 Array_Typ : constant Entity_Id := Etype (Arg);
238 Comp_Typ : constant Entity_Id := Component_Type (Array_Typ);
239 Pref : constant Node_Id := Prefix (Arg);
242 if Known_Alignment (Array_Typ) then
243 if Alignment (Array_Typ) = 1 then
247 elsif Known_Component_Size (Array_Typ) then
248 if Component_Size (Array_Typ) = 1 then
252 elsif Known_Esize (Comp_Typ) then
253 if Esize (Comp_Typ) <= System_Storage_Unit then
258 -- No issue if this is not a selected component
260 if Nkind (Pref) /= N_Selected_Component then
264 -- Else we test for a possibly unaligned component
267 Is_Packed (Etype (Pref))
269 Present (Component_Clause (Entity (Selector_Name (Pref))));
271 end Possible_Unaligned_Slice;
273 -- Determine if Lhs, Rhs are formal arrays or non-local arrays
275 Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs);
276 Rhs_Formal : constant Boolean := Is_Formal_Array (Act_Rhs);
278 Lhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Lhs);
279 Rhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Rhs);
281 -- Start of processing for Expand_Assign_Array
284 -- Deal with length check, note that the length check is done with
285 -- respect to the right hand side as given, not a possible underlying
286 -- renamed object, since this would generate incorrect extra checks.
288 Apply_Length_Check (Rhs, L_Type);
290 -- We start by assuming that the move can be done in either
291 -- direction, i.e. that the two sides are completely disjoint.
293 Set_Forwards_OK (N, True);
294 Set_Backwards_OK (N, True);
296 -- Normally it is only the slice case that can lead to overlap,
297 -- and explicit checks for slices are made below. But there is
298 -- one case where the slice can be implicit and invisible to us
299 -- and that is the case where we have a one dimensional array,
300 -- and either both operands are parameters, or one is a parameter
301 -- and the other is a global variable. In this case the parameter
302 -- could be a slice that overlaps with the other parameter.
304 -- Check for the case of slices requiring an explicit loop. Normally
305 -- it is only the explicit slice cases that bother us, but in the
306 -- case of one dimensional arrays, parameters can be slices that
307 -- are passed by reference, so we can have aliasing for assignments
308 -- from one parameter to another, or assignments between parameters
309 -- and non-local variables.
311 -- Note: overlap is never possible if there is a change of
312 -- representation, so we can exclude this case
317 ((Lhs_Formal and Rhs_Formal)
319 (Lhs_Formal and Rhs_Non_Local_Var)
321 (Rhs_Formal and Lhs_Non_Local_Var))
323 -- In the case of compiling for the Java Virtual Machine,
324 -- slices are always passed by making a copy, so we don't
325 -- have to worry about overlap. We also want to prevent
326 -- generation of "<" comparisons for array addresses,
327 -- since that's a meaningless operation on the JVM.
331 Set_Forwards_OK (N, False);
332 Set_Backwards_OK (N, False);
334 -- Note: the bit-packed case is not worrisome here, since if
335 -- we have a slice passed as a parameter, it is always aligned
336 -- on a byte boundary, and if there are no explicit slices, the
337 -- assignment can be performed directly.
340 -- We certainly must use a loop for change of representation
341 -- and also we use the operand of the conversion on the right
342 -- hand side as the effective right hand side (the component
343 -- types must match in this situation).
346 Act_Rhs := Get_Referenced_Object (Rhs);
347 R_Type := Get_Actual_Subtype (Act_Rhs);
348 Loop_Required := True;
350 -- Arrays with controlled components are expanded into a loop
351 -- to force calls to adjust at the component level.
353 elsif Has_Controlled_Component (L_Type) then
354 Loop_Required := True;
356 -- Case where no slice is involved
358 elsif not L_Slice and not R_Slice then
360 -- The following code deals with the case of unconstrained bit
361 -- packed arrays. The problem is that the template for such
362 -- arrays contains the bounds of the actual source level array,
364 -- But the copy of an entire array requires the bounds of the
365 -- underlying array. It would be nice if the back end could take
366 -- care of this, but right now it does not know how, so if we
367 -- have such a type, then we expand out into a loop, which is
368 -- inefficient but works correctly. If we don't do this, we
369 -- get the wrong length computed for the array to be moved.
370 -- The two cases we need to worry about are:
372 -- Explicit deference of an unconstrained packed array type as
373 -- in the following example:
376 -- type BITS is array(INTEGER range <>) of BOOLEAN;
377 -- pragma PACK(BITS);
378 -- type A is access BITS;
381 -- P1 := new BITS (1 .. 65_535);
382 -- P2 := new BITS (1 .. 65_535);
386 -- A formal parameter reference with an unconstrained bit
387 -- array type is the other case we need to worry about (here
388 -- we assume the same BITS type declared above:
390 -- procedure Write_All (File : out BITS; Contents : in BITS);
392 -- File.Storage := Contents;
395 -- We expand to a loop in either of these two cases.
397 -- Question for future thought. Another potentially more efficient
398 -- approach would be to create the actual subtype, and then do an
399 -- unchecked conversion to this actual subtype ???
401 Check_Unconstrained_Bit_Packed_Array : declare
403 function Is_UBPA_Reference (Opnd : Node_Id) return Boolean;
404 -- Function to perform required test for the first case,
405 -- above (dereference of an unconstrained bit packed array)
407 -----------------------
408 -- Is_UBPA_Reference --
409 -----------------------
411 function Is_UBPA_Reference (Opnd : Node_Id) return Boolean is
412 Typ : constant Entity_Id := Underlying_Type (Etype (Opnd));
414 Des_Type : Entity_Id;
417 if Present (Packed_Array_Type (Typ))
418 and then Is_Array_Type (Packed_Array_Type (Typ))
419 and then not Is_Constrained (Packed_Array_Type (Typ))
423 elsif Nkind (Opnd) = N_Explicit_Dereference then
424 P_Type := Underlying_Type (Etype (Prefix (Opnd)));
426 if not Is_Access_Type (P_Type) then
430 Des_Type := Designated_Type (P_Type);
432 Is_Bit_Packed_Array (Des_Type)
433 and then not Is_Constrained (Des_Type);
439 end Is_UBPA_Reference;
441 -- Start of processing for Check_Unconstrained_Bit_Packed_Array
444 if Is_UBPA_Reference (Lhs)
446 Is_UBPA_Reference (Rhs)
448 Loop_Required := True;
450 -- Here if we do not have the case of a reference to a bit
451 -- packed unconstrained array case. In this case gigi can
452 -- most certainly handle the assignment if a forwards move
455 -- (could it handle the backwards case also???)
457 elsif Forwards_OK (N) then
460 end Check_Unconstrained_Bit_Packed_Array;
462 -- Gigi can always handle the assignment if the right side is a string
463 -- literal (note that overlap is definitely impossible in this case).
465 elsif Nkind (Rhs) = N_String_Literal then
468 -- If either operand is bit packed, then we need a loop, since we
469 -- can't be sure that the slice is byte aligned. Similarly, if either
470 -- operand is a possibly unaligned slice, then we need a loop (since
471 -- gigi cannot handle unaligned slices).
473 elsif Is_Bit_Packed_Array (L_Type)
474 or else Is_Bit_Packed_Array (R_Type)
475 or else Possible_Unaligned_Slice (Lhs)
476 or else Possible_Unaligned_Slice (Rhs)
478 Loop_Required := True;
480 -- If we are not bit-packed, and we have only one slice, then no
481 -- overlap is possible except in the parameter case, so we can let
482 -- gigi handle things.
484 elsif not (L_Slice and R_Slice) then
485 if Forwards_OK (N) then
490 -- Come here to compelete the analysis
492 -- Loop_Required: Set to True if we know that a loop is required
493 -- regardless of overlap considerations.
495 -- Forwards_OK: Set to False if we already know that a forwards
496 -- move is not safe, else set to True.
498 -- Backwards_OK: Set to False if we already know that a backwards
499 -- move is not safe, else set to True
501 -- Our task at this stage is to complete the overlap analysis, which
502 -- can result in possibly setting Forwards_OK or Backwards_OK to
503 -- False, and then generating the final code, either by deciding
504 -- that it is OK after all to let Gigi handle it, or by generating
505 -- appropriate code in the front end.
508 L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type));
509 R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type));
511 Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ);
512 Left_Hi : constant Node_Id := Type_High_Bound (L_Index_Typ);
513 Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ);
514 Right_Hi : constant Node_Id := Type_High_Bound (R_Index_Typ);
516 Act_L_Array : Node_Id;
517 Act_R_Array : Node_Id;
523 Cresult : Compare_Result;
526 -- Get the expressions for the arrays. If we are dealing with a
527 -- private type, then convert to the underlying type. We can do
528 -- direct assignments to an array that is a private type, but
529 -- we cannot assign to elements of the array without this extra
530 -- unchecked conversion.
532 if Nkind (Act_Lhs) = N_Slice then
533 Larray := Prefix (Act_Lhs);
537 if Is_Private_Type (Etype (Larray)) then
540 (Underlying_Type (Etype (Larray)), Larray);
544 if Nkind (Act_Rhs) = N_Slice then
545 Rarray := Prefix (Act_Rhs);
549 if Is_Private_Type (Etype (Rarray)) then
552 (Underlying_Type (Etype (Rarray)), Rarray);
556 -- If both sides are slices, we must figure out whether
557 -- it is safe to do the move in one direction or the other
558 -- It is always safe if there is a change of representation
559 -- since obviously two arrays with different representations
560 -- cannot possibly overlap.
562 if (not Crep) and L_Slice and R_Slice then
563 Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs));
564 Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs));
566 -- If both left and right hand arrays are entity names, and
567 -- refer to different entities, then we know that the move
568 -- is safe (the two storage areas are completely disjoint).
570 if Is_Entity_Name (Act_L_Array)
571 and then Is_Entity_Name (Act_R_Array)
572 and then Entity (Act_L_Array) /= Entity (Act_R_Array)
576 -- Otherwise, we assume the worst, which is that the two
577 -- arrays are the same array. There is no need to check if
578 -- we know that is the case, because if we don't know it,
579 -- we still have to assume it!
581 -- Generally if the same array is involved, then we have
582 -- an overlapping case. We will have to really assume the
583 -- worst (i.e. set neither of the OK flags) unless we can
584 -- determine the lower or upper bounds at compile time and
588 Cresult := Compile_Time_Compare (Left_Lo, Right_Lo);
590 if Cresult = Unknown then
591 Cresult := Compile_Time_Compare (Left_Hi, Right_Hi);
595 when LT | LE | EQ => Set_Backwards_OK (N, False);
596 when GT | GE => Set_Forwards_OK (N, False);
597 when NE | Unknown => Set_Backwards_OK (N, False);
598 Set_Forwards_OK (N, False);
603 -- If after that analysis, Forwards_OK is still True, and
604 -- Loop_Required is False, meaning that we have not discovered
605 -- some non-overlap reason for requiring a loop, then we can
606 -- still let gigi handle it.
608 if not Loop_Required then
609 if Forwards_OK (N) then
614 -- Here is where a memmove would be appropriate ???
618 -- At this stage we have to generate an explicit loop, and
619 -- we have the following cases:
621 -- Forwards_OK = True
623 -- Rnn : right_index := right_index'First;
624 -- for Lnn in left-index loop
625 -- left (Lnn) := right (Rnn);
626 -- Rnn := right_index'Succ (Rnn);
629 -- Note: the above code MUST be analyzed with checks off,
630 -- because otherwise the Succ could overflow. But in any
631 -- case this is more efficient!
633 -- Forwards_OK = False, Backwards_OK = True
635 -- Rnn : right_index := right_index'Last;
636 -- for Lnn in reverse left-index loop
637 -- left (Lnn) := right (Rnn);
638 -- Rnn := right_index'Pred (Rnn);
641 -- Note: the above code MUST be analyzed with checks off,
642 -- because otherwise the Pred could overflow. But in any
643 -- case this is more efficient!
645 -- Forwards_OK = Backwards_OK = False
647 -- This only happens if we have the same array on each side. It is
648 -- possible to create situations using overlays that violate this,
649 -- but we simply do not promise to get this "right" in this case.
651 -- There are two possible subcases. If the No_Implicit_Conditionals
652 -- restriction is set, then we generate the following code:
655 -- T : constant <operand-type> := rhs;
660 -- If implicit conditionals are permitted, then we generate:
662 -- if Left_Lo <= Right_Lo then
663 -- <code for Forwards_OK = True above>
665 -- <code for Backwards_OK = True above>
668 -- Cases where either Forwards_OK or Backwards_OK is true
670 if Forwards_OK (N) or else Backwards_OK (N) then
672 Expand_Assign_Array_Loop
673 (N, Larray, Rarray, L_Type, R_Type, Ndim,
674 Rev => not Forwards_OK (N)));
676 -- Case of both are false with No_Implicit_Conditionals
678 elsif Restrictions (No_Implicit_Conditionals) then
680 T : Entity_Id := Make_Defining_Identifier (Loc,
685 Make_Block_Statement (Loc,
686 Declarations => New_List (
687 Make_Object_Declaration (Loc,
688 Defining_Identifier => T,
689 Constant_Present => True,
691 New_Occurrence_Of (Etype (Rhs), Loc),
692 Expression => Relocate_Node (Rhs))),
694 Handled_Statement_Sequence =>
695 Make_Handled_Sequence_Of_Statements (Loc,
696 Statements => New_List (
697 Make_Assignment_Statement (Loc,
698 Name => Relocate_Node (Lhs),
699 Expression => New_Occurrence_Of (T, Loc))))));
702 -- Case of both are false with implicit conditionals allowed
705 -- Before we generate this code, we must ensure that the
706 -- left and right side array types are defined. They may
707 -- be itypes, and we cannot let them be defined inside the
708 -- if, since the first use in the then may not be executed.
710 Ensure_Defined (L_Type, N);
711 Ensure_Defined (R_Type, N);
713 -- We normally compare addresses to find out which way round
714 -- to do the loop, since this is realiable, and handles the
715 -- cases of parameters, conversions etc. But we can't do that
716 -- in the bit packed case or the Java VM case, because addresses
719 if not Is_Bit_Packed_Array (L_Type) and then not Java_VM then
723 Unchecked_Convert_To (RTE (RE_Integer_Address),
724 Make_Attribute_Reference (Loc,
726 Make_Indexed_Component (Loc,
728 Duplicate_Subexpr (Larray, True),
729 Expressions => New_List (
730 Make_Attribute_Reference (Loc,
734 Attribute_Name => Name_First))),
735 Attribute_Name => Name_Address)),
738 Unchecked_Convert_To (RTE (RE_Integer_Address),
739 Make_Attribute_Reference (Loc,
741 Make_Indexed_Component (Loc,
743 Duplicate_Subexpr (Rarray, True),
744 Expressions => New_List (
745 Make_Attribute_Reference (Loc,
749 Attribute_Name => Name_First))),
750 Attribute_Name => Name_Address)));
752 -- For the bit packed and Java VM cases we use the bounds.
753 -- That's OK, because we don't have to worry about parameters,
754 -- since they cannot cause overlap. Perhaps we should worry
755 -- about weird slice conversions ???
758 -- Copy the bounds and reset the Analyzed flag, because the
759 -- bounds of the index type itself may be universal, and must
760 -- must be reaanalyzed to acquire the proper type for Gigi.
762 Cleft_Lo := New_Copy_Tree (Left_Lo);
763 Cright_Lo := New_Copy_Tree (Right_Lo);
764 Set_Analyzed (Cleft_Lo, False);
765 Set_Analyzed (Cright_Lo, False);
769 Left_Opnd => Cleft_Lo,
770 Right_Opnd => Cright_Lo);
774 Make_Implicit_If_Statement (N,
775 Condition => Condition,
777 Then_Statements => New_List (
778 Expand_Assign_Array_Loop
779 (N, Larray, Rarray, L_Type, R_Type, Ndim,
782 Else_Statements => New_List (
783 Expand_Assign_Array_Loop
784 (N, Larray, Rarray, L_Type, R_Type, Ndim,
788 Analyze (N, Suppress => All_Checks);
790 end Expand_Assign_Array;
792 ------------------------------
793 -- Expand_Assign_Array_Loop --
794 ------------------------------
796 -- The following is an example of the loop generated for the case of
797 -- a two-dimensional array:
802 -- for L1b in 1 .. 100 loop
806 -- for L3b in 1 .. 100 loop
807 -- vm1 (L1b, L3b) := vm2 (R2b, R4b);
808 -- R4b := Tm1X2'succ(R4b);
811 -- R2b := Tm1X1'succ(R2b);
815 -- Here Rev is False, and Tm1Xn are the subscript types for the right
816 -- hand side. The declarations of R2b and R4b are inserted before the
817 -- original assignment statement.
819 function Expand_Assign_Array_Loop
829 Loc : constant Source_Ptr := Sloc (N);
831 Lnn : array (1 .. Ndim) of Entity_Id;
832 Rnn : array (1 .. Ndim) of Entity_Id;
833 -- Entities used as subscripts on left and right sides
835 L_Index_Type : array (1 .. Ndim) of Entity_Id;
836 R_Index_Type : array (1 .. Ndim) of Entity_Id;
837 -- Left and right index types
849 F_Or_L := Name_First;
853 -- Setup index types and subscript entities
860 L_Index := First_Index (L_Type);
861 R_Index := First_Index (R_Type);
863 for J in 1 .. Ndim loop
865 Make_Defining_Identifier (Loc,
866 Chars => New_Internal_Name ('L'));
869 Make_Defining_Identifier (Loc,
870 Chars => New_Internal_Name ('R'));
872 L_Index_Type (J) := Etype (L_Index);
873 R_Index_Type (J) := Etype (R_Index);
875 Next_Index (L_Index);
876 Next_Index (R_Index);
880 -- Now construct the assignment statement
883 ExprL : List_Id := New_List;
884 ExprR : List_Id := New_List;
887 for J in 1 .. Ndim loop
888 Append_To (ExprL, New_Occurrence_Of (Lnn (J), Loc));
889 Append_To (ExprR, New_Occurrence_Of (Rnn (J), Loc));
893 Make_Assignment_Statement (Loc,
895 Make_Indexed_Component (Loc,
896 Prefix => Duplicate_Subexpr (Larray, Name_Req => True),
897 Expressions => ExprL),
899 Make_Indexed_Component (Loc,
900 Prefix => Duplicate_Subexpr (Rarray, Name_Req => True),
901 Expressions => ExprR));
903 -- Propagate the No_Ctrl_Actions flag to individual assignments
905 Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N));
908 -- Now construct the loop from the inside out, with the last subscript
909 -- varying most rapidly. Note that Assign is first the raw assignment
910 -- statement, and then subsequently the loop that wraps it up.
912 for J in reverse 1 .. Ndim loop
914 Make_Block_Statement (Loc,
915 Declarations => New_List (
916 Make_Object_Declaration (Loc,
917 Defining_Identifier => Rnn (J),
919 New_Occurrence_Of (R_Index_Type (J), Loc),
921 Make_Attribute_Reference (Loc,
922 Prefix => New_Occurrence_Of (R_Index_Type (J), Loc),
923 Attribute_Name => F_Or_L))),
925 Handled_Statement_Sequence =>
926 Make_Handled_Sequence_Of_Statements (Loc,
927 Statements => New_List (
928 Make_Implicit_Loop_Statement (N,
930 Make_Iteration_Scheme (Loc,
931 Loop_Parameter_Specification =>
932 Make_Loop_Parameter_Specification (Loc,
933 Defining_Identifier => Lnn (J),
934 Reverse_Present => Rev,
935 Discrete_Subtype_Definition =>
936 New_Reference_To (L_Index_Type (J), Loc))),
938 Statements => New_List (
941 Make_Assignment_Statement (Loc,
942 Name => New_Occurrence_Of (Rnn (J), Loc),
944 Make_Attribute_Reference (Loc,
946 New_Occurrence_Of (R_Index_Type (J), Loc),
947 Attribute_Name => S_Or_P,
948 Expressions => New_List (
949 New_Occurrence_Of (Rnn (J), Loc)))))))));
953 end Expand_Assign_Array_Loop;
955 --------------------------
956 -- Expand_Assign_Record --
957 --------------------------
959 -- The only processing required is in the change of representation
960 -- case, where we must expand the assignment to a series of field
961 -- by field assignments.
963 procedure Expand_Assign_Record (N : Node_Id) is
965 if not Change_Of_Representation (N) then
969 -- At this stage we know that the right hand side is a conversion
972 Loc : constant Source_Ptr := Sloc (N);
973 Lhs : constant Node_Id := Name (N);
974 Rhs : constant Node_Id := Expression (Expression (N));
975 R_Rec : constant Node_Id := Expression (Expression (N));
976 R_Typ : constant Entity_Id := Base_Type (Etype (R_Rec));
977 L_Typ : constant Entity_Id := Etype (Lhs);
978 Decl : constant Node_Id := Declaration_Node (R_Typ);
982 function Find_Component
986 -- Find the component with the given name in the underlying record
987 -- declaration for Typ. We need to use the actual entity because
988 -- the type may be private and resolution by identifier alone would
991 function Make_Component_List_Assign (CL : Node_Id) return List_Id;
992 -- Returns a sequence of statements to assign the components that
993 -- are referenced in the given component list.
995 function Make_Field_Assign (C : Entity_Id) return Node_Id;
996 -- Given C, the entity for a discriminant or component, build
997 -- an assignment for the corresponding field values.
999 function Make_Field_Assigns (CI : List_Id) return List_Id;
1000 -- Given CI, a component items list, construct series of statements
1001 -- for fieldwise assignment of the corresponding components.
1003 --------------------
1004 -- Find_Component --
1005 --------------------
1007 function Find_Component
1013 Utyp : constant Entity_Id := Underlying_Type (Typ);
1017 C := First_Entity (Utyp);
1019 while Present (C) loop
1020 if Chars (C) = Chars (Comp) then
1026 raise Program_Error;
1029 --------------------------------
1030 -- Make_Component_List_Assign --
1031 --------------------------------
1033 function Make_Component_List_Assign (CL : Node_Id) return List_Id is
1034 CI : constant List_Id := Component_Items (CL);
1035 VP : constant Node_Id := Variant_Part (CL);
1044 Result := Make_Field_Assigns (CI);
1046 if Present (VP) then
1048 V := First_Non_Pragma (Variants (VP));
1050 while Present (V) loop
1053 DC := First (Discrete_Choices (V));
1054 while Present (DC) loop
1055 Append_To (DCH, New_Copy_Tree (DC));
1060 Make_Case_Statement_Alternative (Loc,
1061 Discrete_Choices => DCH,
1063 Make_Component_List_Assign (Component_List (V))));
1064 Next_Non_Pragma (V);
1068 Make_Case_Statement (Loc,
1070 Make_Selected_Component (Loc,
1071 Prefix => Duplicate_Subexpr (Rhs),
1073 Make_Identifier (Loc, Chars (Name (VP)))),
1074 Alternatives => Alts));
1079 end Make_Component_List_Assign;
1081 -----------------------
1082 -- Make_Field_Assign --
1083 -----------------------
1085 function Make_Field_Assign (C : Entity_Id) return Node_Id is
1090 Make_Assignment_Statement (Loc,
1092 Make_Selected_Component (Loc,
1093 Prefix => Duplicate_Subexpr (Lhs),
1095 New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
1097 Make_Selected_Component (Loc,
1098 Prefix => Duplicate_Subexpr (Rhs),
1099 Selector_Name => New_Occurrence_Of (C, Loc)));
1101 -- Set Assignment_OK, so discriminants can be assigned
1103 Set_Assignment_OK (Name (A), True);
1105 end Make_Field_Assign;
1107 ------------------------
1108 -- Make_Field_Assigns --
1109 ------------------------
1111 function Make_Field_Assigns (CI : List_Id) return List_Id is
1119 while Present (Item) loop
1120 if Nkind (Item) = N_Component_Declaration then
1122 (Result, Make_Field_Assign (Defining_Identifier (Item)));
1129 end Make_Field_Assigns;
1131 -- Start of processing for Expand_Assign_Record
1134 -- Note that we use the base type for this processing. This results
1135 -- in some extra work in the constrained case, but the change of
1136 -- representation case is so unusual that it is not worth the effort.
1138 -- First copy the discriminants. This is done unconditionally. It
1139 -- is required in the unconstrained left side case, and also in the
1140 -- case where this assignment was constructed during the expansion
1141 -- of a type conversion (since initialization of discriminants is
1142 -- suppressed in this case). It is unnecessary but harmless in
1145 if Has_Discriminants (L_Typ) then
1146 F := First_Discriminant (R_Typ);
1147 while Present (F) loop
1148 Insert_Action (N, Make_Field_Assign (F));
1149 Next_Discriminant (F);
1153 -- We know the underlying type is a record, but its current view
1154 -- may be private. We must retrieve the usable record declaration.
1156 if Nkind (Decl) = N_Private_Type_Declaration
1157 and then Present (Full_View (R_Typ))
1159 RDef := Type_Definition (Declaration_Node (Full_View (R_Typ)));
1161 RDef := Type_Definition (Decl);
1164 if Nkind (RDef) = N_Record_Definition
1165 and then Present (Component_List (RDef))
1168 (N, Make_Component_List_Assign (Component_List (RDef)));
1170 Rewrite (N, Make_Null_Statement (Loc));
1174 end Expand_Assign_Record;
1176 -----------------------------------
1177 -- Expand_N_Assignment_Statement --
1178 -----------------------------------
1180 -- For array types, deal with slice assignments and setting the flags
1181 -- to indicate if it can be statically determined which direction the
1182 -- move should go in. Also deal with generating length checks.
1184 procedure Expand_N_Assignment_Statement (N : Node_Id) is
1185 Loc : constant Source_Ptr := Sloc (N);
1186 Lhs : constant Node_Id := Name (N);
1187 Rhs : constant Node_Id := Expression (N);
1188 Typ : constant Entity_Id := Underlying_Type (Etype (Lhs));
1192 -- Check for a special case where a high level transformation is
1193 -- required. If we have either of:
1198 -- where P is a reference to a bit packed array, then we have to unwind
1199 -- the assignment. The exact meaning of being a reference to a bit
1200 -- packed array is as follows:
1202 -- An indexed component whose prefix is a bit packed array is a
1203 -- reference to a bit packed array.
1205 -- An indexed component or selected component whose prefix is a
1206 -- reference to a bit packed array is itself a reference ot a
1207 -- bit packed array.
1209 -- The required transformation is
1211 -- Tnn : prefix_type := P;
1212 -- Tnn.field := rhs;
1217 -- Tnn : prefix_type := P;
1218 -- Tnn (subscr) := rhs;
1221 -- Since P is going to be evaluated more than once, any subscripts
1222 -- in P must have their evaluation forced.
1224 if (Nkind (Lhs) = N_Indexed_Component
1226 Nkind (Lhs) = N_Selected_Component)
1227 and then Is_Ref_To_Bit_Packed_Array (Prefix (Lhs))
1230 BPAR_Expr : constant Node_Id := Relocate_Node (Prefix (Lhs));
1231 BPAR_Typ : constant Entity_Id := Etype (BPAR_Expr);
1232 Tnn : constant Entity_Id :=
1233 Make_Defining_Identifier (Loc,
1234 Chars => New_Internal_Name ('T'));
1237 -- Insert the post assignment first, because we want to copy
1238 -- the BPAR_Expr tree before it gets analyzed in the context
1239 -- of the pre assignment. Note that we do not analyze the
1240 -- post assignment yet (we cannot till we have completed the
1241 -- analysis of the pre assignment). As usual, the analysis
1242 -- of this post assignment will happen on its own when we
1243 -- "run into" it after finishing the current assignment.
1246 Make_Assignment_Statement (Loc,
1247 Name => New_Copy_Tree (BPAR_Expr),
1248 Expression => New_Occurrence_Of (Tnn, Loc)));
1250 -- At this stage BPAR_Expr is a reference to a bit packed
1251 -- array where the reference was not expanded in the original
1252 -- tree, since it was on the left side of an assignment. But
1253 -- in the pre-assignment statement (the object definition),
1254 -- BPAR_Expr will end up on the right hand side, and must be
1255 -- reexpanded. To achieve this, we reset the analyzed flag
1256 -- of all selected and indexed components down to the actual
1257 -- indexed component for the packed array.
1261 Set_Analyzed (Exp, False);
1263 if Nkind (Exp) = N_Selected_Component
1265 Nkind (Exp) = N_Indexed_Component
1267 Exp := Prefix (Exp);
1273 -- Now we can insert and analyze the pre-assignment.
1275 -- If the right-hand side requires a transient scope, it has
1276 -- already been placed on the stack. However, the declaration is
1277 -- inserted in the tree outside of this scope, and must reflect
1278 -- the proper scope for its variable. This awkward bit is forced
1279 -- by the stricter scope discipline imposed by GCC 2.97.
1282 Uses_Transient_Scope : constant Boolean :=
1283 Scope_Is_Transient and then N = Node_To_Be_Wrapped;
1286 if Uses_Transient_Scope then
1287 New_Scope (Scope (Current_Scope));
1290 Insert_Before_And_Analyze (N,
1291 Make_Object_Declaration (Loc,
1292 Defining_Identifier => Tnn,
1293 Object_Definition => New_Occurrence_Of (BPAR_Typ, Loc),
1294 Expression => BPAR_Expr));
1296 if Uses_Transient_Scope then
1301 -- Now fix up the original assignment and continue processing
1303 Rewrite (Prefix (Lhs),
1304 New_Occurrence_Of (Tnn, Loc));
1308 -- When we have the appropriate type of aggregate in the
1309 -- expression (it has been determined during analysis of the
1310 -- aggregate by setting the delay flag), let's perform in place
1311 -- assignment and thus avoid creating a temporay.
1313 if Is_Delayed_Aggregate (Rhs) then
1314 Convert_Aggr_In_Assignment (N);
1315 Rewrite (N, Make_Null_Statement (Loc));
1320 -- Apply discriminant check if required. If Lhs is an access type
1321 -- to a designated type with discriminants, we must always check.
1323 if Has_Discriminants (Etype (Lhs)) then
1325 -- Skip discriminant check if change of representation. Will be
1326 -- done when the change of representation is expanded out.
1328 if not Change_Of_Representation (N) then
1329 Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs);
1332 -- If the type is private without discriminants, and the full type
1333 -- has discriminants (necessarily with defaults) a check may still be
1334 -- necessary if the Lhs is aliased. The private determinants must be
1335 -- visible to build the discriminant constraints.
1337 elsif Is_Private_Type (Etype (Lhs))
1338 and then Has_Discriminants (Typ)
1339 and then Nkind (Lhs) = N_Explicit_Dereference
1342 Lt : constant Entity_Id := Etype (Lhs);
1344 Set_Etype (Lhs, Typ);
1345 Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
1346 Apply_Discriminant_Check (Rhs, Typ, Lhs);
1347 Set_Etype (Lhs, Lt);
1350 -- If the Lhs has a private type with unknown discriminants, it
1351 -- may have a full view with discriminants, but those are nameable
1352 -- only in the underlying type, so convert the Rhs to it before
1353 -- potential checking.
1355 elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs)))
1356 and then Has_Discriminants (Typ)
1358 Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
1359 Apply_Discriminant_Check (Rhs, Typ, Lhs);
1361 -- In the access type case, we need the same discriminant check,
1362 -- and also range checks if we have an access to constrained array.
1364 elsif Is_Access_Type (Etype (Lhs))
1365 and then Is_Constrained (Designated_Type (Etype (Lhs)))
1367 if Has_Discriminants (Designated_Type (Etype (Lhs))) then
1369 -- Skip discriminant check if change of representation. Will be
1370 -- done when the change of representation is expanded out.
1372 if not Change_Of_Representation (N) then
1373 Apply_Discriminant_Check (Rhs, Etype (Lhs));
1376 elsif Is_Array_Type (Designated_Type (Etype (Lhs))) then
1377 Apply_Range_Check (Rhs, Etype (Lhs));
1379 if Is_Constrained (Etype (Lhs)) then
1380 Apply_Length_Check (Rhs, Etype (Lhs));
1383 if Nkind (Rhs) = N_Allocator then
1385 Target_Typ : constant Entity_Id := Etype (Expression (Rhs));
1386 C_Es : Check_Result;
1393 Etype (Designated_Type (Etype (Lhs))));
1405 -- Apply range check for access type case
1407 elsif Is_Access_Type (Etype (Lhs))
1408 and then Nkind (Rhs) = N_Allocator
1409 and then Nkind (Expression (Rhs)) = N_Qualified_Expression
1411 Analyze_And_Resolve (Expression (Rhs));
1413 (Expression (Rhs), Designated_Type (Etype (Lhs)));
1416 -- Case of assignment to a bit packed array element
1418 if Nkind (Lhs) = N_Indexed_Component
1419 and then Is_Bit_Packed_Array (Etype (Prefix (Lhs)))
1421 Expand_Bit_Packed_Element_Set (N);
1424 -- Case of tagged type assignment
1426 elsif Is_Tagged_Type (Typ)
1427 or else (Controlled_Type (Typ) and then not Is_Array_Type (Typ))
1429 Tagged_Case : declare
1430 L : List_Id := No_List;
1431 Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N);
1434 -- In the controlled case, we need to make sure that function
1435 -- calls are evaluated before finalizing the target. In all
1436 -- cases, it makes the expansion easier if the side-effects
1437 -- are removed first.
1439 Remove_Side_Effects (Lhs);
1440 Remove_Side_Effects (Rhs);
1442 -- Avoid recursion in the mechanism
1446 -- If dispatching assignment, we need to dispatch to _assign
1448 if Is_Class_Wide_Type (Typ)
1450 -- If the type is tagged, we may as well use the predefined
1451 -- primitive assignment. This avoids inlining a lot of code
1452 -- and in the class-wide case, the assignment is replaced by
1453 -- a dispatch call to _assign. Note that this cannot be done
1454 -- when discriminant checks are locally suppressed (as in
1455 -- extension aggregate expansions) because otherwise the
1456 -- discriminant check will be performed within the _assign
1459 or else (Is_Tagged_Type (Typ)
1460 and then Chars (Current_Scope) /= Name_uAssign
1461 and then Expand_Ctrl_Actions
1462 and then not Discriminant_Checks_Suppressed (Empty))
1464 -- Fetch the primitive op _assign and proper type to call
1465 -- it. Because of possible conflits between private and
1466 -- full view the proper type is fetched directly from the
1467 -- operation profile.
1470 Op : constant Entity_Id
1471 := Find_Prim_Op (Typ, Name_uAssign);
1472 F_Typ : Entity_Id := Etype (First_Formal (Op));
1475 -- If the assignment is dispatching, make sure to use the
1476 -- ??? where is rest of this comment ???
1478 if Is_Class_Wide_Type (Typ) then
1479 F_Typ := Class_Wide_Type (F_Typ);
1483 Make_Procedure_Call_Statement (Loc,
1484 Name => New_Reference_To (Op, Loc),
1485 Parameter_Associations => New_List (
1486 Unchecked_Convert_To (F_Typ, Duplicate_Subexpr (Lhs)),
1487 Unchecked_Convert_To (F_Typ,
1488 Duplicate_Subexpr (Rhs)))));
1492 L := Make_Tag_Ctrl_Assignment (N);
1494 -- We can't afford to have destructive Finalization Actions
1495 -- in the Self assignment case, so if the target and the
1496 -- source are not obviously different, code is generated to
1497 -- avoid the self assignment case
1499 -- if lhs'address /= rhs'address then
1500 -- <code for controlled and/or tagged assignment>
1503 if not Statically_Different (Lhs, Rhs)
1504 and then Expand_Ctrl_Actions
1507 Make_Implicit_If_Statement (N,
1511 Make_Attribute_Reference (Loc,
1512 Prefix => Duplicate_Subexpr (Lhs),
1513 Attribute_Name => Name_Address),
1516 Make_Attribute_Reference (Loc,
1517 Prefix => Duplicate_Subexpr (Rhs),
1518 Attribute_Name => Name_Address)),
1520 Then_Statements => L));
1523 -- We need to set up an exception handler for implementing
1524 -- 7.6.1 (18). The remaining adjustments are tackled by the
1525 -- implementation of adjust for record_controllers (see
1528 -- This is skipped in No_Run_Time mode, where we in any
1529 -- case exclude the possibility of finalization going on!
1531 if Expand_Ctrl_Actions and then not No_Run_Time then
1533 Make_Block_Statement (Loc,
1534 Handled_Statement_Sequence =>
1535 Make_Handled_Sequence_Of_Statements (Loc,
1537 Exception_Handlers => New_List (
1538 Make_Exception_Handler (Loc,
1539 Exception_Choices =>
1540 New_List (Make_Others_Choice (Loc)),
1541 Statements => New_List (
1542 Make_Raise_Program_Error (Loc,
1544 PE_Finalize_Raised_Exception)
1550 Make_Block_Statement (Loc,
1551 Handled_Statement_Sequence =>
1552 Make_Handled_Sequence_Of_Statements (Loc, Statements => L)));
1554 -- If no restrictions on aborts, protect the whole assignement
1555 -- for controlled objects as per 9.8(11)
1557 if Controlled_Type (Typ)
1558 and then Expand_Ctrl_Actions
1559 and then Abort_Allowed
1562 Blk : constant Entity_Id :=
1563 New_Internal_Entity (
1564 E_Block, Current_Scope, Sloc (N), 'B');
1567 Set_Scope (Blk, Current_Scope);
1568 Set_Etype (Blk, Standard_Void_Type);
1569 Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
1571 Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
1572 Set_At_End_Proc (Handled_Statement_Sequence (N),
1573 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
1574 Expand_At_End_Handler
1575 (Handled_Statement_Sequence (N), Blk);
1585 elsif Is_Array_Type (Typ) then
1587 Actual_Rhs : Node_Id := Rhs;
1590 while Nkind (Actual_Rhs) = N_Type_Conversion
1592 Nkind (Actual_Rhs) = N_Qualified_Expression
1594 Actual_Rhs := Expression (Actual_Rhs);
1597 Expand_Assign_Array (N, Actual_Rhs);
1603 elsif Is_Record_Type (Typ) then
1604 Expand_Assign_Record (N);
1607 -- Scalar types. This is where we perform the processing related
1608 -- to the requirements of (RM 13.9.1(9-11)) concerning the handling
1609 -- of invalid scalar values.
1611 elsif Is_Scalar_Type (Typ) then
1613 -- Case where right side is known valid
1615 if Expr_Known_Valid (Rhs) then
1617 -- Here the right side is valid, so it is fine. The case to
1618 -- deal with is when the left side is a local variable reference
1619 -- whose value is not currently known to be valid. If this is
1620 -- the case, and the assignment appears in an unconditional
1621 -- context, then we can mark the left side as now being valid.
1623 if Is_Local_Variable_Reference (Lhs)
1624 and then not Is_Known_Valid (Entity (Lhs))
1625 and then In_Unconditional_Context (N)
1627 Set_Is_Known_Valid (Entity (Lhs), True);
1630 -- Case where right side may be invalid in the sense of the RM
1631 -- reference above. The RM does not require that we check for
1632 -- the validity on an assignment, but it does require that the
1633 -- assignment of an invalid value not cause erroneous behavior.
1635 -- The general approach in GNAT is to use the Is_Known_Valid flag
1636 -- to avoid the need for validity checking on assignments. However
1637 -- in some cases, we have to do validity checking in order to make
1638 -- sure that the setting of this flag is correct.
1641 -- Validate right side if we are validating copies
1643 if Validity_Checks_On
1644 and then Validity_Check_Copies
1648 -- We can propagate this to the left side where appropriate
1650 if Is_Local_Variable_Reference (Lhs)
1651 and then not Is_Known_Valid (Entity (Lhs))
1652 and then In_Unconditional_Context (N)
1654 Set_Is_Known_Valid (Entity (Lhs), True);
1657 -- Otherwise check to see what should be done
1659 -- If left side is a local variable, then we just set its
1660 -- flag to indicate that its value may no longer be valid,
1661 -- since we are copying a potentially invalid value.
1663 elsif Is_Local_Variable_Reference (Lhs) then
1664 Set_Is_Known_Valid (Entity (Lhs), False);
1666 -- Check for case of a non-local variable on the left side
1667 -- which is currently known to be valid. In this case, we
1668 -- simply ensure that the right side is valid. We only play
1669 -- the game of copying validity status for local variables,
1670 -- since we are doing this statically, not by tracing the
1673 elsif Is_Entity_Name (Lhs)
1674 and then Is_Known_Valid (Entity (Lhs))
1676 -- Note that the Ensure_Valid call is ignored if the
1677 -- Validity_Checking mode is set to none so we do not
1678 -- need to worry about that case here.
1682 -- In all other cases, we can safely copy an invalid value
1683 -- without worrying about the status of the left side. Since
1684 -- it is not a variable reference it will not be considered
1685 -- as being known to be valid in any case.
1693 -- Defend against invalid subscripts on left side if we are in
1694 -- standard validity checking mode. No need to do this if we
1695 -- are checking all subscripts.
1697 if Validity_Checks_On
1698 and then Validity_Check_Default
1699 and then not Validity_Check_Subscripts
1701 Check_Valid_Lvalue_Subscripts (Lhs);
1703 end Expand_N_Assignment_Statement;
1705 ------------------------------
1706 -- Expand_N_Block_Statement --
1707 ------------------------------
1709 -- Encode entity names defined in block statement
1711 procedure Expand_N_Block_Statement (N : Node_Id) is
1713 Qualify_Entity_Names (N);
1714 end Expand_N_Block_Statement;
1716 -----------------------------
1717 -- Expand_N_Case_Statement --
1718 -----------------------------
1720 procedure Expand_N_Case_Statement (N : Node_Id) is
1721 Loc : constant Source_Ptr := Sloc (N);
1722 Expr : constant Node_Id := Expression (N);
1725 -- Check for the situation where we know at compile time which
1726 -- branch will be taken
1728 if Compile_Time_Known_Value (Expr) then
1730 Val : constant Uint := Expr_Value (Expr);
1735 Alt := First (Alternatives (N));
1737 Choice := First (Discrete_Choices (Alt));
1738 while Present (Choice) loop
1740 -- Others choice, always matches
1742 if Nkind (Choice) = N_Others_Choice then
1745 -- Range, check if value is in the range
1747 elsif Nkind (Choice) = N_Range then
1749 Val >= Expr_Value (Low_Bound (Choice))
1751 Val <= Expr_Value (High_Bound (Choice));
1753 -- Choice is a subtype name. Note that we know it must
1754 -- be a static subtype, since otherwise it would have
1755 -- been diagnosed as illegal.
1757 elsif Is_Entity_Name (Choice)
1758 and then Is_Type (Entity (Choice))
1760 exit when Is_In_Range (Expr, Etype (Choice));
1762 -- Choice is a subtype indication
1764 elsif Nkind (Choice) = N_Subtype_Indication then
1766 C : constant Node_Id := Constraint (Choice);
1767 R : constant Node_Id := Range_Expression (C);
1771 Val >= Expr_Value (Low_Bound (R))
1773 Val <= Expr_Value (High_Bound (R));
1776 -- Choice is a simple expression
1779 exit Search when Val = Expr_Value (Choice);
1786 pragma Assert (Present (Alt));
1789 -- The above loop *must* terminate by finding a match, since
1790 -- we know the case statement is valid, and the value of the
1791 -- expression is known at compile time. When we fall out of
1792 -- the loop, Alt points to the alternative that we know will
1793 -- be selected at run time.
1795 -- Move the statements from this alternative after the case
1796 -- statement. They are already analyzed, so will be skipped
1799 Insert_List_After (N, Statements (Alt));
1801 -- That leaves the case statement as a shell. The alternative
1802 -- that wlil be executed is reset to a null list. So now we can
1803 -- kill the entire case statement.
1805 Kill_Dead_Code (Expression (N));
1806 Kill_Dead_Code (Alternatives (N));
1807 Rewrite (N, Make_Null_Statement (Loc));
1810 -- Here if the choice is not determined at compile time
1812 -- If the last alternative is not an Others choice, replace it with an
1813 -- N_Others_Choice. Note that we do not bother to call Analyze on the
1814 -- modified case statement, since it's only effect would be to compute
1815 -- the contents of the Others_Discrete_Choices node laboriously, and of
1816 -- course we already know the list of choices that corresponds to the
1817 -- others choice (it's the list we are replacing!)
1821 Altnode : constant Node_Id := Last (Alternatives (N));
1822 Others_Node : Node_Id;
1825 if Nkind (First (Discrete_Choices (Altnode)))
1828 Others_Node := Make_Others_Choice (Sloc (Altnode));
1829 Set_Others_Discrete_Choices
1830 (Others_Node, Discrete_Choices (Altnode));
1831 Set_Discrete_Choices (Altnode, New_List (Others_Node));
1834 -- If checks are on, ensure argument is valid (RM 5.4(13)). This
1835 -- is only done for case statements frpm in the source program.
1836 -- We don't just call Ensure_Valid here, because the requirement
1837 -- is more strenous than usual, in that it is required that
1838 -- Constraint_Error be raised.
1840 if Comes_From_Source (N)
1841 and then Validity_Checks_On
1842 and then Validity_Check_Default
1843 and then not Expr_Known_Valid (Expr)
1845 Insert_Valid_Check (Expr);
1849 end Expand_N_Case_Statement;
1851 -----------------------------
1852 -- Expand_N_Exit_Statement --
1853 -----------------------------
1855 -- The only processing required is to deal with a possible C/Fortran
1856 -- boolean value used as the condition for the exit statement.
1858 procedure Expand_N_Exit_Statement (N : Node_Id) is
1860 Adjust_Condition (Condition (N));
1861 end Expand_N_Exit_Statement;
1863 -----------------------------
1864 -- Expand_N_Goto_Statement --
1865 -----------------------------
1867 -- Add poll before goto if polling active
1869 procedure Expand_N_Goto_Statement (N : Node_Id) is
1871 Generate_Poll_Call (N);
1872 end Expand_N_Goto_Statement;
1874 ---------------------------
1875 -- Expand_N_If_Statement --
1876 ---------------------------
1878 -- First we deal with the case of C and Fortran convention boolean
1879 -- values, with zero/non-zero semantics.
1881 -- Second, we deal with the obvious rewriting for the cases where the
1882 -- condition of the IF is known at compile time to be True or False.
1884 -- Third, we remove elsif parts which have non-empty Condition_Actions
1885 -- and rewrite as independent if statements. For example:
1896 -- <<condition actions of y>>
1902 -- This rewriting is needed if at least one elsif part has a non-empty
1903 -- Condition_Actions list. We also do the same processing if there is
1904 -- a constant condition in an elsif part (in conjunction with the first
1905 -- processing step mentioned above, for the recursive call made to deal
1906 -- with the created inner if, this deals with properly optimizing the
1907 -- cases of constant elsif conditions).
1909 procedure Expand_N_If_Statement (N : Node_Id) is
1915 Adjust_Condition (Condition (N));
1917 -- The following loop deals with constant conditions for the IF. We
1918 -- need a loop because as we eliminate False conditions, we grab the
1919 -- first elsif condition and use it as the primary condition.
1921 while Compile_Time_Known_Value (Condition (N)) loop
1923 -- If condition is True, we can simply rewrite the if statement
1924 -- now by replacing it by the series of then statements.
1926 if Is_True (Expr_Value (Condition (N))) then
1928 -- All the else parts can be killed
1930 Kill_Dead_Code (Elsif_Parts (N));
1931 Kill_Dead_Code (Else_Statements (N));
1933 Hed := Remove_Head (Then_Statements (N));
1934 Insert_List_After (N, Then_Statements (N));
1938 -- If condition is False, then we can delete the condition and
1939 -- the Then statements
1942 -- We do not delete the condition if constant condition
1943 -- warnings are enabled, since otherwise we end up deleting
1944 -- the desired warning. Of course the backend will get rid
1945 -- of this True/False test anyway, so nothing is lost here.
1947 if not Constant_Condition_Warnings then
1948 Kill_Dead_Code (Condition (N));
1951 Kill_Dead_Code (Then_Statements (N));
1953 -- If there are no elsif statements, then we simply replace
1954 -- the entire if statement by the sequence of else statements.
1956 if No (Elsif_Parts (N)) then
1958 if No (Else_Statements (N))
1959 or else Is_Empty_List (Else_Statements (N))
1962 Make_Null_Statement (Sloc (N)));
1965 Hed := Remove_Head (Else_Statements (N));
1966 Insert_List_After (N, Else_Statements (N));
1972 -- If there are elsif statements, the first of them becomes
1973 -- the if/then section of the rebuilt if statement This is
1974 -- the case where we loop to reprocess this copied condition.
1977 Hed := Remove_Head (Elsif_Parts (N));
1978 Insert_Actions (N, Condition_Actions (Hed));
1979 Set_Condition (N, Condition (Hed));
1980 Set_Then_Statements (N, Then_Statements (Hed));
1982 if Is_Empty_List (Elsif_Parts (N)) then
1983 Set_Elsif_Parts (N, No_List);
1989 -- Loop through elsif parts, dealing with constant conditions and
1990 -- possible expression actions that are present.
1992 if Present (Elsif_Parts (N)) then
1993 E := First (Elsif_Parts (N));
1994 while Present (E) loop
1995 Adjust_Condition (Condition (E));
1997 -- If there are condition actions, then we rewrite the if
1998 -- statement as indicated above. We also do the same rewrite
1999 -- if the condition is True or False. The further processing
2000 -- of this constant condition is then done by the recursive
2001 -- call to expand the newly created if statement
2003 if Present (Condition_Actions (E))
2004 or else Compile_Time_Known_Value (Condition (E))
2006 -- Note this is not an implicit if statement, since it is
2007 -- part of an explicit if statement in the source (or of an
2008 -- implicit if statement that has already been tested).
2011 Make_If_Statement (Sloc (E),
2012 Condition => Condition (E),
2013 Then_Statements => Then_Statements (E),
2014 Elsif_Parts => No_List,
2015 Else_Statements => Else_Statements (N));
2017 -- Elsif parts for new if come from remaining elsif's of parent
2019 while Present (Next (E)) loop
2020 if No (Elsif_Parts (New_If)) then
2021 Set_Elsif_Parts (New_If, New_List);
2024 Append (Remove_Next (E), Elsif_Parts (New_If));
2027 Set_Else_Statements (N, New_List (New_If));
2029 if Present (Condition_Actions (E)) then
2030 Insert_List_Before (New_If, Condition_Actions (E));
2035 if Is_Empty_List (Elsif_Parts (N)) then
2036 Set_Elsif_Parts (N, No_List);
2042 -- No special processing for that elsif part, move to next
2049 end Expand_N_If_Statement;
2051 -----------------------------
2052 -- Expand_N_Loop_Statement --
2053 -----------------------------
2055 -- 1. Deal with while condition for C/Fortran boolean
2056 -- 2. Deal with loops with a non-standard enumeration type range
2057 -- 3. Deal with while loops where Condition_Actions is set
2058 -- 4. Insert polling call if required
2060 procedure Expand_N_Loop_Statement (N : Node_Id) is
2061 Loc : constant Source_Ptr := Sloc (N);
2062 Isc : constant Node_Id := Iteration_Scheme (N);
2065 if Present (Isc) then
2066 Adjust_Condition (Condition (Isc));
2069 if Is_Non_Empty_List (Statements (N)) then
2070 Generate_Poll_Call (First (Statements (N)));
2077 -- Handle the case where we have a for loop with the range type being
2078 -- an enumeration type with non-standard representation. In this case
2081 -- for x in [reverse] a .. b loop
2087 -- for xP in [reverse] integer
2088 -- range etype'Pos (a) .. etype'Pos (b) loop
2090 -- x : constant etype := Pos_To_Rep (xP);
2096 if Present (Loop_Parameter_Specification (Isc)) then
2098 LPS : constant Node_Id := Loop_Parameter_Specification (Isc);
2099 Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
2100 Ltype : constant Entity_Id := Etype (Loop_Id);
2101 Btype : constant Entity_Id := Base_Type (Ltype);
2106 if not Is_Enumeration_Type (Btype)
2107 or else No (Enum_Pos_To_Rep (Btype))
2113 Make_Defining_Identifier (Loc,
2114 Chars => New_External_Name (Chars (Loop_Id), 'P'));
2116 Lo := Type_Low_Bound (Ltype);
2117 Hi := Type_High_Bound (Ltype);
2120 Make_Loop_Statement (Loc,
2121 Identifier => Identifier (N),
2124 Make_Iteration_Scheme (Loc,
2125 Loop_Parameter_Specification =>
2126 Make_Loop_Parameter_Specification (Loc,
2127 Defining_Identifier => New_Id,
2128 Reverse_Present => Reverse_Present (LPS),
2130 Discrete_Subtype_Definition =>
2131 Make_Subtype_Indication (Loc,
2134 New_Reference_To (Standard_Natural, Loc),
2137 Make_Range_Constraint (Loc,
2142 Make_Attribute_Reference (Loc,
2144 New_Reference_To (Btype, Loc),
2146 Attribute_Name => Name_Pos,
2148 Expressions => New_List (
2150 (Type_Low_Bound (Ltype)))),
2153 Make_Attribute_Reference (Loc,
2155 New_Reference_To (Btype, Loc),
2157 Attribute_Name => Name_Pos,
2159 Expressions => New_List (
2161 (Type_High_Bound (Ltype))))))))),
2163 Statements => New_List (
2164 Make_Block_Statement (Loc,
2165 Declarations => New_List (
2166 Make_Object_Declaration (Loc,
2167 Defining_Identifier => Loop_Id,
2168 Constant_Present => True,
2169 Object_Definition => New_Reference_To (Ltype, Loc),
2171 Make_Indexed_Component (Loc,
2173 New_Reference_To (Enum_Pos_To_Rep (Btype), Loc),
2174 Expressions => New_List (
2175 New_Reference_To (New_Id, Loc))))),
2177 Handled_Statement_Sequence =>
2178 Make_Handled_Sequence_Of_Statements (Loc,
2179 Statements => Statements (N)))),
2181 End_Label => End_Label (N)));
2186 -- Second case, if we have a while loop with Condition_Actions set,
2187 -- then we change it into a plain loop:
2196 -- <<condition actions>>
2202 and then Present (Condition_Actions (Isc))
2209 Make_Exit_Statement (Sloc (Condition (Isc)),
2211 Make_Op_Not (Sloc (Condition (Isc)),
2212 Right_Opnd => Condition (Isc)));
2214 Prepend (ES, Statements (N));
2215 Insert_List_Before (ES, Condition_Actions (Isc));
2217 -- This is not an implicit loop, since it is generated in
2218 -- response to the loop statement being processed. If this
2219 -- is itself implicit, the restriction has already been
2220 -- checked. If not, it is an explicit loop.
2223 Make_Loop_Statement (Sloc (N),
2224 Identifier => Identifier (N),
2225 Statements => Statements (N),
2226 End_Label => End_Label (N)));
2231 end Expand_N_Loop_Statement;
2233 -------------------------------
2234 -- Expand_N_Return_Statement --
2235 -------------------------------
2237 procedure Expand_N_Return_Statement (N : Node_Id) is
2238 Loc : constant Source_Ptr := Sloc (N);
2239 Exp : constant Node_Id := Expression (N);
2243 Scope_Id : Entity_Id;
2247 Goto_Stat : Node_Id;
2250 Return_Type : Entity_Id;
2251 Result_Exp : Node_Id;
2252 Result_Id : Entity_Id;
2253 Result_Obj : Node_Id;
2256 -- Case where returned expression is present
2258 if Present (Exp) then
2260 -- Always normalize C/Fortran boolean result. This is not always
2261 -- necessary, but it seems a good idea to minimize the passing
2262 -- around of non-normalized values, and in any case this handles
2263 -- the processing of barrier functions for protected types, which
2264 -- turn the condition into a return statement.
2266 Exptyp := Etype (Exp);
2268 if Is_Boolean_Type (Exptyp)
2269 and then Nonzero_Is_True (Exptyp)
2271 Adjust_Condition (Exp);
2272 Adjust_Result_Type (Exp, Exptyp);
2275 -- Do validity check if enabled for returns
2277 if Validity_Checks_On
2278 and then Validity_Check_Returns
2284 -- Find relevant enclosing scope from which return is returning
2286 Cur_Idx := Scope_Stack.Last;
2288 Scope_Id := Scope_Stack.Table (Cur_Idx).Entity;
2290 if Ekind (Scope_Id) /= E_Block
2291 and then Ekind (Scope_Id) /= E_Loop
2296 Cur_Idx := Cur_Idx - 1;
2297 pragma Assert (Cur_Idx >= 0);
2302 Kind := Ekind (Scope_Id);
2304 -- If it is a return from procedures do no extra steps.
2306 if Kind = E_Procedure or else Kind = E_Generic_Procedure then
2310 pragma Assert (Is_Entry (Scope_Id));
2312 -- Look at the enclosing block to see whether the return is from
2313 -- an accept statement or an entry body.
2315 for J in reverse 0 .. Cur_Idx loop
2316 Scope_Id := Scope_Stack.Table (J).Entity;
2317 exit when Is_Concurrent_Type (Scope_Id);
2320 -- If it is a return from accept statement it should be expanded
2321 -- as a call to RTS Complete_Rendezvous and a goto to the end of
2324 -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept,
2325 -- Expand_N_Accept_Alternative in exp_ch9.adb)
2327 if Is_Task_Type (Scope_Id) then
2329 Call := (Make_Procedure_Call_Statement (Loc,
2330 Name => New_Reference_To
2331 (RTE (RE_Complete_Rendezvous), Loc)));
2332 Insert_Before (N, Call);
2333 -- why not insert actions here???
2336 Acc_Stat := Parent (N);
2337 while Nkind (Acc_Stat) /= N_Accept_Statement loop
2338 Acc_Stat := Parent (Acc_Stat);
2341 Lab_Node := Last (Statements
2342 (Handled_Statement_Sequence (Acc_Stat)));
2344 Goto_Stat := Make_Goto_Statement (Loc,
2345 Name => New_Occurrence_Of
2346 (Entity (Identifier (Lab_Node)), Loc));
2348 Set_Analyzed (Goto_Stat);
2350 Rewrite (N, Goto_Stat);
2353 -- If it is a return from an entry body, put a Complete_Entry_Body
2354 -- call in front of the return.
2356 elsif Is_Protected_Type (Scope_Id) then
2359 Make_Procedure_Call_Statement (Loc,
2360 Name => New_Reference_To
2361 (RTE (RE_Complete_Entry_Body), Loc),
2362 Parameter_Associations => New_List
2363 (Make_Attribute_Reference (Loc,
2367 (Corresponding_Body (Parent (Scope_Id))),
2369 Attribute_Name => Name_Unchecked_Access)));
2371 Insert_Before (N, Call);
2380 Return_Type := Etype (Scope_Id);
2381 Utyp := Underlying_Type (Return_Type);
2383 -- Check the result expression of a scalar function against
2384 -- the subtype of the function by inserting a conversion.
2385 -- This conversion must eventually be performed for other
2386 -- classes of types, but for now it's only done for scalars.
2389 if Is_Scalar_Type (T) then
2390 Rewrite (Exp, Convert_To (Return_Type, Exp));
2394 -- Implement the rules of 6.5(8-10), which require a tag check in
2395 -- the case of a limited tagged return type, and tag reassignment
2396 -- for nonlimited tagged results. These actions are needed when
2397 -- the return type is a specific tagged type and the result
2398 -- expression is a conversion or a formal parameter, because in
2399 -- that case the tag of the expression might differ from the tag
2400 -- of the specific result type.
2402 if Is_Tagged_Type (Utyp)
2403 and then not Is_Class_Wide_Type (Utyp)
2404 and then (Nkind (Exp) = N_Type_Conversion
2405 or else Nkind (Exp) = N_Unchecked_Type_Conversion
2406 or else (Is_Entity_Name (Exp)
2407 and then Ekind (Entity (Exp)) in Formal_Kind))
2409 -- When the return type is limited, perform a check that the
2410 -- tag of the result is the same as the tag of the return type.
2412 if Is_Limited_Type (Return_Type) then
2414 Make_Raise_Constraint_Error (Loc,
2418 Make_Selected_Component (Loc,
2419 Prefix => Duplicate_Subexpr (Exp),
2421 New_Reference_To (Tag_Component (Utyp), Loc)),
2423 Unchecked_Convert_To (RTE (RE_Tag),
2425 (Access_Disp_Table (Base_Type (Utyp)), Loc))),
2426 Reason => CE_Tag_Check_Failed));
2428 -- If the result type is a specific nonlimited tagged type,
2429 -- then we have to ensure that the tag of the result is that
2430 -- of the result type. This is handled by making a copy of the
2431 -- expression in the case where it might have a different tag,
2432 -- namely when the expression is a conversion or a formal
2433 -- parameter. We create a new object of the result type and
2434 -- initialize it from the expression, which will implicitly
2435 -- force the tag to be set appropriately.
2439 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2440 Result_Exp := New_Reference_To (Result_Id, Loc);
2443 Make_Object_Declaration (Loc,
2444 Defining_Identifier => Result_Id,
2445 Object_Definition => New_Reference_To (Return_Type, Loc),
2446 Constant_Present => True,
2447 Expression => Relocate_Node (Exp));
2449 Set_Assignment_OK (Result_Obj);
2450 Insert_Action (Exp, Result_Obj);
2452 Rewrite (Exp, Result_Exp);
2453 Analyze_And_Resolve (Exp, Return_Type);
2457 -- Deal with returning variable length objects and controlled types
2459 -- Nothing to do if we are returning by reference, or this is not
2460 -- a type that requires special processing (indicated by the fact
2461 -- that it requires a cleanup scope for the secondary stack case)
2463 if Is_Return_By_Reference_Type (T)
2464 or else not Requires_Transient_Scope (Return_Type)
2468 -- Case of secondary stack not used
2470 elsif Function_Returns_With_DSP (Scope_Id) then
2472 -- Here what we need to do is to always return by reference, since
2473 -- we will return with the stack pointer depressed. We may need to
2474 -- do a copy to a local temporary before doing this return.
2476 No_Secondary_Stack_Case : declare
2477 Local_Copy_Required : Boolean := False;
2478 -- Set to True if a local copy is required
2480 Copy_Ent : Entity_Id;
2481 -- Used for the target entity if a copy is required
2484 -- Declaration used to create copy if needed
2486 procedure Test_Copy_Required (Expr : Node_Id);
2487 -- Determines if Expr represents a return value for which a
2488 -- copy is required. More specifically, a copy is not required
2489 -- if Expr represents an object or component of an object that
2490 -- is either in the local subprogram frame, or is constant.
2491 -- If a copy is required, then Local_Copy_Required is set True.
2493 ------------------------
2494 -- Test_Copy_Required --
2495 ------------------------
2497 procedure Test_Copy_Required (Expr : Node_Id) is
2501 -- If component, test prefix (object containing component)
2503 if Nkind (Expr) = N_Indexed_Component
2505 Nkind (Expr) = N_Selected_Component
2507 Test_Copy_Required (Prefix (Expr));
2510 -- See if we have an entity name
2512 elsif Is_Entity_Name (Expr) then
2513 Ent := Entity (Expr);
2515 -- Constant entity is always OK, no copy required
2517 if Ekind (Ent) = E_Constant then
2520 -- No copy required for local variable
2522 elsif Ekind (Ent) = E_Variable
2523 and then Scope (Ent) = Current_Subprogram
2529 -- All other cases require a copy
2531 Local_Copy_Required := True;
2532 end Test_Copy_Required;
2534 -- Start of processing for No_Secondary_Stack_Case
2537 -- No copy needed if result is from a function call for the
2538 -- same type with the same constrainedness (is the latter a
2539 -- necessary check, or could gigi produce the bounds ???).
2540 -- In this case the result is already being returned by
2541 -- reference with the stack pointer depressed.
2543 if Requires_Transient_Scope (T)
2544 and then Is_Constrained (T) = Is_Constrained (Return_Type)
2545 and then (Nkind (Exp) = N_Function_Call
2547 Nkind (Original_Node (Exp)) = N_Function_Call)
2551 -- We always need a local copy for a controlled type, since
2552 -- we are required to finalize the local value before return.
2553 -- The copy will automatically include the required finalize.
2554 -- Moreover, gigi cannot make this copy, since we need special
2555 -- processing to ensure proper behavior for finalization.
2557 -- Note: the reason we are returning with a depressed stack
2558 -- pointer in the controlled case (even if the type involved
2559 -- is constrained) is that we must make a local copy to deal
2560 -- properly with the requirement that the local result be
2563 elsif Controlled_Type (Utyp) then
2565 Make_Defining_Identifier (Loc,
2566 Chars => New_Internal_Name ('R'));
2568 -- Build declaration to do the copy, and insert it, setting
2569 -- Assignment_OK, because we may be copying a limited type.
2570 -- In addition we set the special flag to inhibit finalize
2571 -- attachment if this is a controlled type (since this attach
2572 -- must be done by the caller, otherwise if we attach it here
2573 -- we will finalize the returned result prematurely).
2576 Make_Object_Declaration (Loc,
2577 Defining_Identifier => Copy_Ent,
2578 Object_Definition => New_Occurrence_Of (Return_Type, Loc),
2579 Expression => Relocate_Node (Exp));
2581 Set_Assignment_OK (Decl);
2582 Set_Delay_Finalize_Attach (Decl);
2583 Insert_Action (N, Decl);
2585 -- Now the actual return uses the copied value
2587 Rewrite (Exp, New_Occurrence_Of (Copy_Ent, Loc));
2588 Analyze_And_Resolve (Exp, Return_Type);
2590 -- Since we have made the copy, gigi does not have to, so
2591 -- we set the By_Ref flag to prevent another copy being made.
2595 -- Non-controlled cases
2598 Test_Copy_Required (Exp);
2600 -- If a local copy is required, then gigi will make the
2601 -- copy, otherwise, we can return the result directly,
2602 -- so set By_Ref to suppress the gigi copy.
2604 if not Local_Copy_Required then
2608 end No_Secondary_Stack_Case;
2610 -- Here if secondary stack is used
2613 -- Make sure that no surrounding block will reclaim the
2614 -- secondary-stack on which we are going to put the result.
2615 -- Not only may this introduce secondary stack leaks but worse,
2616 -- if the reclamation is done too early, then the result we are
2617 -- returning may get clobbered. See example in 7417-003.
2620 S : Entity_Id := Current_Scope;
2623 while Ekind (S) = E_Block or else Ekind (S) = E_Loop loop
2624 Set_Sec_Stack_Needed_For_Return (S, True);
2625 S := Enclosing_Dynamic_Scope (S);
2629 -- Optimize the case where the result is from a function call for
2630 -- the same type with the same constrainedness (is the latter a
2631 -- necessary check, or could gigi produce the bounds ???). In this
2632 -- case either the result is already on the secondary stack, or is
2633 -- already being returned with the stack pointer depressed and no
2634 -- further processing is required except to set the By_Ref flag to
2635 -- ensure that gigi does not attempt an extra unnecessary copy.
2636 -- (actually not just unnecessary but harmfully wrong in the case
2637 -- of a controlled type, where gigi does not know how to do a copy).
2639 if Requires_Transient_Scope (T)
2640 and then Is_Constrained (T) = Is_Constrained (Return_Type)
2641 and then (Nkind (Exp) = N_Function_Call
2642 or else Nkind (Original_Node (Exp)) = N_Function_Call)
2646 -- For controlled types, do the allocation on the sec-stack
2647 -- manually in order to call adjust at the right time
2648 -- type Anon1 is access Return_Type;
2649 -- for Anon1'Storage_pool use ss_pool;
2650 -- Anon2 : anon1 := new Return_Type'(expr);
2651 -- return Anon2.all;
2653 elsif Controlled_Type (Utyp) then
2655 Loc : constant Source_Ptr := Sloc (N);
2656 Temp : constant Entity_Id :=
2657 Make_Defining_Identifier (Loc,
2658 Chars => New_Internal_Name ('R'));
2659 Acc_Typ : constant Entity_Id :=
2660 Make_Defining_Identifier (Loc,
2661 Chars => New_Internal_Name ('A'));
2662 Alloc_Node : Node_Id;
2665 Set_Ekind (Acc_Typ, E_Access_Type);
2667 Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
2670 Make_Allocator (Loc,
2672 Make_Qualified_Expression (Loc,
2673 Subtype_Mark => New_Reference_To (Etype (Exp), Loc),
2674 Expression => Relocate_Node (Exp)));
2676 Insert_List_Before_And_Analyze (N, New_List (
2677 Make_Full_Type_Declaration (Loc,
2678 Defining_Identifier => Acc_Typ,
2680 Make_Access_To_Object_Definition (Loc,
2681 Subtype_Indication =>
2682 New_Reference_To (Return_Type, Loc))),
2684 Make_Object_Declaration (Loc,
2685 Defining_Identifier => Temp,
2686 Object_Definition => New_Reference_To (Acc_Typ, Loc),
2687 Expression => Alloc_Node)));
2690 Make_Explicit_Dereference (Loc,
2691 Prefix => New_Reference_To (Temp, Loc)));
2693 Analyze_And_Resolve (Exp, Return_Type);
2696 -- Otherwise use the gigi mechanism to allocate result on the
2700 Set_Storage_Pool (N, RTE (RE_SS_Pool));
2702 -- If we are generating code for the Java VM do not use
2703 -- SS_Allocate since everything is heap-allocated anyway.
2706 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
2710 end Expand_N_Return_Statement;
2712 ------------------------------
2713 -- Make_Tag_Ctrl_Assignment --
2714 ------------------------------
2716 function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is
2717 Loc : constant Source_Ptr := Sloc (N);
2718 L : constant Node_Id := Name (N);
2719 T : constant Entity_Id := Underlying_Type (Etype (L));
2721 Ctrl_Act : constant Boolean := Controlled_Type (T)
2722 and then not No_Ctrl_Actions (N);
2724 Save_Tag : constant Boolean := Is_Tagged_Type (T)
2725 and then not No_Ctrl_Actions (N)
2726 and then not Java_VM;
2727 -- Tags are not saved and restored when Java_VM because JVM tags
2728 -- are represented implicitly in objects.
2731 Tag_Tmp : Entity_Id;
2732 Prev_Tmp : Entity_Id;
2733 Next_Tmp : Entity_Id;
2739 -- Finalize the target of the assignment when controlled.
2740 -- We have two exceptions here:
2742 -- 1. If we are in an init_proc since it is an initialization
2743 -- more than an assignment
2745 -- 2. If the left-hand side is a temporary that was not initialized
2746 -- (or the parent part of a temporary since it is the case in
2747 -- extension aggregates). Such a temporary does not come from
2748 -- source. We must examine the original node for the prefix, because
2749 -- it may be a component of an entry formal, in which case it has
2750 -- been rewritten and does not appear to come from source either.
2754 if not Ctrl_Act then
2757 -- The left hand side is an uninitialized temporary
2759 elsif Nkind (L) = N_Type_Conversion
2760 and then Is_Entity_Name (Expression (L))
2761 and then No_Initialization (Parent (Entity (Expression (L))))
2765 Append_List_To (Res,
2767 Ref => Duplicate_Subexpr (L),
2769 With_Detach => New_Reference_To (Standard_False, Loc)));
2772 Next_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
2774 -- Save the Tag in a local variable Tag_Tmp
2778 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
2781 Make_Object_Declaration (Loc,
2782 Defining_Identifier => Tag_Tmp,
2783 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
2785 Make_Selected_Component (Loc,
2786 Prefix => Duplicate_Subexpr (L),
2787 Selector_Name => New_Reference_To (Tag_Component (T), Loc))));
2789 -- Otherwise Tag_Tmp not used
2795 -- Save the Finalization Pointers in local variables Prev_Tmp and
2796 -- Next_Tmp. For objects with Has_Controlled_Component set, these
2797 -- pointers are in the Record_Controller
2800 Ctrl_Ref := Duplicate_Subexpr (L);
2802 if Has_Controlled_Component (T) then
2804 Make_Selected_Component (Loc,
2807 New_Reference_To (Controller_Component (T), Loc));
2810 Prev_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
2813 Make_Object_Declaration (Loc,
2814 Defining_Identifier => Prev_Tmp,
2816 Object_Definition =>
2817 New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
2820 Make_Selected_Component (Loc,
2822 Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref),
2823 Selector_Name => Make_Identifier (Loc, Name_Prev))));
2825 Next_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
2828 Make_Object_Declaration (Loc,
2829 Defining_Identifier => Next_Tmp,
2831 Object_Definition =>
2832 New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
2835 Make_Selected_Component (Loc,
2837 Unchecked_Convert_To (RTE (RE_Finalizable),
2838 New_Copy_Tree (Ctrl_Ref)),
2839 Selector_Name => Make_Identifier (Loc, Name_Next))));
2841 -- If not controlled type, then Prev_Tmp and Ctrl_Ref unused
2848 -- Do the Assignment
2850 Append_To (Res, Relocate_Node (N));
2856 Make_Assignment_Statement (Loc,
2858 Make_Selected_Component (Loc,
2859 Prefix => Duplicate_Subexpr (L),
2860 Selector_Name => New_Reference_To (Tag_Component (T), Loc)),
2861 Expression => New_Reference_To (Tag_Tmp, Loc)));
2864 -- Restore the finalization pointers
2868 Make_Assignment_Statement (Loc,
2870 Make_Selected_Component (Loc,
2872 Unchecked_Convert_To (RTE (RE_Finalizable),
2873 New_Copy_Tree (Ctrl_Ref)),
2874 Selector_Name => Make_Identifier (Loc, Name_Prev)),
2875 Expression => New_Reference_To (Prev_Tmp, Loc)));
2878 Make_Assignment_Statement (Loc,
2880 Make_Selected_Component (Loc,
2882 Unchecked_Convert_To (RTE (RE_Finalizable),
2883 New_Copy_Tree (Ctrl_Ref)),
2884 Selector_Name => Make_Identifier (Loc, Name_Next)),
2885 Expression => New_Reference_To (Next_Tmp, Loc)));
2888 -- Adjust the target after the assignment when controlled. (not in
2889 -- the init_proc since it is an initialization more than an
2893 Append_List_To (Res,
2895 Ref => Duplicate_Subexpr (L),
2897 Flist_Ref => New_Reference_To (RTE (RE_Global_Final_List), Loc),
2898 With_Attach => Make_Integer_Literal (Loc, 0)));
2902 end Make_Tag_Ctrl_Assignment;