| blob | 67fc5e806406713679c6b0b8055bf42c66889be5 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 4 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2004, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
69 -----------------------
70 -- Local Subprograms --
71 -----------------------
75 -- Performs validity checks for a binary operator
77 procedure Build_Boolean_Array_Proc_Call
81 -- If an boolean array assignment can be done in place, build call to
82 -- corresponding library procedure.
85 -- Subsidiary to Expand_N_Allocator, for the case when the expression
86 -- is a qualified expression or an aggregate.
89 -- This routine handles expansion of the comparison operators (N_Op_Lt,
90 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
91 -- code for these operators is similar, differing only in the details of
92 -- the actual comparison call that is made. Special processing (call a
93 -- run-time routine)
95 function Expand_Array_Equality
101 -- Expand an array equality into a call to a function implementing this
102 -- equality, and a call to it. Loc is the location for the generated
103 -- nodes. Lhs and Rhs are the array expressions to be compared.
104 -- Bodies is a list on which to attach bodies of local functions that
105 -- are created in the process. It is the responsibility of the
106 -- caller to insert those bodies at the right place. Nod provides
107 -- the Sloc value for the generated code. Normally the types used
108 -- for the generated equality routine are taken from Lhs and Rhs.
109 -- However, in some situations of generated code, the Etype fields
110 -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the
111 -- type to be used for the formal parameters.
114 -- Common expansion processing for Boolean operators (And, Or, Xor)
115 -- for the case of array type arguments.
117 function Expand_Composite_Equality
123 -- Local recursive function used to expand equality for nested
124 -- composite types. Used by Expand_Record/Array_Equality, Bodies
125 -- is a list on which to attach bodies of local functions that are
126 -- created in the process. This is the responsability of the caller
127 -- to insert those bodies at the right place. Nod provides the Sloc
128 -- value for generated code. Lhs and Rhs are the left and right sides
129 -- for the comparison, and Typ is the type of the arrays to compare.
132 -- This routine handles expansion of concatenation operations, where
133 -- N is the N_Op_Concat node being expanded and Operands is the list
134 -- of operands (at least two are present). The caller has dealt with
135 -- converting any singleton operands into singleton aggregates.
138 -- Routine to expand concatenation of 2-5 operands (in the list Operands)
139 -- and replace node Cnode with the result of the contatenation. If there
140 -- are two operands, they can be string or character. If there are more
141 -- than two operands, then are always of type string (i.e. the caller has
142 -- already converted character operands to strings in this case).
145 -- N is either an N_Op_Divide or N_Op_Multiply node whose result is
146 -- universal fixed. We do not have such a type at runtime, so the
147 -- purpose of this routine is to find the real type by looking up
148 -- the tree. We also determine if the operation must be rounded.
150 function Get_Allocator_Final_List
154 -- If the designated type is controlled, build final_list expression
155 -- for created object. If context is an access parameter, create a
156 -- local access type to have a usable finalization list.
159 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
160 -- discriminants if it has a constrained nominal type, unless the object
161 -- is a component of an enclosing Unchecked_Union object that is subject
162 -- to a per-object constraint and the enclosing object lacks inferable
163 -- discriminants.
164 --
165 -- An expression of an Unchecked_Union type has inferable discriminants
166 -- if it is either a name of an object with inferable discriminants or a
167 -- qualified expression whose subtype mark denotes a constrained subtype.
170 -- N is an expression whose type is an access. When the type of the
171 -- associated storage pool is derived from Checked_Pool, generate a
172 -- call to the 'Dereference' primitive operation.
174 function Make_Array_Comparison_Op
177 -- Comparisons between arrays are expanded in line. This function
178 -- produces the body of the implementation of (a > b), where a and b
179 -- are one-dimensional arrays of some discrete type. The original
180 -- node is then expanded into the appropriate call to this function.
181 -- Nod provides the Sloc value for the generated code.
183 function Make_Boolean_Array_Op
186 -- Boolean operations on boolean arrays are expanded in line. This
187 -- function produce the body for the node N, which is (a and b),
188 -- (a or b), or (a xor b). It is used only the normal case and not
189 -- the packed case. The type involved, Typ, is the Boolean array type,
190 -- and the logical operations in the body are simple boolean operations.
191 -- Note that Typ is always a constrained type (the caller has ensured
192 -- this by using Convert_To_Actual_Subtype if necessary).
195 -- N is the node for a compile time comparison. If this outcome of this
196 -- comparison can be determined at compile time, then the node N can be
197 -- rewritten with True or False. If the outcome cannot be determined at
198 -- compile time, the call has no effect.
201 -- Construct the expression corresponding to the tagged membership test.
202 -- Deals with a second operand being (or not) a class-wide type.
204 function Safe_In_Place_Array_Op
208 -- In the context of an assignment, where the right-hand side is a
209 -- boolean operation on arrays, check whether operation can be performed
210 -- in place.
214 -- Performs validity checks for a unary operator
216 -------------------------------
217 -- Binary_Op_Validity_Checks --
218 -------------------------------
221 begin
228 ------------------------------------
229 -- Build_Boolean_Array_Proc_Call --
230 ------------------------------------
232 procedure Build_Boolean_Array_Proc_Call
236 is
249 begin
253 -- Use negated version of the binary operators
265 Call_Node :=
270 Target,
283 else
286 Call_Node :=
290 Target,
301 else
302 -- We use the following equivalences:
304 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
305 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
306 -- (not X) xor (not Y) = X xor Y
307 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
316 else
320 else
331 else
336 Call_Node :=
340 Target,
355 exception
360 ---------------------------------
361 -- Expand_Allocator_Expression --
362 ---------------------------------
379 begin
382 -- Actions inserted before:
383 -- Temp : constant ptr_T := new T'(Expression);
384 -- <no CW> Temp._tag := T'tag;
385 -- <CTRL> Adjust (Finalizable (Temp.all));
386 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
388 -- We analyze by hand the new internal allocator to avoid
389 -- any recursion and inappropriate call to Initialize
395 Temp :=
398 -- For a class wide allocation generate the following code:
400 -- type Equiv_Record is record ... end record;
401 -- implicit subtype CW is <Class_Wide_Subytpe>;
402 -- temp : PtrT := new CW'(CW!(expr));
414 Tmp_Node :=
418 Expression =>
422 Set_Comes_From_Source
430 then
431 -- Create local finalization list for access parameter
437 else
448 -- Suppress the tag assignment when Java_VM because JVM tags
449 -- are represented implicitly in objects.
453 and then not Java_VM
454 then
455 Tag_Assign :=
457 Name =>
460 Selector_Name =>
463 Expression =>
467 -- The previous assignment has to be done in any case
474 and then not Java_VM
475 then
476 declare
483 begin
484 Tag_Assign :=
486 Name =>
489 Selector_Name =>
492 Expression =>
494 New_Reference_To (
504 then
505 declare
510 begin
511 -- If it is an allocation on the secondary stack
512 -- (i.e. a value returned from a function), the object
513 -- is attached on the caller side as soon as the call
514 -- is completed (see Expand_Ctrl_Function_Call)
517 declare
521 begin
532 -- Normal case, not a secondary stack allocation
534 else
537 then
538 -- Create local finalization list for access parameter
540 Flist :=
542 else
551 Make_Adjust_Call (
552 Ref =>
554 -- An unchecked conversion is needed in the
555 -- classwide case because the designated type
556 -- can be an ancestor of the subtype mark of
557 -- the allocator.
574 Temp :=
576 Tmp_Node :=
583 Set_Comes_From_Source
595 then
596 -- Apply constraint to designated subtype indication
604 -- Propagate constraint_error to enclosing allocator
608 else
609 -- First check against the type of the qualified expression
610 --
611 -- NOTE: The commented call should be correct, but for
612 -- some reason causes the compiler to bomb (sigsegv) on
613 -- ACVC test c34007g, so for now we just perform the old
614 -- (incorrect) test against the designated subtype with
615 -- no sliding in the else part of the if statement below.
616 -- ???
617 --
618 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
620 -- A check is also needed in cases where the designated
621 -- subtype is constrained and differs from the subtype
622 -- given in the qualified expression. Note that the check
623 -- on the qualified expression does not allow sliding,
624 -- but this check does (a relaxation from Ada 83).
627 and then not Subtypes_Statically_Match
629 then
630 Apply_Constraint_Check
633 -- The nonsliding check should really be performed
634 -- (unconditionally) against the subtype of the
635 -- qualified expression, but that causes a problem
636 -- with c34007g (see above), so for now we retain this.
638 else
639 Apply_Constraint_Check
644 exception
649 -----------------------------
650 -- Expand_Array_Comparison --
651 -----------------------------
653 -- Expansion is only required in the case of array types. For the
654 -- unpacked case, an appropriate runtime routine is called. For
655 -- packed cases, and also in some other cases where a runtime
656 -- routine cannot be called, the form of the expansion is:
658 -- [body for greater_nn; boolean_expression]
660 -- The body is built by Make_Array_Comparison_Op, and the form of the
661 -- Boolean expression depends on the operator involved.
677 -- True for byte addressable target
680 -- Returns True if the length of the given operand is known to be
681 -- less than 4. Returns False if this length is known to be four
682 -- or greater or is not known at compile time.
684 ------------------------
685 -- Length_Less_Than_4 --
686 ------------------------
691 begin
695 else
696 declare
703 begin
706 else
712 else
721 -- Start of processing for Expand_Array_Comparison
723 begin
724 -- Deal first with unpacked case, where we can call a runtime routine
725 -- except that we avoid this for targets for which are not addressable
726 -- by bytes, and for the JVM, since the JVM does not support direct
727 -- addressing of array components.
730 and then Byte_Addressable
731 and then not Java_VM
732 then
733 -- The call we generate is:
735 -- Compare_Array_xn[_Unaligned]
736 -- (left'address, right'address, left'length, right'length) <op> 0
738 -- x = U for unsigned, S for signed
739 -- n = 8,16,32,64 for component size
740 -- Add _Unaligned if length < 4 and component size is 8.
741 -- <op> is the standard comparison operator
745 or else
747 then
750 else
754 else
757 else
765 else
772 else
779 else
817 -- Cases where we cannot make runtime call
819 -- For (a <= b) we convert to not (a > b)
824 Right_Opnd =>
831 -- For < the Boolean expression is
832 -- greater__nn (op2, op1)
837 -- Switch operands
842 -- For (a >= b) we convert to not (a < b)
847 Right_Opnd =>
854 -- For > the Boolean expression is
855 -- greater__nn (op1, op2)
857 else
863 Expr :=
872 exception
877 ---------------------------
878 -- Expand_Array_Equality --
879 ---------------------------
881 -- Expand an equality function for multi-dimensional arrays. Here is
882 -- an example of such a function for Nb_Dimension = 2
884 -- function Enn (A : atyp; B : btyp) return boolean is
885 -- begin
886 -- if (A'length (1) = 0 or else A'length (2) = 0)
887 -- and then
888 -- (B'length (1) = 0 or else B'length (2) = 0)
889 -- then
890 -- return True; -- RM 4.5.2(22)
891 -- end if;
893 -- if A'length (1) /= B'length (1)
894 -- or else
895 -- A'length (2) /= B'length (2)
896 -- then
897 -- return False; -- RM 4.5.2(23)
898 -- end if;
900 -- declare
901 -- A1 : Index_T1 := A'first (1);
902 -- B1 : Index_T1 := B'first (1);
903 -- begin
904 -- loop
905 -- declare
906 -- A2 : Index_T2 := A'first (2);
907 -- B2 : Index_T2 := B'first (2);
908 -- begin
909 -- loop
910 -- if A (A1, A2) /= B (B1, B2) then
911 -- return False;
912 -- end if;
914 -- exit when A2 = A'last (2);
915 -- A2 := Index_T2'succ (A2);
916 -- B2 := Index_T2'succ (B2);
917 -- end loop;
918 -- end;
920 -- exit when A1 = A'last (1);
921 -- A1 := Index_T1'succ (A1);
922 -- B1 := Index_T1'succ (B1);
923 -- end loop;
924 -- end;
926 -- return true;
927 -- end Enn;
929 -- Note on the formal types used (atyp and btyp). If either of the
930 -- arrays is of a private type, we use the underlying type, and
931 -- do an unchecked conversion of the actual. If either of the arrays
932 -- has a bound depending on a discriminant, then we use the base type
933 -- since otherwise we have an escaped discriminant in the function.
935 -- If both arrays are constrained and have the same bounds, we can
936 -- generate a loop with an explicit iteration scheme using a 'Range
937 -- attribute over the first array.
939 function Expand_Array_Equality
945 is
961 -- The parameter types to be used for the formals
963 function Arr_Attr
967 -- This builds the attribute reference Arr'Nam (Expr)
970 -- Create one statement to compare corresponding components,
971 -- designated by a full set of indices.
974 -- Given one of the arguments, computes the appropriate type to
975 -- be used for that argument in the corresponding function formal
977 function Handle_One_Dimension
980 -- This procedure returns the following code
981 --
982 -- declare
983 -- Bn : Index_T := B'First (N);
984 -- begin
985 -- loop
986 -- xxx
987 -- exit when An = A'Last (N);
988 -- An := Index_T'Succ (An)
989 -- Bn := Index_T'Succ (Bn)
990 -- end loop;
991 -- end;
992 --
993 -- If both indices are constrained and identical, the procedure
994 -- returns a simpler loop:
995 --
996 -- for An in A'Range (N) loop
997 -- xxx
998 -- end loop
999 --
1000 -- N is the dimension for which we are generating a loop. Index is the
1001 -- N'th index node, whose Etype is Index_Type_n in the above code.
1002 -- The xxx statement is either the loop or declare for the next
1003 -- dimension or if this is the last dimension the comparison
1004 -- of corresponding components of the arrays.
1005 --
1006 -- The actual way the code works is to return the comparison
1007 -- of corresponding components for the N+1 call. That's neater!
1010 -- This function constructs the test for both arrays being empty
1011 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1012 -- and then
1013 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1016 -- This function constructs the test for arrays having different
1017 -- lengths in at least one index position, in which case resull
1019 -- A'length (1) /= B'length (1)
1020 -- or else
1021 -- A'length (2) /= B'length (2)
1022 -- or else
1023 -- ...
1025 --------------
1026 -- Arr_Attr --
1027 --------------
1029 function Arr_Attr
1033 is
1034 begin
1035 return
1042 ------------------------
1043 -- Component_Equality --
1044 ------------------------
1050 begin
1051 -- if a(i1...) /= b(j1...) then return false; end if;
1053 L :=
1058 R :=
1063 Test := Expand_Composite_Equality
1066 return
1074 ------------------
1075 -- Get_Arg_Type --
1076 ------------------
1082 begin
1088 else
1094 or else
1096 then
1108 --------------------------
1109 -- Handle_One_Dimension --
1110 ---------------------------
1112 function Handle_One_Dimension
1115 is
1117 Ltyp /= Rtyp
1119 -- If the index types are identical, and we are working with
1120 -- constrained types, then we can use the same index for both of
1121 -- the arrays.
1131 begin
1136 -- Case where we generate a loop
1141 Bn :=
1144 else
1155 -- Generate guard for loop, followed by increments of indices
1159 Condition =>
1167 Expression =>
1176 Expression =>
1183 -- If separate indexes, we need a declare block for An and Bn,
1184 -- and a loop without an iteration scheme.
1187 Loop_Stm :=
1190 return
1203 Handled_Statement_Sequence =>
1207 -- If no separate indexes, return loop statement with explicit
1208 -- iteration scheme on its own
1210 else
1211 Loop_Stm :=
1214 Iteration_Scheme =>
1216 Loop_Parameter_Specification =>
1219 Discrete_Subtype_Definition =>
1225 -----------------------
1226 -- Test_Empty_Arrays --
1227 -----------------------
1236 begin
1240 Atest :=
1245 Btest :=
1254 else
1255 Alist :=
1260 Blist :=
1267 return
1273 -----------------------------
1274 -- Test_Lengths_Correspond --
1275 -----------------------------
1281 begin
1284 Rtest :=
1291 else
1292 Result :=
1302 -- Start of processing for Expand_Array_Equality
1304 begin
1308 -- For now, if the argument types are not the same, go to the
1309 -- base type, since the code assumes that the formals have the
1310 -- same type. This is fixable in future ???
1318 -- Build list of formals for function
1331 -- Build statement sequence for function
1333 Func_Body :=
1335 Specification =>
1343 Handled_Statement_Sequence =>
1351 Expression =>
1358 Expression =>
1369 -- If the array type is distinct from the type of the arguments,
1370 -- it is the full view of a private type. Apply an unchecked
1371 -- conversion to insure that analysis of the call succeeds.
1373 declare
1376 begin
1382 then
1388 then
1397 return
1403 -----------------------------
1404 -- Expand_Boolean_Operator --
1405 -----------------------------
1407 -- Note that we first get the actual subtypes of the operands,
1408 -- since we always want to deal with types that have bounds.
1413 begin
1417 else
1418 -- For the normal non-packed case, the general expansion is
1419 -- to build a function for carrying out the comparison (using
1420 -- Make_Boolean_Array_Op) and then inserting it into the tree.
1421 -- The original operator node is then rewritten as a call to
1422 -- this function.
1424 declare
1431 begin
1440 then
1445 and then
1447 then
1449 else
1455 -- Now rewrite the expression with a call
1460 Parameter_Associations =>
1461 New_List
1471 -------------------------------
1472 -- Expand_Composite_Equality --
1473 -------------------------------
1475 -- This function is only called for comparing internal fields of composite
1476 -- types when these fields are themselves composites. This is a special
1477 -- case because it is not possible to respect normal Ada visibility rules.
1479 function Expand_Composite_Equality
1485 is
1491 begin
1494 else
1498 -- Defense against malformed private types with no completion
1499 -- the error will be diagnosed later by check_completion
1509 -- If the operand is an elementary type other than a floating-point
1510 -- type, then we can simply use the built-in block bitwise equality,
1511 -- since the predefined equality operators always apply and bitwise
1512 -- equality is fine for all these cases.
1516 then
1519 -- For composite component types, and floating-point types, use
1520 -- the expansion. This deals with tagged component types (where
1521 -- we use the applicable equality routine) and floating-point,
1522 -- (where we need to worry about negative zeroes), and also the
1523 -- case of any composite type recursively containing such fields.
1525 else
1531 -- Call the primitive operation "=" of this type
1537 -- If this is derived from an untagged private type completed
1538 -- with a tagged type, it does not have a full view, so we
1539 -- use the primitive operations of the private type.
1540 -- This check should no longer be necessary when these
1541 -- types receive their full views ???
1548 then
1550 else
1554 loop
1566 return
1569 Parameter_Associations =>
1570 New_List
1580 -- Inherited equality from parent type. Convert the actuals
1581 -- to match signature of operation.
1583 declare
1586 begin
1587 return
1590 Parameter_Associations =>
1595 else
1596 -- Comparison between Unchecked_Union components
1599 declare
1605 begin
1606 -- Lhs subtype
1612 -- Rhs subtype
1618 -- Lhs of the composite equality
1622 -- Since the enclosing record can never be an
1623 -- Unchecked_Union (this code is executed for records
1624 -- that do not have variants), we may reference its
1625 -- discriminant(s).
1630 then
1631 Lhs_Discr_Val :=
1634 Selector_Name =>
1635 New_Copy (
1636 Get_Discriminant_Value (
1638 Lhs_Type,
1641 else
1643 Get_Discriminant_Value (
1645 Lhs_Type,
1649 else
1650 -- It is not possible to infer the discriminant since
1651 -- the subtype is not constrained.
1657 -- Prevent Gigi from generating illegal code, change
1658 -- the equality to a standard False.
1663 -- Rhs of the composite equality
1669 then
1670 Rhs_Discr_Val :=
1673 Selector_Name =>
1674 New_Copy (
1675 Get_Discriminant_Value (
1677 Rhs_Type,
1680 else
1682 Get_Discriminant_Value (
1684 Rhs_Type,
1688 else
1696 -- Call the TSS equality function with the inferred
1697 -- discriminant values.
1699 return
1703 Lhs,
1704 Rhs,
1705 Lhs_Discr_Val,
1706 Rhs_Discr_Val));
1710 -- Shouldn't this be an else, we can't fall through
1711 -- the above IF, right???
1713 return
1719 else
1723 else
1724 -- It can be a simple record or the full view of a scalar private
1730 ------------------------------
1731 -- Expand_Concatenate_Other --
1732 ------------------------------
1734 -- Let n be the number of array operands to be concatenated, Base_Typ
1735 -- their base type, Ind_Typ their index type, and Arr_Typ the original
1736 -- array type to which the concatenantion operator applies, then the
1737 -- following subprogram is constructed:
1739 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1740 -- L : Ind_Typ;
1741 -- begin
1742 -- if S1'Length /= 0 then
1743 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
1744 -- XXX = Arr_Typ'First otherwise
1745 -- elsif S2'Length /= 0 then
1746 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
1747 -- YYY = Arr_Typ'First otherwise
1748 -- ...
1749 -- elsif Sn-1'Length /= 0 then
1750 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
1751 -- ZZZ = Arr_Typ'First otherwise
1752 -- else
1753 -- return Sn;
1754 -- end if;
1756 -- declare
1757 -- P : Ind_Typ;
1758 -- H : Ind_Typ :=
1759 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1760 -- + Ind_Typ'Pos (L));
1761 -- R : Base_Typ (L .. H);
1762 -- begin
1763 -- if S1'Length /= 0 then
1764 -- P := S1'First;
1765 -- loop
1766 -- R (L) := S1 (P);
1767 -- L := Ind_Typ'Succ (L);
1768 -- exit when P = S1'Last;
1769 -- P := Ind_Typ'Succ (P);
1770 -- end loop;
1771 -- end if;
1772 --
1773 -- if S2'Length /= 0 then
1774 -- L := Ind_Typ'Succ (L);
1775 -- loop
1776 -- R (L) := S2 (P);
1777 -- L := Ind_Typ'Succ (L);
1778 -- exit when P = S2'Last;
1779 -- P := Ind_Typ'Succ (P);
1780 -- end loop;
1781 -- end if;
1783 -- . . .
1785 -- if Sn'Length /= 0 then
1786 -- P := Sn'First;
1787 -- loop
1788 -- R (L) := Sn (P);
1789 -- L := Ind_Typ'Succ (L);
1790 -- exit when P = Sn'Last;
1791 -- P := Ind_Typ'Succ (P);
1792 -- end loop;
1793 -- end if;
1795 -- return R;
1796 -- end;
1797 -- end Cnn;]
1835 -- Builds the sequence of statement:
1836 -- P := Si'First;
1837 -- loop
1838 -- R (L) := Si (P);
1839 -- L := Ind_Typ'Succ (L);
1840 -- exit when P = Si'Last;
1841 -- P := Ind_Typ'Succ (P);
1842 -- end loop;
1843 --
1844 -- where i is the input parameter I given.
1845 -- If the flag Last is true, the exit statement is emitted before
1846 -- incrementing the lower bound, to prevent the creation out of
1847 -- bound values.
1850 -- Builds the statement:
1851 -- L := Arr_Typ'First; If Arr_Typ is constrained
1852 -- L := Si'First; otherwise (where I is the input param given)
1855 -- Builds reference to identifier H
1858 -- Builds expression Ind_Typ'Val (E);
1861 -- Builds reference to identifier L
1864 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
1865 -- expression to avoid universal_integer computations whenever possible,
1866 -- in the expression for the upper bound H.
1869 -- Builds expression Ind_Typ'Succ (L)
1872 -- Builds integer literal one
1875 -- Builds reference to identifier P
1878 -- Builds expression Ind_Typ'Succ (P)
1881 -- Builds reference to identifier R
1884 -- Builds reference to identifier Si, where I is the value given
1887 -- Builds expression Si'First, where I is the value given
1890 -- Builds expression Si'Last, where I is the value given
1893 -- Builds expression Si'Length, where I is the value given
1896 -- Builds expression Si'Length /= 0, where I is the value given
1898 -------------------
1899 -- Copy_Into_R_S --
1900 -------------------
1911 begin
1912 -- First construct the initializations
1919 -- Then build the loop
1941 Loop_Stmt :=
1944 else
1945 Loop_Stmt :=
1955 -------
1956 -- H --
1957 -------
1960 begin
1964 -------------
1965 -- Ind_Val --
1966 -------------
1969 begin
1970 return
1977 ------------
1978 -- Init_L --
1979 ------------
1984 begin
1990 else
1997 -------
1998 -- L --
1999 -------
2002 begin
2006 -----------
2007 -- L_Pos --
2008 -----------
2013 begin
2014 -- If the index type is an enumeration type, the computation
2015 -- can be done in standard integer. Otherwise, choose a large
2016 -- enough integer type.
2022 then
2024 else
2028 return
2031 Expression =>
2038 ------------
2039 -- L_Succ --
2040 ------------
2043 begin
2044 return
2051 ---------
2052 -- One --
2053 ---------
2056 begin
2060 -------
2061 -- P --
2062 -------
2065 begin
2069 ------------
2070 -- P_Succ --
2071 ------------
2074 begin
2075 return
2082 -------
2083 -- R --
2084 -------
2087 begin
2091 -------
2092 -- S --
2093 -------
2096 begin
2100 -------------
2101 -- S_First --
2102 -------------
2105 begin
2111 ------------
2112 -- S_Last --
2113 ------------
2116 begin
2122 --------------
2123 -- S_Length --
2124 --------------
2127 begin
2133 -------------------
2134 -- S_Length_Test --
2135 -------------------
2138 begin
2139 return
2145 -- Start of processing for Expand_Concatenate_Other
2147 begin
2148 -- Construct the parameter specs and the overall function spec
2152 Append_To
2155 Defining_Identifier =>
2161 Func_Spec :=
2167 -- Construct L's object declaration
2169 L_Decl :=
2176 -- Construct the if-then-elsif statements
2185 If_Stmt :=
2193 -- Construct the declaration for H
2195 P_Decl :=
2206 H_Decl :=
2212 -- Construct the declaration for R
2215 R_Constr :=
2219 R_Decl :=
2222 Object_Definition =>
2227 -- Construct the declarations for the declare block
2231 -- Construct list of statements for the declare block
2243 -- Construct the declare block
2247 Handled_Statement_Sequence =>
2250 -- Construct the list of function statements
2254 -- Construct the function body
2256 Func_Body :=
2260 Handled_Statement_Sequence =>
2263 -- Insert the newly generated function in the code. This is analyzed
2264 -- with all checks off, since we have completed all the checks.
2266 -- Note that this does *not* fix the array concatenation bug when the
2267 -- low bound is Integer'first sibce that bug comes from the pointer
2268 -- dereferencing an unconstrained array. An there we need a constraint
2269 -- check to make sure the length of the concatenated array is ok. ???
2273 -- Construct list of arguments for the function call
2282 -- Insert the function call
2284 Rewrite
2292 -------------------------------
2293 -- Expand_Concatenate_String --
2294 -------------------------------
2304 -- RE_Id value for function to be called
2306 begin
2307 -- In all cases, we build a call to a routine giving the list of
2308 -- arguments as the parameter list to the routine.
2316 else
2325 else
2330 -- If we have anything other than Standard_Character or
2331 -- Standard_String, then we must have had a serious error
2332 -- earlier, so we just abandon the attempt at expansion.
2334 else
2353 -- Now generate the appropriate call
2362 exception
2367 ------------------------
2368 -- Expand_N_Allocator --
2369 ------------------------
2379 begin
2380 -- RM E.2.3(22). We enforce that the expected type of an allocator
2381 -- shall not be a remote access-to-class-wide-limited-private type
2383 -- Why is this being done at expansion time, seems clearly wrong ???
2387 -- Set the Storage Pool
2400 else
2406 -- Under certain circumstances we can replace an allocator by an
2407 -- access to statically allocated storage. The conditions, as noted
2408 -- in AARM 3.10 (10c) are as follows:
2410 -- Size and initial value is known at compile time
2411 -- Access type is access-to-constant
2413 -- The allocator is not part of a constraint on a record component,
2414 -- because in that case the inserted actions are delayed until the
2415 -- record declaration is fully analyzed, which is too late for the
2416 -- analysis of the rewritten allocator.
2424 then
2425 -- Here we can do the optimization. For the allocator
2427 -- new x'(y)
2429 -- We insert an object declaration
2431 -- Tnn : aliased x := y;
2433 -- and replace the allocator by Tnn'Unrestricted_Access.
2434 -- Tnn is marked as requiring static allocation.
2436 Temp :=
2441 -- If context is constrained, use constrained subtype directly,
2442 -- so that the constant is not labelled as having a nomimally
2443 -- unconstrained subtype.
2464 -- We set the variable as statically allocated, since we don't
2465 -- want it going on the stack of the current procedure!
2471 -- Handle case of qualified expression (other than optimization above)
2476 -- If the allocator is for a type which requires initialization, and
2477 -- there is no initial value (i.e. operand is a subtype indication
2478 -- rather than a qualifed expression), then we must generate a call
2479 -- to the initialization routine. This is done using an expression
2480 -- actions node:
2481 --
2482 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2483 --
2484 -- Here ptr_T is the pointer type for the allocator, and T is the
2485 -- subtype of the allocator. A special case arises if the designated
2486 -- type of the access type is a task or contains tasks. In this case
2487 -- the call to Init (Temp.all ...) is replaced by code that ensures
2488 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2489 -- for details). In addition, if the type T is a task T, then the
2490 -- first argument to Init must be converted to the task record type.
2492 else
2493 declare
2506 begin
2510 -- Case of no initialization procedure present
2514 -- Case of simple initialization required
2527 -- No initialization required
2529 else
2533 -- Case of initialization procedure present, must be called
2535 else
2538 Temp :=
2541 -- Construct argument list for the initialization routine call
2542 -- The CPP constructor needs the address directly
2548 else
2549 Arg1 :=
2555 -- The initialization procedure expects a specific type.
2556 -- if the context is access to class wide, indicate that
2557 -- the object being allocated has the right specific type.
2564 -- If designated type is a concurrent type or if it is a
2565 -- private type whose definition is a concurrent type,
2566 -- the first argument in the Init routine has to be
2567 -- unchecked conversion to the corresponding record type.
2568 -- If the designated type is a derived type, we also
2569 -- convert the argument to its root type.
2572 Arg1 :=
2578 then
2579 Arg1 :=
2580 Unchecked_Convert_To
2585 declare
2588 begin
2596 -- For the task case, pass the Master_Id of the access type
2597 -- as the value of the _Master parameter, and _Chain as the
2598 -- value of the _Chain parameter (_Chain will be defined as
2599 -- part of the generated code for the allocator).
2604 -- The designated type was an incomplete type, and
2605 -- the access type did not get expanded. Salvage
2606 -- it now.
2608 Expand_N_Full_Type_Declaration
2612 -- If the context of the allocator is a declaration or
2613 -- an assignment, we can generate a meaningful image for
2614 -- it, even though subsequent assignments might remove
2615 -- the connection between task and entity. We build this
2616 -- image when the left-hand side is a simple variable,
2617 -- a simple indexed assignment or a simple selected
2618 -- component.
2621 declare
2624 begin
2626 Decls :=
2627 Build_Task_Image_Decls (
2628 Loc,
2629 New_Occurrence_Of
2635 then
2636 Decls :=
2637 Build_Task_Image_Decls
2639 else
2645 Decls :=
2646 Build_Task_Image_Decls (
2649 else
2654 New_Reference_To
2662 -- Has_Task is false, Decls not used
2664 else
2668 -- Add discriminants if discriminated type
2681 then
2682 Discr :=
2691 -- We set the allocator as analyzed so that when we analyze the
2692 -- expression actions node, we do not get an unwanted recursive
2693 -- expansion of the allocator expression.
2698 -- Here is the transformation:
2699 -- input: new T
2700 -- output: Temp : constant ptr_T := new T;
2701 -- Init (Temp.all, ...);
2702 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
2703 -- <CTRL> Initialize (Finalizable (Temp.all));
2705 -- Here ptr_T is the pointer type for the allocator, and T
2706 -- is the subtype of the allocator.
2708 Temp_Decl :=
2723 -- If the designated type is task type or contains tasks,
2724 -- Create block to activate created tasks, and insert
2725 -- declaration for Task_Image variable ahead of call.
2728 declare
2732 begin
2740 else
2751 else
2755 Make_Init_Call (
2760 Attach_Level)));
2768 else
2777 exception
2782 -----------------------
2783 -- Expand_N_And_Then --
2784 -----------------------
2786 -- Expand into conditional expression if Actions present, and also
2787 -- deal with optimizing case of arguments being True or False.
2796 begin
2797 -- Deal with non-standard booleans
2805 -- Check for cases of left argument is True or False
2809 -- If left argument is True, change (True and then Right) to Right.
2810 -- Any actions associated with Right will be executed unconditionally
2811 -- and can thus be inserted into the tree unconditionally.
2822 -- If left argument is False, change (False and then Right) to
2823 -- False. In this case we can forget the actions associated with
2824 -- Right, since they will never be executed.
2835 -- If Actions are present, we expand
2837 -- left and then right
2839 -- into
2841 -- if left then right else false end
2843 -- with the actions becoming the Then_Actions of the conditional
2844 -- expression. This conditional expression is then further expanded
2845 -- (and will eventually disappear)
2852 Left,
2853 Right,
2862 -- No actions present, check for cases of right argument True/False
2866 -- Change (Left and then True) to Left. Note that we know there
2867 -- are no actions associated with the True operand, since we
2868 -- just checked for this case above.
2873 -- Change (Left and then False) to False, making sure to preserve
2874 -- any side effects associated with the Left operand.
2878 Rewrite
2886 -------------------------------------
2887 -- Expand_N_Conditional_Expression --
2888 -------------------------------------
2890 -- Expand into expression actions if then/else actions present
2901 begin
2902 -- If either then or else actions are present, then given:
2904 -- if cond then then-expr else else-expr end
2906 -- we insert the following sequence of actions (using Insert_Actions):
2908 -- Cnn : typ;
2909 -- if cond then
2910 -- <<then actions>>
2911 -- Cnn := then-expr;
2912 -- else
2913 -- <<else actions>>
2914 -- Cnn := else-expr
2915 -- end if;
2917 -- and replace the conditional expression by a reference to Cnn
2922 New_If :=
2940 Insert_List_Before
2945 Insert_List_Before
2961 -----------------------------------
2962 -- Expand_N_Explicit_Dereference --
2963 -----------------------------------
2966 begin
2967 -- The only processing required is an insertion of an explicit
2968 -- dereference call for the checked storage pool case.
2973 -----------------
2974 -- Expand_N_In --
2975 -----------------
2984 begin
2985 -- If we have an explicit range, do a bit of optimization based
2986 -- on range analysis (we may be able to kill one or both checks).
2989 declare
2995 begin
2996 -- If either check is known to fail, replace result
2997 -- by False, since the other check does not matter.
2998 -- Preserve the static flag for legality checks, because
2999 -- we are constant-folding beyond RM 4.9.
3008 -- If both checks are known to succeed, replace result
3009 -- by True, since we know we are in range.
3018 -- If lower bound check succeeds and upper bound check is
3019 -- not known to succeed or fail, then replace the range check
3020 -- with a comparison against the upper bound.
3030 -- If upper bound check succeeds and lower bound check is
3031 -- not known to succeed or fail, then replace the range check
3032 -- with a comparison against the lower bound.
3044 -- For all other cases of an explicit range, nothing to be done
3048 -- Here right operand is a subtype mark
3050 else
3051 declare
3057 begin
3060 -- For tagged type, do tagged membership operation
3064 -- No expansion will be performed when Java_VM, as the
3065 -- JVM back end will handle the membership tests directly
3066 -- (tags are not explicitly represented in Java objects,
3067 -- so the normal tagged membership expansion is not what
3068 -- we want).
3077 -- If type is scalar type, rewrite as x in t'first .. t'last
3078 -- This reason we do this is that the bounds may have the wrong
3079 -- type if they come from the original type definition.
3084 Low_Bound =>
3089 High_Bound =>
3096 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
3097 -- a membership test if the subtype mark denotes a constrained
3098 -- Unchecked_Union subtype and the expression lacks inferable
3099 -- discriminants.
3104 then
3109 -- Prevent Gigi from generating incorrect code by rewriting
3110 -- the test as a standard False.
3118 -- Here we have a non-scalar type
3129 -- For the constrained array case, we have to check the
3130 -- subscripts for an exact match if the lengths are
3131 -- non-zero (the lengths must match in any case).
3136 function Construct_Attribute_Reference
3140 -- Build attribute reference E'Nam(Dim)
3142 -----------------------------------
3143 -- Construct_Attribute_Reference --
3144 -----------------------------------
3146 function Construct_Attribute_Reference
3150 is
3151 begin
3152 return
3160 -- Start processing for Check_Subscripts
3162 begin
3166 Left_Opnd =>
3167 Construct_Attribute_Reference
3170 Right_Opnd =>
3171 Construct_Attribute_Reference
3176 Left_Opnd =>
3177 Construct_Attribute_Reference
3180 Right_Opnd =>
3181 Construct_Attribute_Reference
3186 Cond :=
3188 Left_Opnd =>
3199 -- These are the cases where constraint checks may be
3200 -- required, e.g. records with possible discriminants
3202 else
3203 -- Expand the test into a series of discriminant comparisons.
3204 -- The expression that is built is the negation of the one
3205 -- that is used for checking discriminant constraints.
3215 Left_Opnd =>
3222 else
3233 --------------------------------
3234 -- Expand_N_Indexed_Component --
3235 --------------------------------
3243 begin
3244 -- A special optimization, if we have an indexed component that
3245 -- is selecting from a slice, then we can eliminate the slice,
3246 -- since, for example, x (i .. j)(k) is identical to x(k). The
3247 -- only difference is the range check required by the slice. The
3248 -- range check for the slice itself has already been generated.
3249 -- The range check for the subscripting operation is ensured
3250 -- by converting the subject to the subtype of the slice.
3252 -- This optimization not only generates better code, avoiding
3253 -- slice messing especially in the packed case, but more importantly
3254 -- bypasses some problems in handling this peculiar case, for
3255 -- example, the issue of dealing specially with object renamings.
3262 Convert_To
3269 -- If the prefix is an access type, then we unconditionally rewrite
3270 -- if as an explicit deference. This simplifies processing for several
3271 -- cases, including packed array cases and certain cases in which
3272 -- checks must be generated. We used to try to do this only when it
3273 -- was necessary, but it cleans up the code to do it all the time.
3280 -- Generate index and validity checks
3288 -- All done for the non-packed case
3294 -- For packed arrays that are not bit-packed (i.e. the case of an array
3295 -- with one or more index types with a non-coniguous enumeration type),
3296 -- we can always use the normal packed element get circuit.
3303 -- For a reference to a component of a bit packed array, we have to
3304 -- convert it to a reference to the corresponding Packed_Array_Type.
3305 -- We only want to do this for simple references, and not for:
3307 -- Left side of assignment, or prefix of left side of assignment,
3308 -- or prefix of the prefix, to handle packed arrays of packed arrays,
3309 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3311 -- Renaming objects in renaming associations
3312 -- This case is handled when a use of the renamed variable occurs
3314 -- Actual parameters for a procedure call
3315 -- This case is handled in Exp_Ch6.Expand_Actuals
3317 -- The second expression in a 'Read attribute reference
3319 -- The prefix of an address or size attribute reference
3321 -- The following circuit detects these exceptions
3323 declare
3327 begin
3328 loop
3335 and then
3337 then
3342 or else
3345 then
3350 then
3353 -- If the expression is an index of an indexed component,
3354 -- it must be expanded regardless of context.
3358 then
3364 then
3370 then
3376 then
3379 else
3384 -- Keep looking up tree for unchecked expression, or if we are
3385 -- the prefix of a possible assignment left side.
3394 ---------------------
3395 -- Expand_N_Not_In --
3396 ---------------------
3398 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
3399 -- can be done. This avoids needing to duplicate this expansion code.
3405 begin
3408 Right_Opnd =>
3415 -------------------
3416 -- Expand_N_Null --
3417 -------------------
3419 -- The only replacement required is for the case of a null of type
3420 -- that is an access to protected subprogram. We represent such
3421 -- access values as a record, and so we must replace the occurrence
3422 -- of null by the equivalent record (with a null address and a null
3423 -- pointer in it), so that the backend creates the proper value.
3430 begin
3432 Agg :=
3441 -- For subsequent semantic analysis, the node must retain its
3442 -- type. Gigi in any case replaces this type by the corresponding
3443 -- record type before processing the node.
3448 exception
3453 ---------------------
3454 -- Expand_N_Op_Abs --
3455 ---------------------
3461 begin
3464 -- Deal with software overflow checking
3466 if not Backend_Overflow_Checks_On_Target
3469 then
3470 -- The only case to worry about is when the argument is
3471 -- equal to the largest negative number, so what we do is
3472 -- to insert the check:
3474 -- [constraint_error when Expr = typ'Base'First]
3476 -- with the usual Duplicate_Subexpr use coding for expr
3480 Condition =>
3483 Right_Opnd =>
3485 Prefix =>
3491 -- Vax floating-point types case
3498 ---------------------
3499 -- Expand_N_Op_Add --
3500 ---------------------
3505 begin
3508 -- N + 0 = 0 + N = N for integer types
3513 then
3519 then
3525 -- Arithmetic overflow checks for signed integer/fixed point types
3529 then
3533 -- Vax floating-point types case
3540 ---------------------
3541 -- Expand_N_Op_And --
3542 ---------------------
3547 begin
3561 ------------------------
3562 -- Expand_N_Op_Concat --
3563 ------------------------
3566 -- This is initialized the first time this routine is called. It records
3567 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3568 -- available in the run-time:
3569 --
3570 -- 0 None available
3571 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
3572 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3573 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3574 -- 5 All routines including RE_Str_Concat_5 available
3577 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3578 -- all three are available, False if any one of these is unavailable.
3582 -- List of operands to be concatenated
3585 -- Single operand for concatenation
3588 -- Node which is to be replaced by the result of concatenating
3589 -- the nodes in the list Opnds.
3592 -- Array type of concatenation result type
3595 -- Component type of concatenation represented by Cnode
3597 begin
3598 -- Initialize global variables showing run-time status
3609 else
3613 Char_Concat_Available :=
3615 and then
3617 and then
3621 -- Ensure validity of both operands
3625 -- If we are the left operand of a concatenation higher up the
3626 -- tree, then do nothing for now, since we want to deal with a
3627 -- series of concatenations as a unit.
3631 then
3635 -- We get here with a concatenation whose left operand may be a
3636 -- concatenation itself with a consistent type. We need to process
3637 -- these concatenation operands from left to right, which means
3638 -- from the deepest node in the tree to the highest node.
3645 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
3646 -- nodes above, so now we process bottom up, doing the operations. We
3647 -- gather a string that is as long as possible up to five operands
3649 -- The outer loop runs more than once if there are more than five
3650 -- concatenations of type Standard.String, the most we handle for
3651 -- this case, or if more than one concatenation type is involved.
3657 -- The inner loop gathers concatenation operands. We gather any
3658 -- number of these in the non-string case, or if no concatenation
3659 -- routines are available for string (since in that case we will
3660 -- treat string like any other non-string case). Otherwise we only
3661 -- gather as many operands as can be handled by the available
3662 -- procedures in the run-time library (normally 5, but may be
3663 -- less for the configurable run-time case).
3667 or else
3669 or else
3671 Max_Available_String_Operands)
3674 loop
3679 -- Here we process the collected operands. First we convert
3680 -- singleton operands to singleton aggregates. This is skipped
3681 -- however for the case of two operands of type String, since
3682 -- we have special routines for these cases.
3688 or else not Char_Concat_Available
3689 then
3691 loop
3704 -- Now call appropriate continuation routine
3708 then
3710 else
3719 ------------------------
3720 -- Expand_N_Op_Divide --
3721 ------------------------
3729 begin
3732 -- Vax_Float is a special case
3739 -- N / 1 = N for integer types
3744 then
3749 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3750 -- Is_Power_Of_2_For_Shift is set means that we know that our left
3751 -- operand is an unsigned integer, as required for this to work.
3756 -- We cannot do this transformation in configurable run time mode if we
3757 -- have 64-bit -- integers and long shifts are not available.
3759 and then
3762 then
3766 Right_Opnd =>
3772 -- Do required fixup of universal fixed operation
3779 -- Divisions with fixed-point results
3783 -- No special processing if Treat_Fixed_As_Integer is set,
3784 -- since from a semantic point of view such operations are
3785 -- simply integer operations and will be treated that way.
3790 else
3795 -- Other cases of division of fixed-point operands. Again we
3796 -- exclude the case where Treat_Fixed_As_Integer is set.
3801 then
3804 else
3809 -- Mixed-mode operations can appear in a non-static universal
3810 -- context, in which case the integer argument must be converted
3811 -- explicitly.
3815 then
3823 then
3829 -- Non-fixed point cases, do zero divide and overflow checks
3834 -- Check for 64-bit division available
3837 and then not Support_64_Bit_Divides_On_Target
3838 then
3844 --------------------
3845 -- Expand_N_Op_Eq --
3846 --------------------
3861 -- If a constructed equality exists for the type or for its parent,
3862 -- build and analyze call, adding conversions if the operation is
3863 -- inherited.
3866 -- Determines whether a type has a subcompoment of an unconstrained
3867 -- Unchecked_Union subtype. Typ is a record type.
3869 -------------------------
3870 -- Build_Equality_Call --
3871 -------------------------
3878 begin
3881 then
3886 -- If we have an Unchecked_Union, we need to add the inferred
3887 -- discriminant values as actuals in the function call. At this
3888 -- point, the expansion has determined that both operands have
3889 -- inferable discriminants.
3892 declare
3898 begin
3899 -- Per-object constrained selected components require special
3900 -- attention. If the enclosing scope of the component is an
3901 -- Unchecked_Union, we can not reference its discriminants
3902 -- directly. This is why we use the two extra parameters of
3903 -- the equality function of the enclosing Unchecked_Union.
3905 -- type UU_Type (Discr : Integer := 0) is
3906 -- . . .
3907 -- end record;
3908 -- pragma Unchecked_Union (UU_Type);
3910 -- 1. Unchecked_Union enclosing record:
3912 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
3913 -- . . .
3914 -- Comp : UU_Type (Discr);
3915 -- . . .
3916 -- end Enclosing_UU_Type;
3917 -- pragma Unchecked_Union (Enclosing_UU_Type);
3919 -- Obj1 : Enclosing_UU_Type;
3920 -- Obj2 : Enclosing_UU_Type (1);
3922 -- [. . .] Obj1 = Obj2 [. . .]
3924 -- Generated code:
3926 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
3928 -- A and B are the formal parameters of the equality function
3929 -- of Enclosing_UU_Type. The function always has two extra
3930 -- formals to capture the inferred discriminant values.
3932 -- 2. Non-Unchecked_Union enclosing record:
3934 -- type
3935 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
3936 -- is record
3937 -- . . .
3938 -- Comp : UU_Type (Discr);
3939 -- . . .
3940 -- end Enclosing_Non_UU_Type;
3942 -- Obj1 : Enclosing_Non_UU_Type;
3943 -- Obj2 : Enclosing_Non_UU_Type (1);
3945 -- . . . Obj1 = Obj2 . . .
3947 -- Generated code:
3949 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
3950 -- obj1.discr, obj2.discr)) then
3952 -- In this case we can directly reference the discriminants of
3953 -- the enclosing record.
3955 -- Lhs of equality
3958 and then Has_Per_Object_Constraint
3960 then
3961 -- Enclosing record is an Unchecked_Union, use formal A
3965 then
3966 Lhs_Discr_Val :=
3970 -- Enclosing record is of a non-Unchecked_Union type, it is
3971 -- possible to reference the discriminant.
3973 else
3974 Lhs_Discr_Val :=
3977 Selector_Name =>
3978 New_Copy
3979 (Get_Discriminant_Value
3981 Lhs_Type,
3985 -- Comment needed here ???
3987 else
3988 -- Infer the discriminant value
3990 Lhs_Discr_Val :=
3991 New_Copy
3992 (Get_Discriminant_Value
3994 Lhs_Type,
3998 -- Rhs of equality
4001 and then Has_Per_Object_Constraint
4003 then
4004 if Is_Unchecked_Union
4006 then
4007 Rhs_Discr_Val :=
4011 else
4012 Rhs_Discr_Val :=
4015 Selector_Name =>
4018 Rhs_Type,
4022 else
4023 Rhs_Discr_Val :=
4026 Rhs_Type,
4035 L_Exp,
4036 R_Exp,
4037 Lhs_Discr_Val,
4038 Rhs_Discr_Val)));
4041 -- Normal case, not an unchecked union
4043 else
4053 ------------------------------------
4054 -- Has_Unconstrained_UU_Component --
4055 ------------------------------------
4057 function Has_Unconstrained_UU_Component
4059 is
4065 function Component_Is_Unconstrained_UU
4067 -- Determines whether the subtype of the component is an
4068 -- unconstrained Unchecked_Union.
4070 function Variant_Is_Unconstrained_UU
4072 -- Determines whether a component of the variant has an unconstrained
4073 -- Unchecked_Union subtype.
4075 -----------------------------------
4076 -- Component_Is_Unconstrained_UU --
4077 -----------------------------------
4079 function Component_Is_Unconstrained_UU
4081 is
4082 begin
4087 declare
4091 begin
4092 -- Unconstrained nominal type. In the case of a constraint
4093 -- present, the node kind would have been N_Subtype_Indication.
4103 ---------------------------------
4104 -- Variant_Is_Unconstrained_UU --
4105 ---------------------------------
4107 function Variant_Is_Unconstrained_UU
4109 is
4112 begin
4117 declare
4120 begin
4123 -- One component is sufficent
4133 -- None of the components withing the variant were of
4134 -- unconstrained Unchecked_Union type.
4139 -- Start of processing for Has_Unconstrained_UU_Component
4141 begin
4149 -- Inspect available components
4152 declare
4155 begin
4158 -- One component is sufficent
4169 -- Inspect available components withing variants
4172 declare
4175 begin
4178 -- One component within a variant is sufficent
4189 -- Neither the available components, nor the components inside the
4190 -- variant parts were of an unconstrained Unchecked_Union subtype.
4195 -- Start of processing for Expand_N_Op_Eq
4197 begin
4207 -- It may happen in error situations that the underlying type is not
4208 -- set. The error will be detected later, here we just defend the
4209 -- expander code.
4217 -- Vax float types
4223 -- Boolean types (requiring handling of non-standard case)
4231 -- Array types
4235 -- If we are doing full validity checking, then expand out array
4236 -- comparisons to make sure that we check the array elements.
4239 declare
4241 Force_Validity_Checks;
4242 begin
4245 Expand_Array_Equality
4249 Bodies,
4250 Typl));
4256 -- Packed case
4261 -- Where the component type is elementary we can use a block bit
4262 -- comparison (if supported on the target) exception in the case
4263 -- of floating-point (negative zero issues require element by
4264 -- element comparison), and atomic types (where we must be sure
4265 -- to load elements independently).
4270 and then Support_Composite_Compare_On_Target
4271 then
4274 -- For composite and floating-point cases, expand equality loop
4275 -- to make sure of using proper comparisons for tagged types,
4276 -- and correctly handling the floating-point case.
4278 else
4280 Expand_Array_Equality
4284 Bodies,
4285 Typl));
4290 -- Record Types
4294 -- For tagged types, use the primitive "="
4298 -- If this is derived from an untagged private type completed
4299 -- with a tagged type, it does not have a full view, so we
4300 -- use the primitive operations of the private type.
4301 -- This check should no longer be necessary when these
4302 -- types receive their full views ???
4308 then
4309 -- Search for equality operation, checking that the
4310 -- operands have the same type. Note that we must find
4311 -- a matching entry, or something is very wrong!
4319 and then
4328 -- Find the type's predefined equality or an overriding
4329 -- user-defined equality. The reason for not simply calling
4330 -- Find_Prim_Op here is that there may be a user-defined
4331 -- overloaded equality op that precedes the equality that
4332 -- we want, so we have to explicitly search (e.g., there
4333 -- could be an equality with two different parameter types).
4335 else
4345 and then
4357 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
4358 -- predefined equality operator for a type which has a subcomponent
4359 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
4366 -- Prevent Gigi from generating incorrect code by rewriting the
4367 -- equality as a standard False.
4374 -- If we can infer the discriminants of the operands, we make a
4375 -- call to the TSS equality function.
4378 and then
4380 then
4381 Build_Equality_Call
4384 else
4385 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4386 -- the predefined equality operator for an Unchecked_Union type
4387 -- if either of the operands lack inferable discriminants.
4393 -- Prevent Gigi from generating incorrect code by rewriting
4394 -- the equality as a standard False.
4401 -- If a type support function is present (for complex cases), use it
4404 Build_Equality_Call
4407 -- Otherwise expand the component by component equality. Note that
4408 -- we never use block-bit coparisons for records, because of the
4409 -- problems with gaps. The backend will often be able to recombine
4410 -- the separate comparisons that we generate here.
4412 else
4423 -- If we still have an equality comparison (i.e. it was not rewritten
4424 -- in some way), then we can test if result is needed at compile time).
4431 -----------------------
4432 -- Expand_N_Op_Expon --
4433 -----------------------
4451 begin
4454 -- If either operand is of a private type, then we have the use of
4455 -- an intrinsic operator, and we get rid of the privateness, by using
4456 -- root types of underlying types for the actual operation. Otherwise
4457 -- the private types will cause trouble if we expand multiplications
4458 -- or shifts etc. We also do this transformation if the result type
4459 -- is different from the base type.
4462 or else
4464 or else
4466 or else
4468 then
4469 declare
4473 begin
4484 -- Test for case of known right argument
4489 -- We only fold small non-negative exponents. You might think we
4490 -- could fold small negative exponents for the real case, but we
4491 -- can't because we are required to raise Constraint_Error for
4492 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
4493 -- See ACVC test C4A012B.
4497 -- X ** 0 = 1 (or 1.0)
4502 else
4506 -- X ** 1 = X
4511 -- X ** 2 = X * X
4514 Xnode :=
4519 -- X ** 3 = X * X * X
4522 Xnode :=
4524 Left_Opnd =>
4530 -- X ** 4 ->
4531 -- En : constant base'type := base * base;
4532 -- ...
4533 -- En * En
4536 Temp :=
4544 Expression =>
4549 Xnode :=
4561 -- Case of (2 ** expression) appearing as an argument of an integer
4562 -- multiplication, or as the right argument of a division of a non-
4563 -- negative integer. In such cases we leave the node untouched, setting
4564 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
4565 -- of the higher level node converts it into a shift.
4572 and then not Ovflo
4574 then
4575 declare
4580 begin
4582 and then
4584 or else
4588 or else
4594 then
4601 -- Fall through if exponentiation must be done using a runtime routine
4603 -- First deal with modular case
4607 -- Non-binary case, we call the special exponentiation routine for
4608 -- the non-binary case, converting the argument to Long_Long_Integer
4609 -- and passing the modulus value. Then the result is converted back
4610 -- to the base type.
4620 Exp))));
4622 -- Binary case, in this case, we call one of two routines, either
4623 -- the unsigned integer case, or the unsigned long long integer
4624 -- case, with a final "and" operation to do the required mod.
4626 else
4629 else
4636 Left_Opnd =>
4641 Exp)),
4642 Right_Opnd =>
4647 -- Common exit point for modular type case
4652 -- Signed integer cases, done using either Integer or Long_Long_Integer.
4653 -- It is not worth having routines for Short_[Short_]Integer, since for
4654 -- most machines it would not help, and it would generate more code that
4655 -- might need certification in the HI-E case.
4657 -- In the integer cases, we have two routines, one for when overflow
4658 -- checks are required, and one when they are not required, since
4659 -- there is a real gain in ommitting checks on many machines.
4663 and then
4666 then
4671 else
4680 else
4684 -- Floating-point cases, always done using Long_Long_Float. We do not
4685 -- need separate routines for the overflow case here, since in the case
4686 -- of floating-point, we generate infinities anyway as a rule (either
4687 -- that or we automatically trap overflow), and if there is an infinity
4688 -- generated and a range check is required, the check will fail anyway.
4690 else
4696 -- Common processing for integer cases and floating-point cases.
4697 -- If we are in the right type, we can call runtime routine directly
4702 then
4708 -- Otherwise we have to introduce conversions (conversions are also
4709 -- required in the universal cases, since the runtime routine is
4710 -- typed using one of the standard types.
4712 else
4719 Exp))));
4725 exception
4730 --------------------
4731 -- Expand_N_Op_Ge --
4732 --------------------
4740 begin
4762 --------------------
4763 -- Expand_N_Op_Gt --
4764 --------------------
4772 begin
4794 --------------------
4795 -- Expand_N_Op_Le --
4796 --------------------
4804 begin
4826 --------------------
4827 -- Expand_N_Op_Lt --
4828 --------------------
4836 begin
4858 -----------------------
4859 -- Expand_N_Op_Minus --
4860 -----------------------
4866 begin
4869 if not Backend_Overflow_Checks_On_Target
4872 then
4873 -- Software overflow checking expands -expr into (0 - expr)
4882 -- Vax floating-point types case
4889 ---------------------
4890 -- Expand_N_Op_Mod --
4891 ---------------------
4909 begin
4915 -- Convert mod to rem if operands are known non-negative. We do this
4916 -- since it is quite likely that this will improve the quality of code,
4917 -- (the operation now corresponds to the hardware remainder), and it
4918 -- does not seem likely that it could be harmful.
4921 and then
4923 then
4929 -- Instead of reanalyzing the node we do the analysis manually.
4930 -- This avoids anomalies when the replacement is done in an
4931 -- instance and is epsilon more efficient.
4940 -- Otherwise, normal mod processing
4942 else
4947 -- Apply optimization x mod 1 = 0. We don't really need that with
4948 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
4949 -- certainly harmless.
4954 then
4960 -- Deal with annoying case of largest negative number remainder
4961 -- minus one. Gigi does not handle this case correctly, because
4962 -- it generates a divide instruction which may trap in this case.
4964 -- In fact the check is quite easy, if the right operand is -1,
4965 -- then the mod value is always 0, and we can just ignore the
4966 -- left operand completely in this case.
4968 -- The operand type may be private (e.g. in the expansion of an
4969 -- an intrinsic operation) so we must use the underlying type to
4970 -- get the bounds, and convert the literals explicitly.
4972 LLB :=
4973 Expr_Value
4977 and then
4979 then
4985 Right_Opnd =>
4998 --------------------------
4999 -- Expand_N_Op_Multiply --
5000 --------------------------
5019 begin
5022 -- Special optimizations for integer types
5026 -- N * 0 = 0 * N = 0 for integer types
5030 or else
5033 then
5039 -- N * 1 = 1 * N = N for integer types
5041 -- This optimisation is not done if we are going to
5042 -- rewrite the product 1 * 2 ** N to a shift.
5046 and then not Lp2
5047 then
5053 and then not Rp2
5054 then
5060 -- Deal with VAX float case
5067 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5068 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5069 -- operand is an integer, as required for this to work.
5074 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
5079 Right_Opnd =>
5086 else
5090 Right_Opnd =>
5096 -- Same processing for the operands the other way round
5102 Right_Opnd =>
5108 -- Do required fixup of universal fixed operation
5115 -- Multiplications with fixed-point results
5119 -- No special processing if Treat_Fixed_As_Integer is set,
5120 -- since from a semantic point of view such operations are
5121 -- simply integer operations and will be treated that way.
5125 -- Case of fixed * integer => fixed
5130 -- Case of integer * fixed => fixed
5135 -- Case of fixed * fixed => fixed
5137 else
5142 -- Other cases of multiplication of fixed-point operands. Again
5143 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
5147 then
5150 else
5155 -- Mixed-mode operations can appear in a non-static universal
5156 -- context, in which case the integer argument must be converted
5157 -- explicitly.
5161 then
5168 then
5173 -- Non-fixed point cases, check software overflow checking required
5180 --------------------
5181 -- Expand_N_Op_Ne --
5182 --------------------
5184 -- Rewrite node as the negation of an equality operation, and reanalyze.
5185 -- The equality to be used is defined in the same scope and has the same
5186 -- signature. It must be set explicitly because in an instance it may not
5187 -- have the same visibility as in the generic unit.
5194 begin
5197 Neg :=
5199 Right_Opnd =>
5209 -- For navigation purposes, the inequality is treated as an implicit
5210 -- reference to the corresponding equality. Preserve the Comes_From_
5211 -- source flag so that the proper Xref entry is generated.
5219 ---------------------
5220 -- Expand_N_Op_Not --
5221 ---------------------
5223 -- If the argument is other than a Boolean array type, there is no
5224 -- special expansion required.
5226 -- For the packed case, we call the special routine in Exp_Pakd, except
5227 -- that if the component size is greater than one, we use the standard
5228 -- routine generating a gruesome loop (it is so peculiar to have packed
5229 -- arrays with non-standard Boolean representations anyway, so it does
5230 -- not matter that we do not handle this case efficiently).
5232 -- For the unpacked case (and for the special packed case where we have
5233 -- non standard Booleans, as discussed above), we generate and insert
5234 -- into the tree the following function definition:
5236 -- function Nnnn (A : arr) is
5237 -- B : arr;
5238 -- begin
5239 -- for J in a'range loop
5240 -- B (J) := not A (J);
5241 -- end loop;
5242 -- return B;
5243 -- end Nnnn;
5245 -- Here arr is the actual subtype of the parameter (and hence always
5246 -- constrained). Then we replace the not with a call to this function.
5262 begin
5265 -- For boolean operand, deal with non-standard booleans
5274 -- Only array types need any other processing
5280 -- Case of array operand. If bit packed, handle it in Exp_Pakd
5287 -- Case of array operand which is not bit-packed. If the context is
5288 -- a safe assignment, call in-place operation, If context is a larger
5289 -- boolean expression in the context of a safe assignment, expansion is
5290 -- done by enclosing operation.
5302 -- Special case the negation of a binary operation
5307 and then Safe_In_Place_Array_Op
5309 then
5316 then
5317 declare
5322 begin
5326 then
5327 -- (not A) op (not B) can be reduced to a single call
5333 then
5334 -- A xor (not B) can also be special-cased
5346 A_J :=
5351 B_J :=
5356 Loop_Statement :=
5360 Iteration_Scheme =>
5362 Loop_Parameter_Specification =>
5365 Discrete_Subtype_Definition =>
5380 Specification =>
5394 Handled_Statement_Sequence =>
5397 Loop_Statement,
5399 Expression =>
5410 --------------------
5411 -- Expand_N_Op_Or --
5412 --------------------
5417 begin
5431 ----------------------
5432 -- Expand_N_Op_Plus --
5433 ----------------------
5436 begin
5440 ---------------------
5441 -- Expand_N_Op_Rem --
5442 ---------------------
5459 begin
5466 -- Apply optimization x rem 1 = 0. We don't really need that with
5467 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5468 -- certainly harmless.
5473 then
5479 -- Deal with annoying case of largest negative number remainder
5480 -- minus one. Gigi does not handle this case correctly, because
5481 -- it generates a divide instruction which may trap in this case.
5483 -- In fact the check is quite easy, if the right operand is -1,
5484 -- then the remainder is always 0, and we can just ignore the
5485 -- left operand completely in this case.
5490 -- The operand type may be private (e.g. in the expansion of an
5491 -- an intrinsic operation) so we must use the underlying type to
5492 -- get the bounds, and convert the literals explicitly.
5494 LLB :=
5495 Expr_Value
5498 -- Now perform the test, generating code only if needed
5501 and then
5503 then
5509 Right_Opnd =>
5523 -----------------------------
5524 -- Expand_N_Op_Rotate_Left --
5525 -----------------------------
5528 begin
5532 ------------------------------
5533 -- Expand_N_Op_Rotate_Right --
5534 ------------------------------
5537 begin
5541 ----------------------------
5542 -- Expand_N_Op_Shift_Left --
5543 ----------------------------
5546 begin
5550 -----------------------------
5551 -- Expand_N_Op_Shift_Right --
5552 -----------------------------
5555 begin
5559 ----------------------------------------
5560 -- Expand_N_Op_Shift_Right_Arithmetic --
5561 ----------------------------------------
5564 begin
5568 --------------------------
5569 -- Expand_N_Op_Subtract --
5570 --------------------------
5575 begin
5578 -- N - 0 = N for integer types
5583 then
5588 -- Arithemtic overflow checks for signed integer/fixed point types
5592 then
5595 -- Vax floating-point types case
5602 ---------------------
5603 -- Expand_N_Op_Xor --
5604 ---------------------
5609 begin
5623 ----------------------
5624 -- Expand_N_Or_Else --
5625 ----------------------
5627 -- Expand into conditional expression if Actions present, and also
5628 -- deal with optimizing case of arguments being True or False.
5637 begin
5638 -- Deal with non-standard booleans
5646 -- Check for cases of left argument is True or False
5650 -- If left argument is False, change (False or else Right) to Right.
5651 -- Any actions associated with Right will be executed unconditionally
5652 -- and can thus be inserted into the tree unconditionally.
5663 -- If left argument is True, change (True and then Right) to
5664 -- True. In this case we can forget the actions associated with
5665 -- Right, since they will never be executed.
5676 -- If Actions are present, we expand
5678 -- left or else right
5680 -- into
5682 -- if left then True else right end
5684 -- with the actions becoming the Else_Actions of the conditional
5685 -- expression. This conditional expression is then further expanded
5686 -- (and will eventually disappear)
5693 Left,
5695 Right)));
5703 -- No actions present, check for cases of right argument True/False
5707 -- Change (Left or else False) to Left. Note that we know there
5708 -- are no actions associated with the True operand, since we
5709 -- just checked for this case above.
5714 -- Change (Left or else True) to True, making sure to preserve
5715 -- any side effects associated with the Left operand.
5719 Rewrite
5727 -----------------------------------
5728 -- Expand_N_Qualified_Expression --
5729 -----------------------------------
5735 begin
5739 ---------------------------------
5740 -- Expand_N_Selected_Component --
5741 ---------------------------------
5743 -- If the selector is a discriminant of a concurrent object, rewrite the
5744 -- prefix to denote the corresponding record type.
5756 -- Gigi needs a temporary for prefixes that depend on a discriminant,
5757 -- unless the context of an assignment can provide size information.
5758 -- Don't we have a general routine that does this???
5760 -----------------------
5761 -- In_Left_Hand_Side --
5762 -----------------------
5765 begin
5773 -- Start of processing for Expand_N_Selected_Component
5775 begin
5776 -- Insert explicit dereference if required
5784 then
5791 -- Deal with discriminant check required
5795 -- Present the discrminant checking function to the backend,
5796 -- so that it can inline the call to the function.
5798 Add_Inlined_Body
5799 (Discriminant_Checking_Func
5802 -- Now reset the flag and generate the call
5808 -- Gigi cannot handle unchecked conversions that are the prefix of a
5809 -- selected component with discriminants. This must be checked during
5810 -- expansion, because during analysis the type of the selector is not
5811 -- known at the point the prefix is analyzed. If the conversion is the
5812 -- target of an assignment, then we cannot force the evaluation.
5817 then
5821 -- Remaining processing applies only if selector is a discriminant
5825 -- If the selector is a discriminant of a constrained record type,
5826 -- we may be able to rewrite the expression with the actual value
5827 -- of the discriminant, a useful optimization in some cases.
5832 then
5833 -- Do this optimization for discrete types only, and not for
5834 -- access types (access discriminants get us into trouble!)
5839 -- Don't do this on the left hand of an assignment statement.
5840 -- Normally one would think that references like this would
5841 -- not occur, but they do in generated code, and mean that
5842 -- we really do want to assign the discriminant!
5846 then
5849 -- Don't do this optimization for the prefix of an attribute
5850 -- or the operand of an object renaming declaration since these
5851 -- are contexts where we do not want the value anyway.
5856 then
5859 -- Don't do this optimization if we are within the code for a
5860 -- discriminant check, since the whole point of such a check may
5861 -- be to verify the condition on which the code below depends!
5866 -- Green light to see if we can do the optimization. There is
5867 -- still one condition that inhibits the optimization below
5868 -- but now is the time to check the particular discriminant.
5870 else
5871 -- Loop through discriminants to find the matching
5872 -- discriminant constraint to see if we can copy it.
5878 -- Check if this is the matching discriminant
5882 -- Here we have the matching discriminant. Check for
5883 -- the case of a discriminant of a component that is
5884 -- constrained by an outer discriminant, which cannot
5885 -- be optimized away.
5887 if
5888 Denotes_Discriminant
5890 then
5893 -- In the context of a case statement, the expression
5894 -- may have the base type of the discriminant, and we
5895 -- need to preserve the constraint to avoid spurious
5896 -- errors on missing cases.
5900 then
5903 Subtype_Mark =>
5905 Expression =>
5909 -- In case that comes out as a static expression,
5910 -- reset it (a selected component is never static).
5915 -- Otherwise we can just copy the constraint, but the
5916 -- result is certainly not static! In some cases the
5917 -- discriminant constraint has been analyzed in the
5918 -- context of the original subtype indication, but for
5919 -- itypes the constraint might not have been analyzed
5920 -- yet, and this must be done now.
5922 else
5934 -- Note: the above loop should always find a matching
5935 -- discriminant, but if it does not, we just missed an
5936 -- optimization due to some glitch (perhaps a previous
5937 -- error), so ignore.
5942 -- The only remaining processing is in the case of a discriminant of
5943 -- a concurrent object, where we rewrite the prefix to denote the
5944 -- corresponding record type. If the type is derived and has renamed
5945 -- discriminants, use corresponding discriminant, which is the one
5946 -- that appears in the corresponding record.
5956 then
5960 New_N :=
5962 Prefix =>
5972 --------------------
5973 -- Expand_N_Slice --
5974 --------------------
5983 -- Check whether the argument is an actual for a procedure call,
5984 -- in which case the expansion of a bit-packed slice is deferred
5985 -- until the call itself is expanded. The reason this is required
5986 -- is that we might have an IN OUT or OUT parameter, and the copy out
5987 -- is essential, and that copy out would be missed if we created a
5988 -- temporary here in Expand_N_Slice. Note that we don't bother
5989 -- to test specifically for an IN OUT or OUT mode parameter, since it
5990 -- is a bit tricky to do, and it is harmless to defer expansion
5991 -- in the IN case, since the call processing will still generate the
5992 -- appropriate copy in operation, which will take care of the slice.
5995 -- Create a named variable for the value of the slice, in
5996 -- cases where the back-end cannot handle it properly, e.g.
5997 -- when packed types or unaligned slices are involved.
5999 -------------------------
6000 -- Is_Procedure_Actual --
6001 -------------------------
6006 begin
6007 loop
6008 -- If our parent is a procedure call we can return
6013 -- If our parent is a type conversion, keep climbing the
6014 -- tree, since a type conversion can be a procedure actual.
6015 -- Also keep climbing if parameter association or a qualified
6016 -- expression, since these are additional cases that do can
6017 -- appear on procedure actuals.
6022 then
6025 -- Any other case is not what we are looking for
6027 else
6033 --------------------
6034 -- Make_Temporary --
6035 --------------------
6041 begin
6042 Decl :=
6050 Decl,
6059 -- Start of processing for Expand_N_Slice
6061 begin
6062 -- Special handling for access types
6075 -- Range checks are potentially also needed for cases involving
6076 -- a slice indexed by a subtype indication, but Do_Range_Check
6077 -- can currently only be set for expressions ???
6083 then
6087 -- The remaining case to be handled is packed slices. We can leave
6088 -- packed slices as they are in the following situations:
6090 -- 1. Right or left side of an assignment (we can handle this
6091 -- situation correctly in the assignment statement expansion).
6093 -- 2. Prefix of indexed component (the slide is optimized away
6094 -- in this case, see the start of Expand_N_Slice.
6096 -- 3. Object renaming declaration, since we want the name of
6097 -- the slice, not the value.
6099 -- 4. Argument to procedure call, since copy-in/copy-out handling
6100 -- may be required, and this is handled in the expansion of
6101 -- call itself.
6103 -- 5. Prefix of an address attribute (this is an error which
6104 -- is caught elsewhere, and the expansion would intefere
6105 -- with generating the error message).
6109 -- Apply transformation for actuals of a function call,
6110 -- where Expand_Actuals is not used.
6114 then
6115 Make_Temporary;
6121 then
6127 then
6132 then
6135 else
6136 Make_Temporary;
6140 ------------------------------
6141 -- Expand_N_Type_Conversion --
6142 ------------------------------
6151 -- This is called in the case of record and array type conversions
6152 -- to see if there is a change of representation to be handled.
6153 -- Change of representation is actually handled at the assignment
6154 -- statement level, and what this procedure does is rewrite node N
6155 -- conversion as an assignment to temporary. If there is no change
6156 -- of representation, then the conversion node is unchanged.
6159 -- Handles generation of range check for real target value
6161 -----------------------------------
6162 -- Handle_Changed_Representation --
6163 -----------------------------------
6173 begin
6174 -- Nothing to do if no change of representation
6179 -- The real change of representation work is done by the assignment
6180 -- statement processing. So if this type conversion is appearing as
6181 -- the expression of an assignment statement, nothing needs to be
6182 -- done to the conversion.
6187 -- Otherwise we need to generate a temporary variable, and do the
6188 -- change of representation assignment into that temporary variable.
6189 -- The conversion is then replaced by a reference to this variable.
6191 else
6194 -- If type is unconstrained we have to add a constraint,
6195 -- copied from the actual value of the left hand side.
6210 Selector_Name =>
6221 -- We convert the bounds explicitly. We use an unchecked
6222 -- conversion because bounds checks are done elsewhere.
6226 Low_Bound =>
6229 Prefix =>
6230 Duplicate_Subexpr_No_Checks
6236 High_Bound =>
6239 Prefix =>
6240 Duplicate_Subexpr_No_Checks
6254 Odef :=
6257 Constraint =>
6263 Decl :=
6270 -- Insert required actions. It is essential to suppress checks
6271 -- since we have suppressed default initialization, which means
6272 -- that the variable we create may have no discriminants.
6275 New_List (
6276 Decl,
6287 ----------------------
6288 -- Real_Range_Check --
6289 ----------------------
6291 -- Case of conversions to floating-point or fixed-point. If range
6292 -- checks are enabled and the target type has a range constraint,
6293 -- we convert:
6295 -- typ (x)
6297 -- to
6299 -- Tnn : typ'Base := typ'Base (x);
6300 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
6301 -- Tnn
6303 -- This is necessary when there is a conversion of integer to float
6304 -- or to fixed-point to ensure that the correct checks are made. It
6305 -- is not necessary for float to float where it is enough to simply
6306 -- set the Do_Range_Check flag.
6316 begin
6317 -- Nothing to do if conversion was rewritten
6323 -- Nothing to do if range checks suppressed, or target has the
6324 -- same range as the base type (or is the base type).
6328 and then
6330 then
6334 -- Nothing to do if expression is an entity on which checks
6335 -- have been suppressed.
6339 then
6343 -- Nothing to do if bounds are all static and we can tell that
6344 -- the expression is within the bounds of the target. Note that
6345 -- if the operand is of an unconstrained floating-point type,
6346 -- then we do not trust it to be in range (might be infinite)
6348 declare
6352 begin
6359 then
6360 declare
6366 begin
6370 else
6378 then
6386 -- For float to float conversions, we are done
6389 and then
6391 then
6395 -- Otherwise rewrite the conversion as described above
6398 Rewrite
6402 -- Enable overflow except in the case of integer to float
6403 -- conversions, where it is never required, since we can
6404 -- never have overflow in this case.
6410 Tnn :=
6421 Condition =>
6423 Left_Opnd =>
6426 Right_Opnd =>
6429 Prefix =>
6432 Right_Opnd =>
6435 Right_Opnd =>
6438 Prefix =>
6446 -- Start of processing for Expand_N_Type_Conversion
6448 begin
6449 -- Nothing at all to do if conversion is to the identical type
6450 -- so remove the conversion completely, it is useless.
6457 -- Deal with Vax floating-point cases
6464 -- Nothing to do if this is the second argument of read. This
6465 -- is a "backwards" conversion that will be handled by the
6466 -- specialized code in attribute processing.
6471 then
6475 -- Here if we may need to expand conversion
6477 -- Special case of converting from non-standard boolean type
6481 then
6487 -- Case of converting to an access type
6491 -- Apply an accessibility check if the operand is an
6492 -- access parameter. Note that other checks may still
6493 -- need to be applied below (such as tagged type checks).
6498 then
6501 -- If the level of the operand type is statically deeper
6502 -- then the level of the target type, then force Program_Error.
6503 -- Note that this can only occur for cases where the attribute
6504 -- is within the body of an instantiation (otherwise the
6505 -- conversion will already have been rejected as illegal).
6506 -- Note: warnings are issued by the analyzer for the instance
6507 -- cases.
6509 elsif In_Instance_Body
6512 then
6518 -- When the operand is a selected access discriminant
6519 -- the check needs to be made against the level of the
6520 -- object denoted by the prefix of the selected name.
6521 -- Force Program_Error for this case as well (this
6522 -- accessibility violation can only happen if within
6523 -- the body of an instantiation).
6525 elsif In_Instance_Body
6530 then
6538 -- Case of conversions of tagged types and access to tagged types
6540 -- When needed, that is to say when the expression is class-wide,
6541 -- Add runtime a tag check for (strict) downward conversion by using
6542 -- the membership test, generating:
6544 -- [constraint_error when Operand not in Target_Type'Class]
6546 -- or in the access type case
6548 -- [constraint_error
6549 -- when Operand /= null
6550 -- and then Operand.all not in
6551 -- Designated_Type (Target_Type)'Class]
6556 then
6557 -- Do not do any expansion in the access type case if the
6558 -- parent is a renaming, since this is an error situation
6559 -- which will be caught by Sem_Ch8, and the expansion can
6560 -- intefere with this error check.
6564 then
6568 -- Oherwise, proceed with processing tagged conversion
6570 declare
6576 begin
6581 else
6588 and then Is_Ancestor
6590 Actual_Target_Type)
6592 then
6593 -- The conversion is valid for any descendant of the
6594 -- target type
6599 Cond :=
6601 Left_Opnd =>
6606 Right_Opnd =>
6608 Left_Opnd =>
6610 Prefix =>
6612 Right_Opnd =>
6615 else
6616 Cond :=
6619 Right_Opnd =>
6628 declare
6630 begin
6631 Conv :=
6641 -- Case of other access type conversions
6646 -- Case of conversions from a fixed-point type
6648 -- These conversions require special expansion and processing, found
6649 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
6650 -- set, since from a semantic point of view, these are simple integer
6651 -- conversions, which do not need further processing.
6655 then
6656 -- We should never see universal fixed at this case, since the
6657 -- expansion of the constituent divide or multiply should have
6658 -- eliminated the explicit mention of universal fixed.
6662 -- Check for special case of the conversion to universal real
6663 -- that occurs as a result of the use of a round attribute.
6664 -- In this case, the real type for the conversion is taken
6665 -- from the target type of the Round attribute and the
6666 -- result must be marked as rounded.
6671 then
6676 -- Otherwise do correct fixed-conversion, but skip these if the
6677 -- Conversion_OK flag is set, because from a semantic point of
6678 -- view these are simple integer conversions needing no further
6679 -- processing (the backend will simply treat them as integers)
6684 Real_Range_Check;
6689 else
6692 Real_Range_Check;
6696 -- Case of conversions to a fixed-point type
6698 -- These conversions require special expansion and processing, found
6699 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6700 -- is set, since from a semantic point of view, these are simple
6701 -- integer conversions, which do not need further processing.
6705 then
6708 Real_Range_Check;
6709 else
6712 Real_Range_Check;
6715 -- Case of float-to-integer conversions
6717 -- We also handle float-to-fixed conversions with Conversion_OK set
6718 -- since semantically the fixed-point target is treated as though it
6719 -- were an integer in such cases.
6722 and then
6724 or else
6726 then
6727 -- Special processing required if the conversion is the expression
6728 -- of a Truncation attribute reference. In this case we replace:
6730 -- ityp (ftyp'Truncation (x))
6732 -- by
6734 -- ityp (x)
6736 -- with the Float_Truncate flag set. This is clearly more efficient
6740 then
6746 -- One more check here, gcc is still not able to do conversions of
6747 -- this type with proper overflow checking, and so gigi is doing an
6748 -- approximation of what is required by doing floating-point compares
6749 -- with the end-point. But that can lose precision in some cases, and
6750 -- give a wrong result. Converting the operand to Long_Long_Float is
6751 -- helpful, but still does not catch all cases with 64-bit integers
6752 -- on targets with only 64-bit floats ???
6757 Subtype_Mark =>
6759 Expression =>
6767 -- Case of array conversions
6769 -- Expansion of array conversions, add required length/range checks
6770 -- but only do this if there is no change of representation. For
6771 -- handling of this case, see Handle_Changed_Representation.
6777 else
6781 Handle_Changed_Representation;
6783 -- Case of conversions of discriminated types
6785 -- Add required discriminant checks if target is constrained. Again
6786 -- this change is skipped if we have a change of representation.
6790 then
6792 Handle_Changed_Representation;
6794 -- Case of all other record conversions. The only processing required
6795 -- is to check for a change of representation requiring the special
6796 -- assignment processing.
6800 -- Ada 2005 (AI-216): Program_Error is raised when converting from
6801 -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
6802 -- Union type if the operand lacks inferable discriminants.
6809 then
6810 -- To prevent Gigi from generating illegal code, we make a
6811 -- Program_Error node, but we give it the target type of the
6812 -- conversion.
6814 declare
6818 begin
6823 else
6824 Handle_Changed_Representation;
6827 -- Case of conversions of enumeration types
6831 -- Special processing is required if there is a change of
6832 -- representation (from enumeration representation clauses)
6836 -- Convert: x(y) to x'val (ytyp'val (y))
6851 -- Case of conversions to floating-point
6854 Real_Range_Check;
6856 -- The remaining cases require no front end processing
6858 else
6862 -- At this stage, either the conversion node has been transformed
6863 -- into some other equivalent expression, or left as a conversion
6864 -- that can be handled by Gigi. The conversions that Gigi can handle
6865 -- are the following:
6867 -- Conversions with no change of representation or type
6869 -- Numeric conversions involving integer values, floating-point
6870 -- values, and fixed-point values. Fixed-point values are allowed
6871 -- only if Conversion_OK is set, i.e. if the fixed-point values
6872 -- are to be treated as integers.
6874 -- No other conversions should be passed to Gigi
6876 -- Check: are these rules stated in sinfo??? if so, why restate here???
6878 -- The only remaining step is to generate a range check if we still
6879 -- have a type conversion at this stage and Do_Range_Check is set.
6880 -- For now we do this only for conversions of discrete types.
6884 then
6885 declare
6890 begin
6893 then
6896 -- Before we do a range check, we have to deal with treating
6897 -- a fixed-point operand as an integer. The way we do this
6898 -- is simply to do an unchecked conversion to an appropriate
6899 -- integer type large enough to hold the result.
6901 -- This code is not active yet, because we are only dealing
6902 -- with discrete types so far ???
6906 then
6911 else
6918 -- Reset overflow flag, since the range check will include
6919 -- dealing with possible overflow, and generate the check
6920 -- If Address is either source or target type, suppress
6921 -- range check to avoid typing anomalies when it is a visible
6922 -- integer type.
6927 then
6928 Generate_Range_Check
6936 -----------------------------------
6937 -- Expand_N_Unchecked_Expression --
6938 -----------------------------------
6940 -- Remove the unchecked expression node from the tree. It's job was simply
6941 -- to make sure that its constituent expression was handled with checks
6942 -- off, and now that that is done, we can remove it from the tree, and
6943 -- indeed must, since gigi does not expect to see these nodes.
6948 begin
6953 ----------------------------------------
6954 -- Expand_N_Unchecked_Type_Conversion --
6955 ----------------------------------------
6957 -- If this cannot be handled by Gigi and we haven't already made
6958 -- a temporary for it, do it now.
6965 begin
6966 -- If we have a conversion of a compile time known value to a target
6967 -- type and the value is in range of the target type, then we can simply
6968 -- replace the construct by an integer literal of the correct type. We
6969 -- only apply this to integer types being converted. Possibly it may
6970 -- apply in other cases, but it is too much trouble to worry about.
6972 -- Note that we do not do this transformation if the Kill_Range_Check
6973 -- flag is set, since then the value may be outside the expected range.
6974 -- This happens in the Normalize_Scalars case.
6980 then
6981 declare
6984 begin
6986 and then
6988 and then
6990 and then
6992 then
6995 -- If Address is the target type, just set the type
6996 -- to avoid a spurious type error on the literal when
6997 -- Address is a visible integer type.
7001 else
7010 -- Nothing to do if conversion is safe
7016 -- Otherwise force evaluation unless Assignment_OK flag is set (this
7017 -- flag indicates ??? -- more comments needed here)
7021 else
7026 ----------------------------
7027 -- Expand_Record_Equality --
7028 ----------------------------
7030 -- For non-variant records, Equality is expanded when needed into:
7032 -- and then Lhs.Discr1 = Rhs.Discr1
7033 -- and then ...
7034 -- and then Lhs.Discrn = Rhs.Discrn
7035 -- and then Lhs.Cmp1 = Rhs.Cmp1
7036 -- and then ...
7037 -- and then Lhs.Cmpn = Rhs.Cmpn
7039 -- The expression is folded by the back-end for adjacent fields. This
7040 -- function is called for tagged record in only one occasion: for imple-
7041 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
7042 -- otherwise the primitive "=" is used directly.
7044 function Expand_Record_Equality
7050 is
7059 -- Return the first field to compare beginning with C, skipping the
7060 -- inherited components.
7062 ----------------------
7063 -- Suitable_Element --
7064 ----------------------
7067 begin
7073 then
7078 then
7083 then
7086 else
7091 -- Start of processing for Expand_Record_Equality
7093 begin
7094 -- Generates the following code: (assuming that Typ has one Discr and
7095 -- component C2 is also a record)
7097 -- True
7098 -- and then Lhs.Discr1 = Rhs.Discr1
7099 -- and then Lhs.C1 = Rhs.C1
7100 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
7101 -- and then ...
7102 -- and then Lhs.Cmpn = Rhs.Cmpn
7108 declare
7112 begin
7117 else
7122 Result :=
7125 Right_Opnd =>
7127 Lhs =>
7131 Rhs =>
7144 -------------------------------------
7145 -- Fixup_Universal_Fixed_Operation --
7146 -------------------------------------
7151 begin
7152 -- We must have a type conversion immediately above us
7156 -- Normally the type conversion gives our target type. The exception
7157 -- occurs in the case of the Round attribute, where the conversion
7158 -- will be to universal real, and our real type comes from the Round
7159 -- attribute (as well as an indication that we must round the result)
7163 then
7167 -- Normal case where type comes from conversion above us
7169 else
7174 ------------------------------
7175 -- Get_Allocator_Final_List --
7176 ------------------------------
7178 function Get_Allocator_Final_List
7182 is
7186 -- The entity whose finalisation list must be used to attach the
7187 -- allocated object.
7189 begin
7192 in N_Subprogram_Specification
7193 then
7194 -- If the context is an access parameter, we need to create
7195 -- a non-anonymous access type in order to have a usable
7196 -- final list, because there is otherwise no pool to which
7197 -- the allocated object can belong. We create both the type
7198 -- and the finalization chain here, because freezing an
7199 -- internal type does not create such a chain. The Final_Chain
7200 -- that is thus created is shared by the access parameter.
7206 Type_Definition =>
7208 Subtype_Indication =>
7214 else
7215 -- Case of an access discriminant, or (Ada 2005) of
7216 -- an anonymous access component: find the final list
7217 -- associated with the scope of the type.
7226 ---------------------------------
7227 -- Has_Inferable_Discriminants --
7228 ---------------------------------
7233 -- Determines whether the left-most prefix of a selected component is a
7234 -- formal parameter in a subprogram. Assumes N is a selected component.
7236 --------------------------------
7237 -- Prefix_Is_Formal_Parameter --
7238 --------------------------------
7243 begin
7244 -- Move to the left-most prefix by climbing up the tree
7248 loop
7255 -- Start of processing for Has_Inferable_Discriminants
7257 begin
7258 -- For identifiers and indexed components, it is sufficent to have a
7259 -- constrained Unchecked_Union nominal subtype.
7262 or else
7264 then
7266 and then
7269 -- For selected components, the subtype of the selector must be a
7270 -- constrained Unchecked_Union. If the component is subject to a
7271 -- per-object constraint, then the enclosing object must have inferable
7272 -- discriminants.
7277 -- A small hack. If we have a per-object constrained selected
7278 -- component of a formal parameter, return True since we do not
7279 -- know the actual parameter association yet.
7285 -- Otherwise, check the enclosing object and the selector
7288 and then
7292 -- The call to Has_Inferable_Discriminants will determine whether
7293 -- the selector has a constrained Unchecked_Union nominal type.
7297 -- A qualified expression has inferable discriminants if its subtype
7298 -- mark is a constrained Unchecked_Union subtype.
7302 and then
7310 -------------------------------
7311 -- Insert_Dereference_Action --
7312 -------------------------------
7321 -- Return true if type of P is derived from Checked_Pool;
7323 -----------------------------
7324 -- Is_Checked_Storage_Pool --
7325 -----------------------------
7330 begin
7339 else
7347 -- Start of processing for Insert_Dereference_Action
7349 begin
7354 then
7365 -- Pool
7369 -- Storage_Address. We use the attribute Pool_Address,
7370 -- which uses the pointer itself to find the address of
7371 -- the object, and which handles unconstrained arrays
7372 -- properly by computing the address of the template.
7373 -- i.e. the correct address of the corresponding allocation.
7379 -- Size_In_Storage_Elements
7382 Left_Opnd =>
7384 Prefix =>
7388 Right_Opnd =>
7391 -- Alignment
7394 Prefix =>
7399 exception
7404 ------------------------------
7405 -- Make_Array_Comparison_Op --
7406 ------------------------------
7408 -- This is a hand-coded expansion of the following generic function:
7410 -- generic
7411 -- type elem is (<>);
7412 -- type index is (<>);
7413 -- type a is array (index range <>) of elem;
7414 --
7415 -- function Gnnn (X : a; Y: a) return boolean is
7416 -- J : index := Y'first;
7417 --
7418 -- begin
7419 -- if X'length = 0 then
7420 -- return false;
7421 --
7422 -- elsif Y'length = 0 then
7423 -- return true;
7424 --
7425 -- else
7426 -- for I in X'range loop
7427 -- if X (I) = Y (J) then
7428 -- if J = Y'last then
7429 -- exit;
7430 -- else
7431 -- J := index'succ (J);
7432 -- end if;
7433 --
7434 -- else
7435 -- return X (I) > Y (J);
7436 -- end if;
7437 -- end loop;
7438 --
7439 -- return X'length > Y'length;
7440 -- end if;
7441 -- end Gnnn;
7443 -- Note that since we are essentially doing this expansion by hand, we
7444 -- do not need to generate an actual or formal generic part, just the
7445 -- instantiated function itself.
7447 function Make_Array_Comparison_Op
7450 is
7471 begin
7472 -- if J = Y'last then
7473 -- exit;
7474 -- else
7475 -- J := index'succ (J);
7476 -- end if;
7478 Inner_If :=
7480 Condition =>
7483 Right_Opnd =>
7491 Else_Statements =>
7492 New_List (
7495 Expression =>
7501 -- if X (I) = Y (J) then
7502 -- if ... end if;
7503 -- else
7504 -- return X (I) > Y (J);
7505 -- end if;
7507 Loop_Body :=
7509 Condition =>
7511 Left_Opnd =>
7516 Right_Opnd =>
7525 Expression =>
7527 Left_Opnd =>
7532 Right_Opnd =>
7538 -- for I in X'range loop
7539 -- if ... end if;
7540 -- end loop;
7542 Loop_Statement :=
7546 Iteration_Scheme =>
7548 Loop_Parameter_Specification =>
7551 Discrete_Subtype_Definition =>
7558 -- if X'length = 0 then
7559 -- return false;
7560 -- elsif Y'length = 0 then
7561 -- return true;
7562 -- else
7563 -- for ... loop ... end loop;
7564 -- return X'length > Y'length;
7565 -- end if;
7567 Length1 :=
7572 Length2 :=
7577 Final_Expr :=
7582 If_Stat :=
7584 Condition =>
7586 Left_Opnd =>
7590 Right_Opnd =>
7593 Then_Statements =>
7594 New_List (
7600 Condition =>
7602 Left_Opnd =>
7606 Right_Opnd =>
7609 Then_Statements =>
7610 New_List (
7615 Loop_Statement,
7619 -- (X : a; Y: a)
7630 -- function Gnnn (...) return boolean is
7631 -- J : index := Y'first;
7632 -- begin
7633 -- if ... end if;
7634 -- end Gnnn;
7638 Func_Body :=
7640 Specification =>
7650 Expression =>
7655 Handled_Statement_Sequence =>
7663 ---------------------------
7664 -- Make_Boolean_Array_Op --
7665 ---------------------------
7667 -- For logical operations on boolean arrays, expand in line the
7668 -- following, replacing 'and' with 'or' or 'xor' where needed:
7670 -- function Annn (A : typ; B: typ) return typ is
7671 -- C : typ;
7672 -- begin
7673 -- for J in A'range loop
7674 -- C (J) := A (J) op B (J);
7675 -- end loop;
7676 -- return C;
7677 -- end Annn;
7679 -- Here typ is the boolean array type
7681 function Make_Boolean_Array_Op
7684 is
7702 begin
7703 A_J :=
7708 B_J :=
7713 C_J :=
7719 Op :=
7725 Op :=
7730 else
7731 Op :=
7737 Loop_Statement :=
7741 Iteration_Scheme =>
7743 Loop_Parameter_Specification =>
7746 Discrete_Subtype_Definition =>
7765 Func_Name :=
7769 Func_Body :=
7771 Specification =>
7782 Handled_Statement_Sequence =>
7785 Loop_Statement,
7792 ------------------------
7793 -- Rewrite_Comparison --
7794 ------------------------
7802 -- Res indicates if compare outcome can be determined at compile time
7807 begin
7848 ----------------------------
7849 -- Safe_In_Place_Array_Op --
7850 ----------------------------
7852 function Safe_In_Place_Array_Op
7856 is
7860 -- Operand is safe if it cannot overlap part of the target of the
7861 -- operation. If the operand and the target are identical, the operand
7862 -- is safe. The operand can be empty in the case of negation.
7865 -- Check that N is a stand-alone entity
7867 ------------------
7868 -- Is_Unaliased --
7869 ------------------
7872 begin
7873 return
7879 ---------------------
7880 -- Is_Safe_Operand --
7881 ---------------------
7884 begin
7893 then
7897 return
7904 else
7909 -- Start of processing for Is_Safe_In_Place_Array_Op
7911 begin
7912 -- We skip this processing if the component size is not the
7913 -- same as a system storage unit (since at least for NOT
7914 -- this would cause problems).
7919 -- Cannot do in place stuff on Java_VM since cannot pass addresses
7924 -- Cannot do in place stuff if non-standard Boolean representation
7931 else
7934 return
7940 -----------------------
7941 -- Tagged_Membership --
7942 -----------------------
7944 -- There are two different cases to consider depending on whether
7945 -- the right operand is a class-wide type or not. If not we just
7946 -- compare the actual tag of the left expr to the target type tag:
7947 --
7948 -- Left_Expr.Tag = Right_Type'Tag;
7949 --
7950 -- If it is a class-wide type we use the RT function CW_Membership which
7951 -- is usually implemented by looking in the ancestor tables contained in
7952 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
7963 begin
7971 Obj_Tag :=
7977 return
7981 Obj_Tag,
7982 New_Reference_To (
7984 else
7985 return
7988 Right_Opnd =>
7994 ------------------------------
7995 -- Unary_Op_Validity_Checks --
7996 ------------------------------
7999 begin