| blob | fd03a08b41129434cc3cd8de0511d6460c02a1e4 |
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-2005, 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 -- If some (sub)component is an unchecked_union, the whole
1067 -- operation will raise program error.
1072 else
1073 return
1082 ------------------
1083 -- Get_Arg_Type --
1084 ------------------
1090 begin
1096 else
1102 or else
1104 then
1116 --------------------------
1117 -- Handle_One_Dimension --
1118 ---------------------------
1120 function Handle_One_Dimension
1123 is
1125 Ltyp /= Rtyp
1127 -- If the index types are identical, and we are working with
1128 -- constrained types, then we can use the same index for both of
1129 -- the arrays.
1139 begin
1144 -- Case where we generate a loop
1149 Bn :=
1152 else
1163 -- Generate guard for loop, followed by increments of indices
1167 Condition =>
1175 Expression =>
1184 Expression =>
1191 -- If separate indexes, we need a declare block for An and Bn,
1192 -- and a loop without an iteration scheme.
1195 Loop_Stm :=
1198 return
1211 Handled_Statement_Sequence =>
1215 -- If no separate indexes, return loop statement with explicit
1216 -- iteration scheme on its own
1218 else
1219 Loop_Stm :=
1222 Iteration_Scheme =>
1224 Loop_Parameter_Specification =>
1227 Discrete_Subtype_Definition =>
1233 -----------------------
1234 -- Test_Empty_Arrays --
1235 -----------------------
1244 begin
1248 Atest :=
1253 Btest :=
1262 else
1263 Alist :=
1268 Blist :=
1275 return
1281 -----------------------------
1282 -- Test_Lengths_Correspond --
1283 -----------------------------
1289 begin
1292 Rtest :=
1299 else
1300 Result :=
1310 -- Start of processing for Expand_Array_Equality
1312 begin
1316 -- For now, if the argument types are not the same, go to the
1317 -- base type, since the code assumes that the formals have the
1318 -- same type. This is fixable in future ???
1326 -- Build list of formals for function
1339 -- Build statement sequence for function
1341 Func_Body :=
1343 Specification =>
1351 Handled_Statement_Sequence =>
1359 Expression =>
1366 Expression =>
1377 -- If the array type is distinct from the type of the arguments,
1378 -- it is the full view of a private type. Apply an unchecked
1379 -- conversion to insure that analysis of the call succeeds.
1381 declare
1384 begin
1390 then
1396 then
1405 return
1411 -----------------------------
1412 -- Expand_Boolean_Operator --
1413 -----------------------------
1415 -- Note that we first get the actual subtypes of the operands,
1416 -- since we always want to deal with types that have bounds.
1421 begin
1425 else
1426 -- For the normal non-packed case, the general expansion is
1427 -- to build a function for carrying out the comparison (using
1428 -- Make_Boolean_Array_Op) and then inserting it into the tree.
1429 -- The original operator node is then rewritten as a call to
1430 -- this function.
1432 declare
1439 begin
1448 then
1453 and then
1455 then
1457 else
1463 -- Now rewrite the expression with a call
1468 Parameter_Associations =>
1469 New_List
1479 -------------------------------
1480 -- Expand_Composite_Equality --
1481 -------------------------------
1483 -- This function is only called for comparing internal fields of composite
1484 -- types when these fields are themselves composites. This is a special
1485 -- case because it is not possible to respect normal Ada visibility rules.
1487 function Expand_Composite_Equality
1493 is
1499 begin
1502 else
1506 -- Defense against malformed private types with no completion
1507 -- the error will be diagnosed later by check_completion
1517 -- If the operand is an elementary type other than a floating-point
1518 -- type, then we can simply use the built-in block bitwise equality,
1519 -- since the predefined equality operators always apply and bitwise
1520 -- equality is fine for all these cases.
1524 then
1527 -- For composite component types, and floating-point types, use
1528 -- the expansion. This deals with tagged component types (where
1529 -- we use the applicable equality routine) and floating-point,
1530 -- (where we need to worry about negative zeroes), and also the
1531 -- case of any composite type recursively containing such fields.
1533 else
1539 -- Call the primitive operation "=" of this type
1545 -- If this is derived from an untagged private type completed
1546 -- with a tagged type, it does not have a full view, so we
1547 -- use the primitive operations of the private type.
1548 -- This check should no longer be necessary when these
1549 -- types receive their full views ???
1556 then
1558 else
1562 loop
1574 return
1577 Parameter_Associations =>
1578 New_List
1588 -- Inherited equality from parent type. Convert the actuals
1589 -- to match signature of operation.
1591 declare
1594 begin
1595 return
1598 Parameter_Associations =>
1603 else
1604 -- Comparison between Unchecked_Union components
1607 declare
1613 begin
1614 -- Lhs subtype
1620 -- Rhs subtype
1626 -- Lhs of the composite equality
1630 -- Since the enclosing record can never be an
1631 -- Unchecked_Union (this code is executed for records
1632 -- that do not have variants), we may reference its
1633 -- discriminant(s).
1638 then
1639 Lhs_Discr_Val :=
1642 Selector_Name =>
1643 New_Copy (
1644 Get_Discriminant_Value (
1646 Lhs_Type,
1649 else
1651 Get_Discriminant_Value (
1653 Lhs_Type,
1657 else
1658 -- It is not possible to infer the discriminant since
1659 -- the subtype is not constrained.
1661 return
1666 -- Rhs of the composite equality
1672 then
1673 Rhs_Discr_Val :=
1676 Selector_Name =>
1677 New_Copy (
1678 Get_Discriminant_Value (
1680 Rhs_Type,
1683 else
1685 Get_Discriminant_Value (
1687 Rhs_Type,
1691 else
1692 return
1697 -- Call the TSS equality function with the inferred
1698 -- discriminant values.
1700 return
1704 Lhs,
1705 Rhs,
1706 Lhs_Discr_Val,
1707 Rhs_Discr_Val));
1711 -- Shouldn't this be an else, we can't fall through
1712 -- the above IF, right???
1714 return
1720 else
1724 else
1725 -- It can be a simple record or the full view of a scalar private
1731 ------------------------------
1732 -- Expand_Concatenate_Other --
1733 ------------------------------
1735 -- Let n be the number of array operands to be concatenated, Base_Typ
1736 -- their base type, Ind_Typ their index type, and Arr_Typ the original
1737 -- array type to which the concatenantion operator applies, then the
1738 -- following subprogram is constructed:
1740 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1741 -- L : Ind_Typ;
1742 -- begin
1743 -- if S1'Length /= 0 then
1744 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
1745 -- XXX = Arr_Typ'First otherwise
1746 -- elsif S2'Length /= 0 then
1747 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
1748 -- YYY = Arr_Typ'First otherwise
1749 -- ...
1750 -- elsif Sn-1'Length /= 0 then
1751 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
1752 -- ZZZ = Arr_Typ'First otherwise
1753 -- else
1754 -- return Sn;
1755 -- end if;
1757 -- declare
1758 -- P : Ind_Typ;
1759 -- H : Ind_Typ :=
1760 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1761 -- + Ind_Typ'Pos (L));
1762 -- R : Base_Typ (L .. H);
1763 -- begin
1764 -- if S1'Length /= 0 then
1765 -- P := S1'First;
1766 -- loop
1767 -- R (L) := S1 (P);
1768 -- L := Ind_Typ'Succ (L);
1769 -- exit when P = S1'Last;
1770 -- P := Ind_Typ'Succ (P);
1771 -- end loop;
1772 -- end if;
1773 --
1774 -- if S2'Length /= 0 then
1775 -- L := Ind_Typ'Succ (L);
1776 -- loop
1777 -- R (L) := S2 (P);
1778 -- L := Ind_Typ'Succ (L);
1779 -- exit when P = S2'Last;
1780 -- P := Ind_Typ'Succ (P);
1781 -- end loop;
1782 -- end if;
1784 -- . . .
1786 -- if Sn'Length /= 0 then
1787 -- P := Sn'First;
1788 -- loop
1789 -- R (L) := Sn (P);
1790 -- L := Ind_Typ'Succ (L);
1791 -- exit when P = Sn'Last;
1792 -- P := Ind_Typ'Succ (P);
1793 -- end loop;
1794 -- end if;
1796 -- return R;
1797 -- end;
1798 -- end Cnn;]
1836 -- Builds the sequence of statement:
1837 -- P := Si'First;
1838 -- loop
1839 -- R (L) := Si (P);
1840 -- L := Ind_Typ'Succ (L);
1841 -- exit when P = Si'Last;
1842 -- P := Ind_Typ'Succ (P);
1843 -- end loop;
1844 --
1845 -- where i is the input parameter I given.
1846 -- If the flag Last is true, the exit statement is emitted before
1847 -- incrementing the lower bound, to prevent the creation out of
1848 -- bound values.
1851 -- Builds the statement:
1852 -- L := Arr_Typ'First; If Arr_Typ is constrained
1853 -- L := Si'First; otherwise (where I is the input param given)
1856 -- Builds reference to identifier H
1859 -- Builds expression Ind_Typ'Val (E);
1862 -- Builds reference to identifier L
1865 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
1866 -- expression to avoid universal_integer computations whenever possible,
1867 -- in the expression for the upper bound H.
1870 -- Builds expression Ind_Typ'Succ (L)
1873 -- Builds integer literal one
1876 -- Builds reference to identifier P
1879 -- Builds expression Ind_Typ'Succ (P)
1882 -- Builds reference to identifier R
1885 -- Builds reference to identifier Si, where I is the value given
1888 -- Builds expression Si'First, where I is the value given
1891 -- Builds expression Si'Last, where I is the value given
1894 -- Builds expression Si'Length, where I is the value given
1897 -- Builds expression Si'Length /= 0, where I is the value given
1899 -------------------
1900 -- Copy_Into_R_S --
1901 -------------------
1912 begin
1913 -- First construct the initializations
1920 -- Then build the loop
1942 Loop_Stmt :=
1945 else
1946 Loop_Stmt :=
1956 -------
1957 -- H --
1958 -------
1961 begin
1965 -------------
1966 -- Ind_Val --
1967 -------------
1970 begin
1971 return
1978 ------------
1979 -- Init_L --
1980 ------------
1985 begin
1991 else
1998 -------
1999 -- L --
2000 -------
2003 begin
2007 -----------
2008 -- L_Pos --
2009 -----------
2014 begin
2015 -- If the index type is an enumeration type, the computation
2016 -- can be done in standard integer. Otherwise, choose a large
2017 -- enough integer type.
2023 then
2025 else
2029 return
2032 Expression =>
2039 ------------
2040 -- L_Succ --
2041 ------------
2044 begin
2045 return
2052 ---------
2053 -- One --
2054 ---------
2057 begin
2061 -------
2062 -- P --
2063 -------
2066 begin
2070 ------------
2071 -- P_Succ --
2072 ------------
2075 begin
2076 return
2083 -------
2084 -- R --
2085 -------
2088 begin
2092 -------
2093 -- S --
2094 -------
2097 begin
2101 -------------
2102 -- S_First --
2103 -------------
2106 begin
2112 ------------
2113 -- S_Last --
2114 ------------
2117 begin
2123 --------------
2124 -- S_Length --
2125 --------------
2128 begin
2134 -------------------
2135 -- S_Length_Test --
2136 -------------------
2139 begin
2140 return
2146 -- Start of processing for Expand_Concatenate_Other
2148 begin
2149 -- Construct the parameter specs and the overall function spec
2153 Append_To
2156 Defining_Identifier =>
2162 Func_Spec :=
2168 -- Construct L's object declaration
2170 L_Decl :=
2177 -- Construct the if-then-elsif statements
2186 If_Stmt :=
2194 -- Construct the declaration for H
2196 P_Decl :=
2207 H_Decl :=
2213 -- Construct the declaration for R
2216 R_Constr :=
2220 R_Decl :=
2223 Object_Definition =>
2228 -- Construct the declarations for the declare block
2232 -- Construct list of statements for the declare block
2244 -- Construct the declare block
2248 Handled_Statement_Sequence =>
2251 -- Construct the list of function statements
2255 -- Construct the function body
2257 Func_Body :=
2261 Handled_Statement_Sequence =>
2264 -- Insert the newly generated function in the code. This is analyzed
2265 -- with all checks off, since we have completed all the checks.
2267 -- Note that this does *not* fix the array concatenation bug when the
2268 -- low bound is Integer'first sibce that bug comes from the pointer
2269 -- dereferencing an unconstrained array. An there we need a constraint
2270 -- check to make sure the length of the concatenated array is ok. ???
2274 -- Construct list of arguments for the function call
2283 -- Insert the function call
2285 Rewrite
2293 -------------------------------
2294 -- Expand_Concatenate_String --
2295 -------------------------------
2305 -- RE_Id value for function to be called
2307 begin
2308 -- In all cases, we build a call to a routine giving the list of
2309 -- arguments as the parameter list to the routine.
2317 else
2326 else
2331 -- If we have anything other than Standard_Character or
2332 -- Standard_String, then we must have had a serious error
2333 -- earlier, so we just abandon the attempt at expansion.
2335 else
2354 -- Now generate the appropriate call
2363 exception
2368 ------------------------
2369 -- Expand_N_Allocator --
2370 ------------------------
2380 begin
2381 -- RM E.2.3(22). We enforce that the expected type of an allocator
2382 -- shall not be a remote access-to-class-wide-limited-private type
2384 -- Why is this being done at expansion time, seems clearly wrong ???
2388 -- Set the Storage Pool
2401 else
2407 -- Under certain circumstances we can replace an allocator by an
2408 -- access to statically allocated storage. The conditions, as noted
2409 -- in AARM 3.10 (10c) are as follows:
2411 -- Size and initial value is known at compile time
2412 -- Access type is access-to-constant
2414 -- The allocator is not part of a constraint on a record component,
2415 -- because in that case the inserted actions are delayed until the
2416 -- record declaration is fully analyzed, which is too late for the
2417 -- analysis of the rewritten allocator.
2425 then
2426 -- Here we can do the optimization. For the allocator
2428 -- new x'(y)
2430 -- We insert an object declaration
2432 -- Tnn : aliased x := y;
2434 -- and replace the allocator by Tnn'Unrestricted_Access.
2435 -- Tnn is marked as requiring static allocation.
2437 Temp :=
2442 -- If context is constrained, use constrained subtype directly,
2443 -- so that the constant is not labelled as having a nomimally
2444 -- unconstrained subtype.
2465 -- We set the variable as statically allocated, since we don't
2466 -- want it going on the stack of the current procedure!
2472 -- Handle case of qualified expression (other than optimization above)
2477 -- If the allocator is for a type which requires initialization, and
2478 -- there is no initial value (i.e. operand is a subtype indication
2479 -- rather than a qualifed expression), then we must generate a call
2480 -- to the initialization routine. This is done using an expression
2481 -- actions node:
2482 --
2483 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2484 --
2485 -- Here ptr_T is the pointer type for the allocator, and T is the
2486 -- subtype of the allocator. A special case arises if the designated
2487 -- type of the access type is a task or contains tasks. In this case
2488 -- the call to Init (Temp.all ...) is replaced by code that ensures
2489 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2490 -- for details). In addition, if the type T is a task T, then the
2491 -- first argument to Init must be converted to the task record type.
2493 else
2494 declare
2507 begin
2511 -- Case of no initialization procedure present
2515 -- Case of simple initialization required
2528 -- No initialization required
2530 else
2534 -- Case of initialization procedure present, must be called
2536 else
2539 Temp :=
2542 -- Construct argument list for the initialization routine call
2543 -- The CPP constructor needs the address directly
2549 else
2550 Arg1 :=
2556 -- The initialization procedure expects a specific type.
2557 -- if the context is access to class wide, indicate that
2558 -- the object being allocated has the right specific type.
2565 -- If designated type is a concurrent type or if it is a
2566 -- private type whose definition is a concurrent type,
2567 -- the first argument in the Init routine has to be
2568 -- unchecked conversion to the corresponding record type.
2569 -- If the designated type is a derived type, we also
2570 -- convert the argument to its root type.
2573 Arg1 :=
2579 then
2580 Arg1 :=
2581 Unchecked_Convert_To
2586 declare
2589 begin
2597 -- For the task case, pass the Master_Id of the access type
2598 -- as the value of the _Master parameter, and _Chain as the
2599 -- value of the _Chain parameter (_Chain will be defined as
2600 -- part of the generated code for the allocator).
2605 -- The designated type was an incomplete type, and
2606 -- the access type did not get expanded. Salvage
2607 -- it now.
2609 Expand_N_Full_Type_Declaration
2613 -- If the context of the allocator is a declaration or
2614 -- an assignment, we can generate a meaningful image for
2615 -- it, even though subsequent assignments might remove
2616 -- the connection between task and entity. We build this
2617 -- image when the left-hand side is a simple variable,
2618 -- a simple indexed assignment or a simple selected
2619 -- component.
2622 declare
2625 begin
2627 Decls :=
2628 Build_Task_Image_Decls (
2629 Loc,
2630 New_Occurrence_Of
2636 then
2637 Decls :=
2638 Build_Task_Image_Decls
2640 else
2646 Decls :=
2647 Build_Task_Image_Decls (
2650 else
2655 New_Reference_To
2663 -- Has_Task is false, Decls not used
2665 else
2669 -- Add discriminants if discriminated type
2682 then
2683 Discr :=
2692 -- We set the allocator as analyzed so that when we analyze the
2693 -- expression actions node, we do not get an unwanted recursive
2694 -- expansion of the allocator expression.
2699 -- Here is the transformation:
2700 -- input: new T
2701 -- output: Temp : constant ptr_T := new T;
2702 -- Init (Temp.all, ...);
2703 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
2704 -- <CTRL> Initialize (Finalizable (Temp.all));
2706 -- Here ptr_T is the pointer type for the allocator, and T
2707 -- is the subtype of the allocator.
2709 Temp_Decl :=
2724 -- If the designated type is task type or contains tasks,
2725 -- Create block to activate created tasks, and insert
2726 -- declaration for Task_Image variable ahead of call.
2729 declare
2733 begin
2741 else
2752 else
2756 Make_Init_Call (
2761 Attach_Level)));
2769 else
2778 exception
2783 -----------------------
2784 -- Expand_N_And_Then --
2785 -----------------------
2787 -- Expand into conditional expression if Actions present, and also
2788 -- deal with optimizing case of arguments being True or False.
2797 begin
2798 -- Deal with non-standard booleans
2806 -- Check for cases of left argument is True or False
2810 -- If left argument is True, change (True and then Right) to Right.
2811 -- Any actions associated with Right will be executed unconditionally
2812 -- and can thus be inserted into the tree unconditionally.
2823 -- If left argument is False, change (False and then Right) to
2824 -- False. In this case we can forget the actions associated with
2825 -- Right, since they will never be executed.
2836 -- If Actions are present, we expand
2838 -- left and then right
2840 -- into
2842 -- if left then right else false end
2844 -- with the actions becoming the Then_Actions of the conditional
2845 -- expression. This conditional expression is then further expanded
2846 -- (and will eventually disappear)
2853 Left,
2854 Right,
2863 -- No actions present, check for cases of right argument True/False
2867 -- Change (Left and then True) to Left. Note that we know there
2868 -- are no actions associated with the True operand, since we
2869 -- just checked for this case above.
2874 -- Change (Left and then False) to False, making sure to preserve
2875 -- any side effects associated with the Left operand.
2879 Rewrite
2887 -------------------------------------
2888 -- Expand_N_Conditional_Expression --
2889 -------------------------------------
2891 -- Expand into expression actions if then/else actions present
2902 begin
2903 -- If either then or else actions are present, then given:
2905 -- if cond then then-expr else else-expr end
2907 -- we insert the following sequence of actions (using Insert_Actions):
2909 -- Cnn : typ;
2910 -- if cond then
2911 -- <<then actions>>
2912 -- Cnn := then-expr;
2913 -- else
2914 -- <<else actions>>
2915 -- Cnn := else-expr
2916 -- end if;
2918 -- and replace the conditional expression by a reference to Cnn
2923 New_If :=
2941 Insert_List_Before
2946 Insert_List_Before
2962 -----------------------------------
2963 -- Expand_N_Explicit_Dereference --
2964 -----------------------------------
2967 begin
2968 -- The only processing required is an insertion of an explicit
2969 -- dereference call for the checked storage pool case.
2974 -----------------
2975 -- Expand_N_In --
2976 -----------------
2985 begin
2986 -- If we have an explicit range, do a bit of optimization based
2987 -- on range analysis (we may be able to kill one or both checks).
2990 declare
2996 begin
2997 -- If either check is known to fail, replace result
2998 -- by False, since the other check does not matter.
2999 -- Preserve the static flag for legality checks, because
3000 -- we are constant-folding beyond RM 4.9.
3009 -- If both checks are known to succeed, replace result
3010 -- by True, since we know we are in range.
3019 -- If lower bound check succeeds and upper bound check is
3020 -- not known to succeed or fail, then replace the range check
3021 -- with a comparison against the upper bound.
3031 -- If upper bound check succeeds and lower bound check is
3032 -- not known to succeed or fail, then replace the range check
3033 -- with a comparison against the lower bound.
3045 -- For all other cases of an explicit range, nothing to be done
3049 -- Here right operand is a subtype mark
3051 else
3052 declare
3058 begin
3061 -- For tagged type, do tagged membership operation
3065 -- No expansion will be performed when Java_VM, as the
3066 -- JVM back end will handle the membership tests directly
3067 -- (tags are not explicitly represented in Java objects,
3068 -- so the normal tagged membership expansion is not what
3069 -- we want).
3078 -- If type is scalar type, rewrite as x in t'first .. t'last
3079 -- This reason we do this is that the bounds may have the wrong
3080 -- type if they come from the original type definition.
3085 Low_Bound =>
3090 High_Bound =>
3097 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
3098 -- a membership test if the subtype mark denotes a constrained
3099 -- Unchecked_Union subtype and the expression lacks inferable
3100 -- discriminants.
3105 then
3110 -- Prevent Gigi from generating incorrect code by rewriting
3111 -- the test as a standard False.
3119 -- Here we have a non-scalar type
3130 -- For the constrained array case, we have to check the
3131 -- subscripts for an exact match if the lengths are
3132 -- non-zero (the lengths must match in any case).
3137 function Construct_Attribute_Reference
3141 -- Build attribute reference E'Nam(Dim)
3143 -----------------------------------
3144 -- Construct_Attribute_Reference --
3145 -----------------------------------
3147 function Construct_Attribute_Reference
3151 is
3152 begin
3153 return
3161 -- Start processing for Check_Subscripts
3163 begin
3167 Left_Opnd =>
3168 Construct_Attribute_Reference
3171 Right_Opnd =>
3172 Construct_Attribute_Reference
3177 Left_Opnd =>
3178 Construct_Attribute_Reference
3181 Right_Opnd =>
3182 Construct_Attribute_Reference
3187 Cond :=
3189 Left_Opnd =>
3200 -- These are the cases where constraint checks may be
3201 -- required, e.g. records with possible discriminants
3203 else
3204 -- Expand the test into a series of discriminant comparisons.
3205 -- The expression that is built is the negation of the one
3206 -- that is used for checking discriminant constraints.
3216 Left_Opnd =>
3223 else
3234 --------------------------------
3235 -- Expand_N_Indexed_Component --
3236 --------------------------------
3244 begin
3245 -- A special optimization, if we have an indexed component that
3246 -- is selecting from a slice, then we can eliminate the slice,
3247 -- since, for example, x (i .. j)(k) is identical to x(k). The
3248 -- only difference is the range check required by the slice. The
3249 -- range check for the slice itself has already been generated.
3250 -- The range check for the subscripting operation is ensured
3251 -- by converting the subject to the subtype of the slice.
3253 -- This optimization not only generates better code, avoiding
3254 -- slice messing especially in the packed case, but more importantly
3255 -- bypasses some problems in handling this peculiar case, for
3256 -- example, the issue of dealing specially with object renamings.
3263 Convert_To
3270 -- If the prefix is an access type, then we unconditionally rewrite
3271 -- if as an explicit deference. This simplifies processing for several
3272 -- cases, including packed array cases and certain cases in which
3273 -- checks must be generated. We used to try to do this only when it
3274 -- was necessary, but it cleans up the code to do it all the time.
3281 -- Generate index and validity checks
3289 -- All done for the non-packed case
3295 -- For packed arrays that are not bit-packed (i.e. the case of an array
3296 -- with one or more index types with a non-coniguous enumeration type),
3297 -- we can always use the normal packed element get circuit.
3304 -- For a reference to a component of a bit packed array, we have to
3305 -- convert it to a reference to the corresponding Packed_Array_Type.
3306 -- We only want to do this for simple references, and not for:
3308 -- Left side of assignment, or prefix of left side of assignment,
3309 -- or prefix of the prefix, to handle packed arrays of packed arrays,
3310 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3312 -- Renaming objects in renaming associations
3313 -- This case is handled when a use of the renamed variable occurs
3315 -- Actual parameters for a procedure call
3316 -- This case is handled in Exp_Ch6.Expand_Actuals
3318 -- The second expression in a 'Read attribute reference
3320 -- The prefix of an address or size attribute reference
3322 -- The following circuit detects these exceptions
3324 declare
3328 begin
3329 loop
3336 and then
3338 then
3343 or else
3346 then
3351 then
3354 -- If the expression is an index of an indexed component,
3355 -- it must be expanded regardless of context.
3359 then
3365 then
3371 then
3377 then
3380 else
3385 -- Keep looking up tree for unchecked expression, or if we are
3386 -- the prefix of a possible assignment left side.
3395 ---------------------
3396 -- Expand_N_Not_In --
3397 ---------------------
3399 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
3400 -- can be done. This avoids needing to duplicate this expansion code.
3406 begin
3409 Right_Opnd =>
3416 -------------------
3417 -- Expand_N_Null --
3418 -------------------
3420 -- The only replacement required is for the case of a null of type
3421 -- that is an access to protected subprogram. We represent such
3422 -- access values as a record, and so we must replace the occurrence
3423 -- of null by the equivalent record (with a null address and a null
3424 -- pointer in it), so that the backend creates the proper value.
3431 begin
3433 Agg :=
3442 -- For subsequent semantic analysis, the node must retain its
3443 -- type. Gigi in any case replaces this type by the corresponding
3444 -- record type before processing the node.
3449 exception
3454 ---------------------
3455 -- Expand_N_Op_Abs --
3456 ---------------------
3462 begin
3465 -- Deal with software overflow checking
3467 if not Backend_Overflow_Checks_On_Target
3470 then
3471 -- The only case to worry about is when the argument is
3472 -- equal to the largest negative number, so what we do is
3473 -- to insert the check:
3475 -- [constraint_error when Expr = typ'Base'First]
3477 -- with the usual Duplicate_Subexpr use coding for expr
3481 Condition =>
3484 Right_Opnd =>
3486 Prefix =>
3492 -- Vax floating-point types case
3499 ---------------------
3500 -- Expand_N_Op_Add --
3501 ---------------------
3506 begin
3509 -- N + 0 = 0 + N = N for integer types
3514 then
3520 then
3526 -- Arithmetic overflow checks for signed integer/fixed point types
3530 then
3534 -- Vax floating-point types case
3541 ---------------------
3542 -- Expand_N_Op_And --
3543 ---------------------
3548 begin
3562 ------------------------
3563 -- Expand_N_Op_Concat --
3564 ------------------------
3567 -- This is initialized the first time this routine is called. It records
3568 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3569 -- available in the run-time:
3570 --
3571 -- 0 None available
3572 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
3573 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3574 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3575 -- 5 All routines including RE_Str_Concat_5 available
3578 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3579 -- all three are available, False if any one of these is unavailable.
3583 -- List of operands to be concatenated
3586 -- Single operand for concatenation
3589 -- Node which is to be replaced by the result of concatenating
3590 -- the nodes in the list Opnds.
3593 -- Array type of concatenation result type
3596 -- Component type of concatenation represented by Cnode
3598 begin
3599 -- Initialize global variables showing run-time status
3610 else
3614 Char_Concat_Available :=
3616 and then
3618 and then
3622 -- Ensure validity of both operands
3626 -- If we are the left operand of a concatenation higher up the
3627 -- tree, then do nothing for now, since we want to deal with a
3628 -- series of concatenations as a unit.
3632 then
3636 -- We get here with a concatenation whose left operand may be a
3637 -- concatenation itself with a consistent type. We need to process
3638 -- these concatenation operands from left to right, which means
3639 -- from the deepest node in the tree to the highest node.
3646 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
3647 -- nodes above, so now we process bottom up, doing the operations. We
3648 -- gather a string that is as long as possible up to five operands
3650 -- The outer loop runs more than once if there are more than five
3651 -- concatenations of type Standard.String, the most we handle for
3652 -- this case, or if more than one concatenation type is involved.
3658 -- The inner loop gathers concatenation operands. We gather any
3659 -- number of these in the non-string case, or if no concatenation
3660 -- routines are available for string (since in that case we will
3661 -- treat string like any other non-string case). Otherwise we only
3662 -- gather as many operands as can be handled by the available
3663 -- procedures in the run-time library (normally 5, but may be
3664 -- less for the configurable run-time case).
3668 or else
3670 or else
3672 Max_Available_String_Operands)
3675 loop
3680 -- Here we process the collected operands. First we convert
3681 -- singleton operands to singleton aggregates. This is skipped
3682 -- however for the case of two operands of type String, since
3683 -- we have special routines for these cases.
3689 or else not Char_Concat_Available
3690 then
3692 loop
3705 -- Now call appropriate continuation routine
3709 then
3711 else
3720 ------------------------
3721 -- Expand_N_Op_Divide --
3722 ------------------------
3730 begin
3733 -- Vax_Float is a special case
3740 -- N / 1 = N for integer types
3745 then
3750 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3751 -- Is_Power_Of_2_For_Shift is set means that we know that our left
3752 -- operand is an unsigned integer, as required for this to work.
3757 -- We cannot do this transformation in configurable run time mode if we
3758 -- have 64-bit -- integers and long shifts are not available.
3760 and then
3763 then
3767 Right_Opnd =>
3773 -- Do required fixup of universal fixed operation
3780 -- Divisions with fixed-point results
3784 -- No special processing if Treat_Fixed_As_Integer is set,
3785 -- since from a semantic point of view such operations are
3786 -- simply integer operations and will be treated that way.
3791 else
3796 -- Other cases of division of fixed-point operands. Again we
3797 -- exclude the case where Treat_Fixed_As_Integer is set.
3802 then
3805 else
3810 -- Mixed-mode operations can appear in a non-static universal
3811 -- context, in which case the integer argument must be converted
3812 -- explicitly.
3816 then
3824 then
3830 -- Non-fixed point cases, do zero divide and overflow checks
3835 -- Check for 64-bit division available
3838 and then not Support_64_Bit_Divides_On_Target
3839 then
3845 --------------------
3846 -- Expand_N_Op_Eq --
3847 --------------------
3862 -- If a constructed equality exists for the type or for its parent,
3863 -- build and analyze call, adding conversions if the operation is
3864 -- inherited.
3867 -- Determines whether a type has a subcompoment of an unconstrained
3868 -- Unchecked_Union subtype. Typ is a record type.
3870 -------------------------
3871 -- Build_Equality_Call --
3872 -------------------------
3879 begin
3882 then
3887 -- If we have an Unchecked_Union, we need to add the inferred
3888 -- discriminant values as actuals in the function call. At this
3889 -- point, the expansion has determined that both operands have
3890 -- inferable discriminants.
3893 declare
3899 begin
3900 -- Per-object constrained selected components require special
3901 -- attention. If the enclosing scope of the component is an
3902 -- Unchecked_Union, we can not reference its discriminants
3903 -- directly. This is why we use the two extra parameters of
3904 -- the equality function of the enclosing Unchecked_Union.
3906 -- type UU_Type (Discr : Integer := 0) is
3907 -- . . .
3908 -- end record;
3909 -- pragma Unchecked_Union (UU_Type);
3911 -- 1. Unchecked_Union enclosing record:
3913 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
3914 -- . . .
3915 -- Comp : UU_Type (Discr);
3916 -- . . .
3917 -- end Enclosing_UU_Type;
3918 -- pragma Unchecked_Union (Enclosing_UU_Type);
3920 -- Obj1 : Enclosing_UU_Type;
3921 -- Obj2 : Enclosing_UU_Type (1);
3923 -- [. . .] Obj1 = Obj2 [. . .]
3925 -- Generated code:
3927 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
3929 -- A and B are the formal parameters of the equality function
3930 -- of Enclosing_UU_Type. The function always has two extra
3931 -- formals to capture the inferred discriminant values.
3933 -- 2. Non-Unchecked_Union enclosing record:
3935 -- type
3936 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
3937 -- is record
3938 -- . . .
3939 -- Comp : UU_Type (Discr);
3940 -- . . .
3941 -- end Enclosing_Non_UU_Type;
3943 -- Obj1 : Enclosing_Non_UU_Type;
3944 -- Obj2 : Enclosing_Non_UU_Type (1);
3946 -- . . . Obj1 = Obj2 . . .
3948 -- Generated code:
3950 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
3951 -- obj1.discr, obj2.discr)) then
3953 -- In this case we can directly reference the discriminants of
3954 -- the enclosing record.
3956 -- Lhs of equality
3959 and then Has_Per_Object_Constraint
3961 then
3962 -- Enclosing record is an Unchecked_Union, use formal A
3966 then
3967 Lhs_Discr_Val :=
3971 -- Enclosing record is of a non-Unchecked_Union type, it is
3972 -- possible to reference the discriminant.
3974 else
3975 Lhs_Discr_Val :=
3978 Selector_Name =>
3979 New_Copy
3980 (Get_Discriminant_Value
3982 Lhs_Type,
3986 -- Comment needed here ???
3988 else
3989 -- Infer the discriminant value
3991 Lhs_Discr_Val :=
3992 New_Copy
3993 (Get_Discriminant_Value
3995 Lhs_Type,
3999 -- Rhs of equality
4002 and then Has_Per_Object_Constraint
4004 then
4005 if Is_Unchecked_Union
4007 then
4008 Rhs_Discr_Val :=
4012 else
4013 Rhs_Discr_Val :=
4016 Selector_Name =>
4019 Rhs_Type,
4023 else
4024 Rhs_Discr_Val :=
4027 Rhs_Type,
4036 L_Exp,
4037 R_Exp,
4038 Lhs_Discr_Val,
4039 Rhs_Discr_Val)));
4042 -- Normal case, not an unchecked union
4044 else
4054 ------------------------------------
4055 -- Has_Unconstrained_UU_Component --
4056 ------------------------------------
4058 function Has_Unconstrained_UU_Component
4060 is
4066 function Component_Is_Unconstrained_UU
4068 -- Determines whether the subtype of the component is an
4069 -- unconstrained Unchecked_Union.
4071 function Variant_Is_Unconstrained_UU
4073 -- Determines whether a component of the variant has an unconstrained
4074 -- Unchecked_Union subtype.
4076 -----------------------------------
4077 -- Component_Is_Unconstrained_UU --
4078 -----------------------------------
4080 function Component_Is_Unconstrained_UU
4082 is
4083 begin
4088 declare
4092 begin
4093 -- Unconstrained nominal type. In the case of a constraint
4094 -- present, the node kind would have been N_Subtype_Indication.
4104 ---------------------------------
4105 -- Variant_Is_Unconstrained_UU --
4106 ---------------------------------
4108 function Variant_Is_Unconstrained_UU
4110 is
4113 begin
4118 declare
4121 begin
4124 -- One component is sufficent
4134 -- None of the components withing the variant were of
4135 -- unconstrained Unchecked_Union type.
4140 -- Start of processing for Has_Unconstrained_UU_Component
4142 begin
4150 -- Inspect available components
4153 declare
4156 begin
4159 -- One component is sufficent
4170 -- Inspect available components withing variants
4173 declare
4176 begin
4179 -- One component within a variant is sufficent
4190 -- Neither the available components, nor the components inside the
4191 -- variant parts were of an unconstrained Unchecked_Union subtype.
4196 -- Start of processing for Expand_N_Op_Eq
4198 begin
4208 -- It may happen in error situations that the underlying type is not
4209 -- set. The error will be detected later, here we just defend the
4210 -- expander code.
4218 -- Vax float types
4224 -- Boolean types (requiring handling of non-standard case)
4232 -- Array types
4236 -- If we are doing full validity checking, then expand out array
4237 -- comparisons to make sure that we check the array elements.
4240 declare
4242 Force_Validity_Checks;
4243 begin
4246 Expand_Array_Equality
4250 Bodies,
4251 Typl));
4257 -- Packed case
4262 -- Where the component type is elementary we can use a block bit
4263 -- comparison (if supported on the target) exception in the case
4264 -- of floating-point (negative zero issues require element by
4265 -- element comparison), and atomic types (where we must be sure
4266 -- to load elements independently).
4271 and then Support_Composite_Compare_On_Target
4272 then
4275 -- For composite and floating-point cases, expand equality loop
4276 -- to make sure of using proper comparisons for tagged types,
4277 -- and correctly handling the floating-point case.
4279 else
4281 Expand_Array_Equality
4285 Bodies,
4286 Typl));
4291 -- Record Types
4295 -- For tagged types, use the primitive "="
4299 -- If this is derived from an untagged private type completed
4300 -- with a tagged type, it does not have a full view, so we
4301 -- use the primitive operations of the private type.
4302 -- This check should no longer be necessary when these
4303 -- types receive their full views ???
4309 then
4310 -- Search for equality operation, checking that the
4311 -- operands have the same type. Note that we must find
4312 -- a matching entry, or something is very wrong!
4320 and then
4329 -- Find the type's predefined equality or an overriding
4330 -- user-defined equality. The reason for not simply calling
4331 -- Find_Prim_Op here is that there may be a user-defined
4332 -- overloaded equality op that precedes the equality that
4333 -- we want, so we have to explicitly search (e.g., there
4334 -- could be an equality with two different parameter types).
4336 else
4346 and then
4358 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
4359 -- predefined equality operator for a type which has a subcomponent
4360 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
4367 -- Prevent Gigi from generating incorrect code by rewriting the
4368 -- equality as a standard False.
4375 -- If we can infer the discriminants of the operands, we make a
4376 -- call to the TSS equality function.
4379 and then
4381 then
4382 Build_Equality_Call
4385 else
4386 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4387 -- the predefined equality operator for an Unchecked_Union type
4388 -- if either of the operands lack inferable discriminants.
4394 -- Prevent Gigi from generating incorrect code by rewriting
4395 -- the equality as a standard False.
4402 -- If a type support function is present (for complex cases), use it
4405 Build_Equality_Call
4408 -- Otherwise expand the component by component equality. Note that
4409 -- we never use block-bit coparisons for records, because of the
4410 -- problems with gaps. The backend will often be able to recombine
4411 -- the separate comparisons that we generate here.
4413 else
4424 -- If we still have an equality comparison (i.e. it was not rewritten
4425 -- in some way), then we can test if result is needed at compile time).
4432 -----------------------
4433 -- Expand_N_Op_Expon --
4434 -----------------------
4452 begin
4455 -- If either operand is of a private type, then we have the use of
4456 -- an intrinsic operator, and we get rid of the privateness, by using
4457 -- root types of underlying types for the actual operation. Otherwise
4458 -- the private types will cause trouble if we expand multiplications
4459 -- or shifts etc. We also do this transformation if the result type
4460 -- is different from the base type.
4463 or else
4465 or else
4467 or else
4469 then
4470 declare
4474 begin
4485 -- Test for case of known right argument
4490 -- We only fold small non-negative exponents. You might think we
4491 -- could fold small negative exponents for the real case, but we
4492 -- can't because we are required to raise Constraint_Error for
4493 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
4494 -- See ACVC test C4A012B.
4498 -- X ** 0 = 1 (or 1.0)
4503 else
4507 -- X ** 1 = X
4512 -- X ** 2 = X * X
4515 Xnode :=
4520 -- X ** 3 = X * X * X
4523 Xnode :=
4525 Left_Opnd =>
4531 -- X ** 4 ->
4532 -- En : constant base'type := base * base;
4533 -- ...
4534 -- En * En
4537 Temp :=
4545 Expression =>
4550 Xnode :=
4562 -- Case of (2 ** expression) appearing as an argument of an integer
4563 -- multiplication, or as the right argument of a division of a non-
4564 -- negative integer. In such cases we leave the node untouched, setting
4565 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
4566 -- of the higher level node converts it into a shift.
4573 and then not Ovflo
4575 then
4576 declare
4581 begin
4583 and then
4585 or else
4589 or else
4595 then
4602 -- Fall through if exponentiation must be done using a runtime routine
4604 -- First deal with modular case
4608 -- Non-binary case, we call the special exponentiation routine for
4609 -- the non-binary case, converting the argument to Long_Long_Integer
4610 -- and passing the modulus value. Then the result is converted back
4611 -- to the base type.
4621 Exp))));
4623 -- Binary case, in this case, we call one of two routines, either
4624 -- the unsigned integer case, or the unsigned long long integer
4625 -- case, with a final "and" operation to do the required mod.
4627 else
4630 else
4637 Left_Opnd =>
4642 Exp)),
4643 Right_Opnd =>
4648 -- Common exit point for modular type case
4653 -- Signed integer cases, done using either Integer or Long_Long_Integer.
4654 -- It is not worth having routines for Short_[Short_]Integer, since for
4655 -- most machines it would not help, and it would generate more code that
4656 -- might need certification in the HI-E case.
4658 -- In the integer cases, we have two routines, one for when overflow
4659 -- checks are required, and one when they are not required, since
4660 -- there is a real gain in ommitting checks on many machines.
4664 and then
4667 then
4672 else
4681 else
4685 -- Floating-point cases, always done using Long_Long_Float. We do not
4686 -- need separate routines for the overflow case here, since in the case
4687 -- of floating-point, we generate infinities anyway as a rule (either
4688 -- that or we automatically trap overflow), and if there is an infinity
4689 -- generated and a range check is required, the check will fail anyway.
4691 else
4697 -- Common processing for integer cases and floating-point cases.
4698 -- If we are in the right type, we can call runtime routine directly
4703 then
4709 -- Otherwise we have to introduce conversions (conversions are also
4710 -- required in the universal cases, since the runtime routine is
4711 -- typed using one of the standard types.
4713 else
4720 Exp))));
4726 exception
4731 --------------------
4732 -- Expand_N_Op_Ge --
4733 --------------------
4741 begin
4763 --------------------
4764 -- Expand_N_Op_Gt --
4765 --------------------
4773 begin
4795 --------------------
4796 -- Expand_N_Op_Le --
4797 --------------------
4805 begin
4827 --------------------
4828 -- Expand_N_Op_Lt --
4829 --------------------
4837 begin
4859 -----------------------
4860 -- Expand_N_Op_Minus --
4861 -----------------------
4867 begin
4870 if not Backend_Overflow_Checks_On_Target
4873 then
4874 -- Software overflow checking expands -expr into (0 - expr)
4883 -- Vax floating-point types case
4890 ---------------------
4891 -- Expand_N_Op_Mod --
4892 ---------------------
4910 begin
4916 -- Convert mod to rem if operands are known non-negative. We do this
4917 -- since it is quite likely that this will improve the quality of code,
4918 -- (the operation now corresponds to the hardware remainder), and it
4919 -- does not seem likely that it could be harmful.
4922 and then
4924 then
4930 -- Instead of reanalyzing the node we do the analysis manually.
4931 -- This avoids anomalies when the replacement is done in an
4932 -- instance and is epsilon more efficient.
4941 -- Otherwise, normal mod processing
4943 else
4948 -- Apply optimization x mod 1 = 0. We don't really need that with
4949 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
4950 -- certainly harmless.
4955 then
4961 -- Deal with annoying case of largest negative number remainder
4962 -- minus one. Gigi does not handle this case correctly, because
4963 -- it generates a divide instruction which may trap in this case.
4965 -- In fact the check is quite easy, if the right operand is -1,
4966 -- then the mod value is always 0, and we can just ignore the
4967 -- left operand completely in this case.
4969 -- The operand type may be private (e.g. in the expansion of an
4970 -- an intrinsic operation) so we must use the underlying type to
4971 -- get the bounds, and convert the literals explicitly.
4973 LLB :=
4974 Expr_Value
4978 and then
4980 then
4986 Right_Opnd =>
4999 --------------------------
5000 -- Expand_N_Op_Multiply --
5001 --------------------------
5020 begin
5023 -- Special optimizations for integer types
5027 -- N * 0 = 0 * N = 0 for integer types
5031 or else
5034 then
5040 -- N * 1 = 1 * N = N for integer types
5042 -- This optimisation is not done if we are going to
5043 -- rewrite the product 1 * 2 ** N to a shift.
5047 and then not Lp2
5048 then
5054 and then not Rp2
5055 then
5061 -- Deal with VAX float case
5068 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5069 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5070 -- operand is an integer, as required for this to work.
5075 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
5080 Right_Opnd =>
5087 else
5091 Right_Opnd =>
5097 -- Same processing for the operands the other way round
5103 Right_Opnd =>
5109 -- Do required fixup of universal fixed operation
5116 -- Multiplications with fixed-point results
5120 -- No special processing if Treat_Fixed_As_Integer is set,
5121 -- since from a semantic point of view such operations are
5122 -- simply integer operations and will be treated that way.
5126 -- Case of fixed * integer => fixed
5131 -- Case of integer * fixed => fixed
5136 -- Case of fixed * fixed => fixed
5138 else
5143 -- Other cases of multiplication of fixed-point operands. Again
5144 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
5148 then
5151 else
5156 -- Mixed-mode operations can appear in a non-static universal
5157 -- context, in which case the integer argument must be converted
5158 -- explicitly.
5162 then
5169 then
5174 -- Non-fixed point cases, check software overflow checking required
5181 --------------------
5182 -- Expand_N_Op_Ne --
5183 --------------------
5185 -- Rewrite node as the negation of an equality operation, and reanalyze.
5186 -- The equality to be used is defined in the same scope and has the same
5187 -- signature. It must be set explicitly because in an instance it may not
5188 -- have the same visibility as in the generic unit.
5195 begin
5198 Neg :=
5200 Right_Opnd =>
5210 -- For navigation purposes, the inequality is treated as an implicit
5211 -- reference to the corresponding equality. Preserve the Comes_From_
5212 -- source flag so that the proper Xref entry is generated.
5220 ---------------------
5221 -- Expand_N_Op_Not --
5222 ---------------------
5224 -- If the argument is other than a Boolean array type, there is no
5225 -- special expansion required.
5227 -- For the packed case, we call the special routine in Exp_Pakd, except
5228 -- that if the component size is greater than one, we use the standard
5229 -- routine generating a gruesome loop (it is so peculiar to have packed
5230 -- arrays with non-standard Boolean representations anyway, so it does
5231 -- not matter that we do not handle this case efficiently).
5233 -- For the unpacked case (and for the special packed case where we have
5234 -- non standard Booleans, as discussed above), we generate and insert
5235 -- into the tree the following function definition:
5237 -- function Nnnn (A : arr) is
5238 -- B : arr;
5239 -- begin
5240 -- for J in a'range loop
5241 -- B (J) := not A (J);
5242 -- end loop;
5243 -- return B;
5244 -- end Nnnn;
5246 -- Here arr is the actual subtype of the parameter (and hence always
5247 -- constrained). Then we replace the not with a call to this function.
5263 begin
5266 -- For boolean operand, deal with non-standard booleans
5275 -- Only array types need any other processing
5281 -- Case of array operand. If bit packed, handle it in Exp_Pakd
5288 -- Case of array operand which is not bit-packed. If the context is
5289 -- a safe assignment, call in-place operation, If context is a larger
5290 -- boolean expression in the context of a safe assignment, expansion is
5291 -- done by enclosing operation.
5303 -- Special case the negation of a binary operation
5308 and then Safe_In_Place_Array_Op
5310 then
5317 then
5318 declare
5323 begin
5327 then
5328 -- (not A) op (not B) can be reduced to a single call
5334 then
5335 -- A xor (not B) can also be special-cased
5347 A_J :=
5352 B_J :=
5357 Loop_Statement :=
5361 Iteration_Scheme =>
5363 Loop_Parameter_Specification =>
5366 Discrete_Subtype_Definition =>
5381 Specification =>
5395 Handled_Statement_Sequence =>
5398 Loop_Statement,
5400 Expression =>
5411 --------------------
5412 -- Expand_N_Op_Or --
5413 --------------------
5418 begin
5432 ----------------------
5433 -- Expand_N_Op_Plus --
5434 ----------------------
5437 begin
5441 ---------------------
5442 -- Expand_N_Op_Rem --
5443 ---------------------
5460 begin
5467 -- Apply optimization x rem 1 = 0. We don't really need that with
5468 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5469 -- certainly harmless.
5474 then
5480 -- Deal with annoying case of largest negative number remainder
5481 -- minus one. Gigi does not handle this case correctly, because
5482 -- it generates a divide instruction which may trap in this case.
5484 -- In fact the check is quite easy, if the right operand is -1,
5485 -- then the remainder is always 0, and we can just ignore the
5486 -- left operand completely in this case.
5491 -- The operand type may be private (e.g. in the expansion of an
5492 -- an intrinsic operation) so we must use the underlying type to
5493 -- get the bounds, and convert the literals explicitly.
5495 LLB :=
5496 Expr_Value
5499 -- Now perform the test, generating code only if needed
5502 and then
5504 then
5510 Right_Opnd =>
5524 -----------------------------
5525 -- Expand_N_Op_Rotate_Left --
5526 -----------------------------
5529 begin
5533 ------------------------------
5534 -- Expand_N_Op_Rotate_Right --
5535 ------------------------------
5538 begin
5542 ----------------------------
5543 -- Expand_N_Op_Shift_Left --
5544 ----------------------------
5547 begin
5551 -----------------------------
5552 -- Expand_N_Op_Shift_Right --
5553 -----------------------------
5556 begin
5560 ----------------------------------------
5561 -- Expand_N_Op_Shift_Right_Arithmetic --
5562 ----------------------------------------
5565 begin
5569 --------------------------
5570 -- Expand_N_Op_Subtract --
5571 --------------------------
5576 begin
5579 -- N - 0 = N for integer types
5584 then
5589 -- Arithemtic overflow checks for signed integer/fixed point types
5593 then
5596 -- Vax floating-point types case
5603 ---------------------
5604 -- Expand_N_Op_Xor --
5605 ---------------------
5610 begin
5624 ----------------------
5625 -- Expand_N_Or_Else --
5626 ----------------------
5628 -- Expand into conditional expression if Actions present, and also
5629 -- deal with optimizing case of arguments being True or False.
5638 begin
5639 -- Deal with non-standard booleans
5647 -- Check for cases of left argument is True or False
5651 -- If left argument is False, change (False or else Right) to Right.
5652 -- Any actions associated with Right will be executed unconditionally
5653 -- and can thus be inserted into the tree unconditionally.
5664 -- If left argument is True, change (True and then Right) to
5665 -- True. In this case we can forget the actions associated with
5666 -- Right, since they will never be executed.
5677 -- If Actions are present, we expand
5679 -- left or else right
5681 -- into
5683 -- if left then True else right end
5685 -- with the actions becoming the Else_Actions of the conditional
5686 -- expression. This conditional expression is then further expanded
5687 -- (and will eventually disappear)
5694 Left,
5696 Right)));
5704 -- No actions present, check for cases of right argument True/False
5708 -- Change (Left or else False) to Left. Note that we know there
5709 -- are no actions associated with the True operand, since we
5710 -- just checked for this case above.
5715 -- Change (Left or else True) to True, making sure to preserve
5716 -- any side effects associated with the Left operand.
5720 Rewrite
5728 -----------------------------------
5729 -- Expand_N_Qualified_Expression --
5730 -----------------------------------
5736 begin
5740 ---------------------------------
5741 -- Expand_N_Selected_Component --
5742 ---------------------------------
5744 -- If the selector is a discriminant of a concurrent object, rewrite the
5745 -- prefix to denote the corresponding record type.
5757 -- Gigi needs a temporary for prefixes that depend on a discriminant,
5758 -- unless the context of an assignment can provide size information.
5759 -- Don't we have a general routine that does this???
5761 -----------------------
5762 -- In_Left_Hand_Side --
5763 -----------------------
5766 begin
5774 -- Start of processing for Expand_N_Selected_Component
5776 begin
5777 -- Insert explicit dereference if required
5785 then
5792 -- Deal with discriminant check required
5796 -- Present the discrminant checking function to the backend,
5797 -- so that it can inline the call to the function.
5799 Add_Inlined_Body
5800 (Discriminant_Checking_Func
5803 -- Now reset the flag and generate the call
5809 -- Gigi cannot handle unchecked conversions that are the prefix of a
5810 -- selected component with discriminants. This must be checked during
5811 -- expansion, because during analysis the type of the selector is not
5812 -- known at the point the prefix is analyzed. If the conversion is the
5813 -- target of an assignment, then we cannot force the evaluation.
5818 then
5822 -- Remaining processing applies only if selector is a discriminant
5826 -- If the selector is a discriminant of a constrained record type,
5827 -- we may be able to rewrite the expression with the actual value
5828 -- of the discriminant, a useful optimization in some cases.
5833 then
5834 -- Do this optimization for discrete types only, and not for
5835 -- access types (access discriminants get us into trouble!)
5840 -- Don't do this on the left hand of an assignment statement.
5841 -- Normally one would think that references like this would
5842 -- not occur, but they do in generated code, and mean that
5843 -- we really do want to assign the discriminant!
5847 then
5850 -- Don't do this optimization for the prefix of an attribute
5851 -- or the operand of an object renaming declaration since these
5852 -- are contexts where we do not want the value anyway.
5857 then
5860 -- Don't do this optimization if we are within the code for a
5861 -- discriminant check, since the whole point of such a check may
5862 -- be to verify the condition on which the code below depends!
5867 -- Green light to see if we can do the optimization. There is
5868 -- still one condition that inhibits the optimization below
5869 -- but now is the time to check the particular discriminant.
5871 else
5872 -- Loop through discriminants to find the matching
5873 -- discriminant constraint to see if we can copy it.
5879 -- Check if this is the matching discriminant
5883 -- Here we have the matching discriminant. Check for
5884 -- the case of a discriminant of a component that is
5885 -- constrained by an outer discriminant, which cannot
5886 -- be optimized away.
5888 if
5889 Denotes_Discriminant
5891 then
5894 -- In the context of a case statement, the expression
5895 -- may have the base type of the discriminant, and we
5896 -- need to preserve the constraint to avoid spurious
5897 -- errors on missing cases.
5901 then
5904 Subtype_Mark =>
5906 Expression =>
5910 -- In case that comes out as a static expression,
5911 -- reset it (a selected component is never static).
5916 -- Otherwise we can just copy the constraint, but the
5917 -- result is certainly not static! In some cases the
5918 -- discriminant constraint has been analyzed in the
5919 -- context of the original subtype indication, but for
5920 -- itypes the constraint might not have been analyzed
5921 -- yet, and this must be done now.
5923 else
5935 -- Note: the above loop should always find a matching
5936 -- discriminant, but if it does not, we just missed an
5937 -- optimization due to some glitch (perhaps a previous
5938 -- error), so ignore.
5943 -- The only remaining processing is in the case of a discriminant of
5944 -- a concurrent object, where we rewrite the prefix to denote the
5945 -- corresponding record type. If the type is derived and has renamed
5946 -- discriminants, use corresponding discriminant, which is the one
5947 -- that appears in the corresponding record.
5957 then
5961 New_N :=
5963 Prefix =>
5973 --------------------
5974 -- Expand_N_Slice --
5975 --------------------
5984 -- Check whether the argument is an actual for a procedure call,
5985 -- in which case the expansion of a bit-packed slice is deferred
5986 -- until the call itself is expanded. The reason this is required
5987 -- is that we might have an IN OUT or OUT parameter, and the copy out
5988 -- is essential, and that copy out would be missed if we created a
5989 -- temporary here in Expand_N_Slice. Note that we don't bother
5990 -- to test specifically for an IN OUT or OUT mode parameter, since it
5991 -- is a bit tricky to do, and it is harmless to defer expansion
5992 -- in the IN case, since the call processing will still generate the
5993 -- appropriate copy in operation, which will take care of the slice.
5996 -- Create a named variable for the value of the slice, in
5997 -- cases where the back-end cannot handle it properly, e.g.
5998 -- when packed types or unaligned slices are involved.
6000 -------------------------
6001 -- Is_Procedure_Actual --
6002 -------------------------
6007 begin
6008 loop
6009 -- If our parent is a procedure call we can return
6014 -- If our parent is a type conversion, keep climbing the
6015 -- tree, since a type conversion can be a procedure actual.
6016 -- Also keep climbing if parameter association or a qualified
6017 -- expression, since these are additional cases that do can
6018 -- appear on procedure actuals.
6023 then
6026 -- Any other case is not what we are looking for
6028 else
6034 --------------------
6035 -- Make_Temporary --
6036 --------------------
6042 begin
6043 Decl :=
6051 Decl,
6060 -- Start of processing for Expand_N_Slice
6062 begin
6063 -- Special handling for access types
6076 -- Range checks are potentially also needed for cases involving
6077 -- a slice indexed by a subtype indication, but Do_Range_Check
6078 -- can currently only be set for expressions ???
6084 then
6088 -- The remaining case to be handled is packed slices. We can leave
6089 -- packed slices as they are in the following situations:
6091 -- 1. Right or left side of an assignment (we can handle this
6092 -- situation correctly in the assignment statement expansion).
6094 -- 2. Prefix of indexed component (the slide is optimized away
6095 -- in this case, see the start of Expand_N_Slice.
6097 -- 3. Object renaming declaration, since we want the name of
6098 -- the slice, not the value.
6100 -- 4. Argument to procedure call, since copy-in/copy-out handling
6101 -- may be required, and this is handled in the expansion of
6102 -- call itself.
6104 -- 5. Prefix of an address attribute (this is an error which
6105 -- is caught elsewhere, and the expansion would intefere
6106 -- with generating the error message).
6110 -- Apply transformation for actuals of a function call,
6111 -- where Expand_Actuals is not used.
6115 then
6116 Make_Temporary;
6122 then
6128 then
6133 then
6136 else
6137 Make_Temporary;
6141 ------------------------------
6142 -- Expand_N_Type_Conversion --
6143 ------------------------------
6152 -- This is called in the case of record and array type conversions
6153 -- to see if there is a change of representation to be handled.
6154 -- Change of representation is actually handled at the assignment
6155 -- statement level, and what this procedure does is rewrite node N
6156 -- conversion as an assignment to temporary. If there is no change
6157 -- of representation, then the conversion node is unchanged.
6160 -- Handles generation of range check for real target value
6162 -----------------------------------
6163 -- Handle_Changed_Representation --
6164 -----------------------------------
6174 begin
6175 -- Nothing to do if no change of representation
6180 -- The real change of representation work is done by the assignment
6181 -- statement processing. So if this type conversion is appearing as
6182 -- the expression of an assignment statement, nothing needs to be
6183 -- done to the conversion.
6188 -- Otherwise we need to generate a temporary variable, and do the
6189 -- change of representation assignment into that temporary variable.
6190 -- The conversion is then replaced by a reference to this variable.
6192 else
6195 -- If type is unconstrained we have to add a constraint,
6196 -- copied from the actual value of the left hand side.
6211 Selector_Name =>
6222 -- We convert the bounds explicitly. We use an unchecked
6223 -- conversion because bounds checks are done elsewhere.
6227 Low_Bound =>
6230 Prefix =>
6231 Duplicate_Subexpr_No_Checks
6237 High_Bound =>
6240 Prefix =>
6241 Duplicate_Subexpr_No_Checks
6255 Odef :=
6258 Constraint =>
6264 Decl :=
6271 -- Insert required actions. It is essential to suppress checks
6272 -- since we have suppressed default initialization, which means
6273 -- that the variable we create may have no discriminants.
6276 New_List (
6277 Decl,
6288 ----------------------
6289 -- Real_Range_Check --
6290 ----------------------
6292 -- Case of conversions to floating-point or fixed-point. If range
6293 -- checks are enabled and the target type has a range constraint,
6294 -- we convert:
6296 -- typ (x)
6298 -- to
6300 -- Tnn : typ'Base := typ'Base (x);
6301 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
6302 -- Tnn
6304 -- This is necessary when there is a conversion of integer to float
6305 -- or to fixed-point to ensure that the correct checks are made. It
6306 -- is not necessary for float to float where it is enough to simply
6307 -- set the Do_Range_Check flag.
6317 begin
6318 -- Nothing to do if conversion was rewritten
6324 -- Nothing to do if range checks suppressed, or target has the
6325 -- same range as the base type (or is the base type).
6329 and then
6331 then
6335 -- Nothing to do if expression is an entity on which checks
6336 -- have been suppressed.
6340 then
6344 -- Nothing to do if bounds are all static and we can tell that
6345 -- the expression is within the bounds of the target. Note that
6346 -- if the operand is of an unconstrained floating-point type,
6347 -- then we do not trust it to be in range (might be infinite)
6349 declare
6353 begin
6360 then
6361 declare
6367 begin
6371 else
6379 then
6387 -- For float to float conversions, we are done
6390 and then
6392 then
6396 -- Otherwise rewrite the conversion as described above
6399 Rewrite
6403 -- Enable overflow except in the case of integer to float
6404 -- conversions, where it is never required, since we can
6405 -- never have overflow in this case.
6411 Tnn :=
6422 Condition =>
6424 Left_Opnd =>
6427 Right_Opnd =>
6430 Prefix =>
6433 Right_Opnd =>
6436 Right_Opnd =>
6439 Prefix =>
6447 -- Start of processing for Expand_N_Type_Conversion
6449 begin
6450 -- Nothing at all to do if conversion is to the identical type
6451 -- so remove the conversion completely, it is useless.
6458 -- Deal with Vax floating-point cases
6465 -- Nothing to do if this is the second argument of read. This
6466 -- is a "backwards" conversion that will be handled by the
6467 -- specialized code in attribute processing.
6472 then
6476 -- Here if we may need to expand conversion
6478 -- Special case of converting from non-standard boolean type
6482 then
6488 -- Case of converting to an access type
6492 -- Apply an accessibility check if the operand is an
6493 -- access parameter. Note that other checks may still
6494 -- need to be applied below (such as tagged type checks).
6499 then
6502 -- If the level of the operand type is statically deeper
6503 -- then the level of the target type, then force Program_Error.
6504 -- Note that this can only occur for cases where the attribute
6505 -- is within the body of an instantiation (otherwise the
6506 -- conversion will already have been rejected as illegal).
6507 -- Note: warnings are issued by the analyzer for the instance
6508 -- cases.
6510 elsif In_Instance_Body
6513 then
6519 -- When the operand is a selected access discriminant
6520 -- the check needs to be made against the level of the
6521 -- object denoted by the prefix of the selected name.
6522 -- Force Program_Error for this case as well (this
6523 -- accessibility violation can only happen if within
6524 -- the body of an instantiation).
6526 elsif In_Instance_Body
6531 then
6539 -- Case of conversions of tagged types and access to tagged types
6541 -- When needed, that is to say when the expression is class-wide,
6542 -- Add runtime a tag check for (strict) downward conversion by using
6543 -- the membership test, generating:
6545 -- [constraint_error when Operand not in Target_Type'Class]
6547 -- or in the access type case
6549 -- [constraint_error
6550 -- when Operand /= null
6551 -- and then Operand.all not in
6552 -- Designated_Type (Target_Type)'Class]
6557 then
6558 -- Do not do any expansion in the access type case if the
6559 -- parent is a renaming, since this is an error situation
6560 -- which will be caught by Sem_Ch8, and the expansion can
6561 -- intefere with this error check.
6565 then
6569 -- Oherwise, proceed with processing tagged conversion
6571 declare
6577 begin
6582 else
6589 and then Is_Ancestor
6591 Actual_Target_Type)
6593 then
6594 -- The conversion is valid for any descendant of the
6595 -- target type
6600 Cond :=
6602 Left_Opnd =>
6607 Right_Opnd =>
6609 Left_Opnd =>
6611 Prefix =>
6613 Right_Opnd =>
6616 else
6617 Cond :=
6620 Right_Opnd =>
6629 declare
6631 begin
6632 Conv :=
6642 -- Case of other access type conversions
6647 -- Case of conversions from a fixed-point type
6649 -- These conversions require special expansion and processing, found
6650 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
6651 -- set, since from a semantic point of view, these are simple integer
6652 -- conversions, which do not need further processing.
6656 then
6657 -- We should never see universal fixed at this case, since the
6658 -- expansion of the constituent divide or multiply should have
6659 -- eliminated the explicit mention of universal fixed.
6663 -- Check for special case of the conversion to universal real
6664 -- that occurs as a result of the use of a round attribute.
6665 -- In this case, the real type for the conversion is taken
6666 -- from the target type of the Round attribute and the
6667 -- result must be marked as rounded.
6672 then
6677 -- Otherwise do correct fixed-conversion, but skip these if the
6678 -- Conversion_OK flag is set, because from a semantic point of
6679 -- view these are simple integer conversions needing no further
6680 -- processing (the backend will simply treat them as integers)
6685 Real_Range_Check;
6690 else
6693 Real_Range_Check;
6697 -- Case of conversions to a fixed-point type
6699 -- These conversions require special expansion and processing, found
6700 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6701 -- is set, since from a semantic point of view, these are simple
6702 -- integer conversions, which do not need further processing.
6706 then
6709 Real_Range_Check;
6710 else
6713 Real_Range_Check;
6716 -- Case of float-to-integer conversions
6718 -- We also handle float-to-fixed conversions with Conversion_OK set
6719 -- since semantically the fixed-point target is treated as though it
6720 -- were an integer in such cases.
6723 and then
6725 or else
6727 then
6728 -- Special processing required if the conversion is the expression
6729 -- of a Truncation attribute reference. In this case we replace:
6731 -- ityp (ftyp'Truncation (x))
6733 -- by
6735 -- ityp (x)
6737 -- with the Float_Truncate flag set. This is clearly more efficient
6741 then
6747 -- One more check here, gcc is still not able to do conversions of
6748 -- this type with proper overflow checking, and so gigi is doing an
6749 -- approximation of what is required by doing floating-point compares
6750 -- with the end-point. But that can lose precision in some cases, and
6751 -- give a wrong result. Converting the operand to Long_Long_Float is
6752 -- helpful, but still does not catch all cases with 64-bit integers
6753 -- on targets with only 64-bit floats ???
6758 Subtype_Mark =>
6760 Expression =>
6768 -- Case of array conversions
6770 -- Expansion of array conversions, add required length/range checks
6771 -- but only do this if there is no change of representation. For
6772 -- handling of this case, see Handle_Changed_Representation.
6778 else
6782 Handle_Changed_Representation;
6784 -- Case of conversions of discriminated types
6786 -- Add required discriminant checks if target is constrained. Again
6787 -- this change is skipped if we have a change of representation.
6791 then
6793 Handle_Changed_Representation;
6795 -- Case of all other record conversions. The only processing required
6796 -- is to check for a change of representation requiring the special
6797 -- assignment processing.
6801 -- Ada 2005 (AI-216): Program_Error is raised when converting from
6802 -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
6803 -- Union type if the operand lacks inferable discriminants.
6810 then
6811 -- To prevent Gigi from generating illegal code, we make a
6812 -- Program_Error node, but we give it the target type of the
6813 -- conversion.
6815 declare
6819 begin
6824 else
6825 Handle_Changed_Representation;
6828 -- Case of conversions of enumeration types
6832 -- Special processing is required if there is a change of
6833 -- representation (from enumeration representation clauses)
6837 -- Convert: x(y) to x'val (ytyp'val (y))
6852 -- Case of conversions to floating-point
6855 Real_Range_Check;
6857 -- The remaining cases require no front end processing
6859 else
6863 -- At this stage, either the conversion node has been transformed
6864 -- into some other equivalent expression, or left as a conversion
6865 -- that can be handled by Gigi. The conversions that Gigi can handle
6866 -- are the following:
6868 -- Conversions with no change of representation or type
6870 -- Numeric conversions involving integer values, floating-point
6871 -- values, and fixed-point values. Fixed-point values are allowed
6872 -- only if Conversion_OK is set, i.e. if the fixed-point values
6873 -- are to be treated as integers.
6875 -- No other conversions should be passed to Gigi
6877 -- Check: are these rules stated in sinfo??? if so, why restate here???
6879 -- The only remaining step is to generate a range check if we still
6880 -- have a type conversion at this stage and Do_Range_Check is set.
6881 -- For now we do this only for conversions of discrete types.
6885 then
6886 declare
6891 begin
6894 then
6897 -- Before we do a range check, we have to deal with treating
6898 -- a fixed-point operand as an integer. The way we do this
6899 -- is simply to do an unchecked conversion to an appropriate
6900 -- integer type large enough to hold the result.
6902 -- This code is not active yet, because we are only dealing
6903 -- with discrete types so far ???
6907 then
6912 else
6919 -- Reset overflow flag, since the range check will include
6920 -- dealing with possible overflow, and generate the check
6921 -- If Address is either source or target type, suppress
6922 -- range check to avoid typing anomalies when it is a visible
6923 -- integer type.
6928 then
6929 Generate_Range_Check
6937 -----------------------------------
6938 -- Expand_N_Unchecked_Expression --
6939 -----------------------------------
6941 -- Remove the unchecked expression node from the tree. It's job was simply
6942 -- to make sure that its constituent expression was handled with checks
6943 -- off, and now that that is done, we can remove it from the tree, and
6944 -- indeed must, since gigi does not expect to see these nodes.
6949 begin
6954 ----------------------------------------
6955 -- Expand_N_Unchecked_Type_Conversion --
6956 ----------------------------------------
6958 -- If this cannot be handled by Gigi and we haven't already made
6959 -- a temporary for it, do it now.
6966 begin
6967 -- If we have a conversion of a compile time known value to a target
6968 -- type and the value is in range of the target type, then we can simply
6969 -- replace the construct by an integer literal of the correct type. We
6970 -- only apply this to integer types being converted. Possibly it may
6971 -- apply in other cases, but it is too much trouble to worry about.
6973 -- Note that we do not do this transformation if the Kill_Range_Check
6974 -- flag is set, since then the value may be outside the expected range.
6975 -- This happens in the Normalize_Scalars case.
6981 then
6982 declare
6985 begin
6987 and then
6989 and then
6991 and then
6993 then
6996 -- If Address is the target type, just set the type
6997 -- to avoid a spurious type error on the literal when
6998 -- Address is a visible integer type.
7002 else
7011 -- Nothing to do if conversion is safe
7017 -- Otherwise force evaluation unless Assignment_OK flag is set (this
7018 -- flag indicates ??? -- more comments needed here)
7022 else
7027 ----------------------------
7028 -- Expand_Record_Equality --
7029 ----------------------------
7031 -- For non-variant records, Equality is expanded when needed into:
7033 -- and then Lhs.Discr1 = Rhs.Discr1
7034 -- and then ...
7035 -- and then Lhs.Discrn = Rhs.Discrn
7036 -- and then Lhs.Cmp1 = Rhs.Cmp1
7037 -- and then ...
7038 -- and then Lhs.Cmpn = Rhs.Cmpn
7040 -- The expression is folded by the back-end for adjacent fields. This
7041 -- function is called for tagged record in only one occasion: for imple-
7042 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
7043 -- otherwise the primitive "=" is used directly.
7045 function Expand_Record_Equality
7051 is
7060 -- Return the first field to compare beginning with C, skipping the
7061 -- inherited components.
7063 ----------------------
7064 -- Suitable_Element --
7065 ----------------------
7068 begin
7074 then
7079 then
7084 then
7087 else
7092 -- Start of processing for Expand_Record_Equality
7094 begin
7095 -- Generates the following code: (assuming that Typ has one Discr and
7096 -- component C2 is also a record)
7098 -- True
7099 -- and then Lhs.Discr1 = Rhs.Discr1
7100 -- and then Lhs.C1 = Rhs.C1
7101 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
7102 -- and then ...
7103 -- and then Lhs.Cmpn = Rhs.Cmpn
7109 declare
7114 begin
7119 else
7124 Check :=
7126 Lhs =>
7130 Rhs =>
7136 -- If some (sub)component is an unchecked_union, the whole
7137 -- operation will raise program error.
7143 else
7144 Result :=
7157 -------------------------------------
7158 -- Fixup_Universal_Fixed_Operation --
7159 -------------------------------------
7164 begin
7165 -- We must have a type conversion immediately above us
7169 -- Normally the type conversion gives our target type. The exception
7170 -- occurs in the case of the Round attribute, where the conversion
7171 -- will be to universal real, and our real type comes from the Round
7172 -- attribute (as well as an indication that we must round the result)
7176 then
7180 -- Normal case where type comes from conversion above us
7182 else
7187 ------------------------------
7188 -- Get_Allocator_Final_List --
7189 ------------------------------
7191 function Get_Allocator_Final_List
7195 is
7199 -- The entity whose finalisation list must be used to attach the
7200 -- allocated object.
7202 begin
7205 in N_Subprogram_Specification
7206 then
7207 -- If the context is an access parameter, we need to create
7208 -- a non-anonymous access type in order to have a usable
7209 -- final list, because there is otherwise no pool to which
7210 -- the allocated object can belong. We create both the type
7211 -- and the finalization chain here, because freezing an
7212 -- internal type does not create such a chain. The Final_Chain
7213 -- that is thus created is shared by the access parameter.
7219 Type_Definition =>
7221 Subtype_Indication =>
7227 else
7228 -- Case of an access discriminant, or (Ada 2005) of
7229 -- an anonymous access component: find the final list
7230 -- associated with the scope of the type.
7239 ---------------------------------
7240 -- Has_Inferable_Discriminants --
7241 ---------------------------------
7246 -- Determines whether the left-most prefix of a selected component is a
7247 -- formal parameter in a subprogram. Assumes N is a selected component.
7249 --------------------------------
7250 -- Prefix_Is_Formal_Parameter --
7251 --------------------------------
7256 begin
7257 -- Move to the left-most prefix by climbing up the tree
7261 loop
7268 -- Start of processing for Has_Inferable_Discriminants
7270 begin
7271 -- For identifiers and indexed components, it is sufficent to have a
7272 -- constrained Unchecked_Union nominal subtype.
7275 or else
7277 then
7279 and then
7282 -- For selected components, the subtype of the selector must be a
7283 -- constrained Unchecked_Union. If the component is subject to a
7284 -- per-object constraint, then the enclosing object must have inferable
7285 -- discriminants.
7290 -- A small hack. If we have a per-object constrained selected
7291 -- component of a formal parameter, return True since we do not
7292 -- know the actual parameter association yet.
7298 -- Otherwise, check the enclosing object and the selector
7301 and then
7305 -- The call to Has_Inferable_Discriminants will determine whether
7306 -- the selector has a constrained Unchecked_Union nominal type.
7310 -- A qualified expression has inferable discriminants if its subtype
7311 -- mark is a constrained Unchecked_Union subtype.
7315 and then
7323 -------------------------------
7324 -- Insert_Dereference_Action --
7325 -------------------------------
7334 -- Return true if type of P is derived from Checked_Pool;
7336 -----------------------------
7337 -- Is_Checked_Storage_Pool --
7338 -----------------------------
7343 begin
7352 else
7360 -- Start of processing for Insert_Dereference_Action
7362 begin
7367 then
7378 -- Pool
7382 -- Storage_Address. We use the attribute Pool_Address,
7383 -- which uses the pointer itself to find the address of
7384 -- the object, and which handles unconstrained arrays
7385 -- properly by computing the address of the template.
7386 -- i.e. the correct address of the corresponding allocation.
7392 -- Size_In_Storage_Elements
7395 Left_Opnd =>
7397 Prefix =>
7401 Right_Opnd =>
7404 -- Alignment
7407 Prefix =>
7412 exception
7417 ------------------------------
7418 -- Make_Array_Comparison_Op --
7419 ------------------------------
7421 -- This is a hand-coded expansion of the following generic function:
7423 -- generic
7424 -- type elem is (<>);
7425 -- type index is (<>);
7426 -- type a is array (index range <>) of elem;
7427 --
7428 -- function Gnnn (X : a; Y: a) return boolean is
7429 -- J : index := Y'first;
7430 --
7431 -- begin
7432 -- if X'length = 0 then
7433 -- return false;
7434 --
7435 -- elsif Y'length = 0 then
7436 -- return true;
7437 --
7438 -- else
7439 -- for I in X'range loop
7440 -- if X (I) = Y (J) then
7441 -- if J = Y'last then
7442 -- exit;
7443 -- else
7444 -- J := index'succ (J);
7445 -- end if;
7446 --
7447 -- else
7448 -- return X (I) > Y (J);
7449 -- end if;
7450 -- end loop;
7451 --
7452 -- return X'length > Y'length;
7453 -- end if;
7454 -- end Gnnn;
7456 -- Note that since we are essentially doing this expansion by hand, we
7457 -- do not need to generate an actual or formal generic part, just the
7458 -- instantiated function itself.
7460 function Make_Array_Comparison_Op
7463 is
7484 begin
7485 -- if J = Y'last then
7486 -- exit;
7487 -- else
7488 -- J := index'succ (J);
7489 -- end if;
7491 Inner_If :=
7493 Condition =>
7496 Right_Opnd =>
7504 Else_Statements =>
7505 New_List (
7508 Expression =>
7514 -- if X (I) = Y (J) then
7515 -- if ... end if;
7516 -- else
7517 -- return X (I) > Y (J);
7518 -- end if;
7520 Loop_Body :=
7522 Condition =>
7524 Left_Opnd =>
7529 Right_Opnd =>
7538 Expression =>
7540 Left_Opnd =>
7545 Right_Opnd =>
7551 -- for I in X'range loop
7552 -- if ... end if;
7553 -- end loop;
7555 Loop_Statement :=
7559 Iteration_Scheme =>
7561 Loop_Parameter_Specification =>
7564 Discrete_Subtype_Definition =>
7571 -- if X'length = 0 then
7572 -- return false;
7573 -- elsif Y'length = 0 then
7574 -- return true;
7575 -- else
7576 -- for ... loop ... end loop;
7577 -- return X'length > Y'length;
7578 -- end if;
7580 Length1 :=
7585 Length2 :=
7590 Final_Expr :=
7595 If_Stat :=
7597 Condition =>
7599 Left_Opnd =>
7603 Right_Opnd =>
7606 Then_Statements =>
7607 New_List (
7613 Condition =>
7615 Left_Opnd =>
7619 Right_Opnd =>
7622 Then_Statements =>
7623 New_List (
7628 Loop_Statement,
7632 -- (X : a; Y: a)
7643 -- function Gnnn (...) return boolean is
7644 -- J : index := Y'first;
7645 -- begin
7646 -- if ... end if;
7647 -- end Gnnn;
7651 Func_Body :=
7653 Specification =>
7663 Expression =>
7668 Handled_Statement_Sequence =>
7676 ---------------------------
7677 -- Make_Boolean_Array_Op --
7678 ---------------------------
7680 -- For logical operations on boolean arrays, expand in line the
7681 -- following, replacing 'and' with 'or' or 'xor' where needed:
7683 -- function Annn (A : typ; B: typ) return typ is
7684 -- C : typ;
7685 -- begin
7686 -- for J in A'range loop
7687 -- C (J) := A (J) op B (J);
7688 -- end loop;
7689 -- return C;
7690 -- end Annn;
7692 -- Here typ is the boolean array type
7694 function Make_Boolean_Array_Op
7697 is
7715 begin
7716 A_J :=
7721 B_J :=
7726 C_J :=
7732 Op :=
7738 Op :=
7743 else
7744 Op :=
7750 Loop_Statement :=
7754 Iteration_Scheme =>
7756 Loop_Parameter_Specification =>
7759 Discrete_Subtype_Definition =>
7778 Func_Name :=
7782 Func_Body :=
7784 Specification =>
7795 Handled_Statement_Sequence =>
7798 Loop_Statement,
7805 ------------------------
7806 -- Rewrite_Comparison --
7807 ------------------------
7815 -- Res indicates if compare outcome can be determined at compile time
7820 begin
7861 ----------------------------
7862 -- Safe_In_Place_Array_Op --
7863 ----------------------------
7865 function Safe_In_Place_Array_Op
7869 is
7873 -- Operand is safe if it cannot overlap part of the target of the
7874 -- operation. If the operand and the target are identical, the operand
7875 -- is safe. The operand can be empty in the case of negation.
7878 -- Check that N is a stand-alone entity
7880 ------------------
7881 -- Is_Unaliased --
7882 ------------------
7885 begin
7886 return
7892 ---------------------
7893 -- Is_Safe_Operand --
7894 ---------------------
7897 begin
7906 then
7910 return
7917 else
7922 -- Start of processing for Is_Safe_In_Place_Array_Op
7924 begin
7925 -- We skip this processing if the component size is not the
7926 -- same as a system storage unit (since at least for NOT
7927 -- this would cause problems).
7932 -- Cannot do in place stuff on Java_VM since cannot pass addresses
7937 -- Cannot do in place stuff if non-standard Boolean representation
7944 else
7947 return
7953 -----------------------
7954 -- Tagged_Membership --
7955 -----------------------
7957 -- There are two different cases to consider depending on whether
7958 -- the right operand is a class-wide type or not. If not we just
7959 -- compare the actual tag of the left expr to the target type tag:
7960 --
7961 -- Left_Expr.Tag = Right_Type'Tag;
7962 --
7963 -- If it is a class-wide type we use the RT function CW_Membership which
7964 -- is usually implemented by looking in the ancestor tables contained in
7965 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
7976 begin
7984 Obj_Tag :=
7990 return
7994 Obj_Tag,
7995 New_Reference_To (
7997 else
7998 return
8001 Right_Opnd =>
8007 ------------------------------
8008 -- Unary_Op_Validity_Checks --
8009 ------------------------------
8012 begin