| blob | 2e1f38f88e4110a8a0bcb01d7e38a70cebbee489 |
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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 ---------------------------------
380 begin
383 -- Actions inserted before:
384 -- Temp : constant ptr_T := new T'(Expression);
385 -- <no CW> Temp._tag := T'tag;
386 -- <CTRL> Adjust (Finalizable (Temp.all));
387 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
389 -- We analyze by hand the new internal allocator to avoid
390 -- any recursion and inappropriate call to Initialize
396 Temp :=
399 -- For a class wide allocation generate the following code:
401 -- type Equiv_Record is record ... end record;
402 -- implicit subtype CW is <Class_Wide_Subytpe>;
403 -- temp : PtrT := new CW'(CW!(expr));
415 Tmp_Node :=
419 Expression =>
423 Set_Comes_From_Source
431 then
432 -- Create local finalization list for access parameter
438 else
449 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
450 -- type, generate an accessibility check to verify that the level of
451 -- the type of the created object is not deeper than the level of the
452 -- access type. If the type of the qualified expression is class-
453 -- wide, then always generate the check. Otherwise, only generate the
454 -- check if the level of the qualified expression type is statically
455 -- deeper than the access type. Although the static accessibility
456 -- will generally have been performed as a legality check, it won't
457 -- have been done in cases where the allocator appears in generic
458 -- body, so a run-time check is needed in general.
463 and then
465 or else
467 then
470 Condition =>
472 Left_Opnd =>
474 Name =>
476 Parameter_Associations =>
478 Prefix =>
480 Attribute_Name =>
481 Name_Tag))),
482 Right_Opnd =>
487 -- Suppress the tag assignment when Java_VM because JVM tags
488 -- are represented implicitly in objects.
492 and then not Java_VM
493 then
494 Tag_Assign :=
496 Name =>
499 Selector_Name =>
502 Expression =>
504 New_Reference_To
506 Loc)));
508 -- The previous assignment has to be done in any case
515 and then not Java_VM
516 then
517 declare
524 begin
525 Tag_Assign :=
527 Name =>
530 Selector_Name =>
533 Expression =>
535 New_Reference_To (
537 Loc)));
546 then
547 declare
552 begin
553 -- If it is an allocation on the secondary stack
554 -- (i.e. a value returned from a function), the object
555 -- is attached on the caller side as soon as the call
556 -- is completed (see Expand_Ctrl_Function_Call)
559 declare
563 begin
574 -- Normal case, not a secondary stack allocation
576 else
579 then
580 -- Create local finalization list for access parameter
582 Flist :=
584 else
593 Make_Adjust_Call (
594 Ref =>
596 -- An unchecked conversion is needed in the
597 -- classwide case because the designated type
598 -- can be an ancestor of the subtype mark of
599 -- the allocator.
616 Temp :=
618 Tmp_Node :=
625 Set_Comes_From_Source
637 then
638 -- Apply constraint to designated subtype indication
646 -- Propagate constraint_error to enclosing allocator
650 else
651 -- First check against the type of the qualified expression
652 --
653 -- NOTE: The commented call should be correct, but for
654 -- some reason causes the compiler to bomb (sigsegv) on
655 -- ACVC test c34007g, so for now we just perform the old
656 -- (incorrect) test against the designated subtype with
657 -- no sliding in the else part of the if statement below.
658 -- ???
659 --
660 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
662 -- A check is also needed in cases where the designated
663 -- subtype is constrained and differs from the subtype
664 -- given in the qualified expression. Note that the check
665 -- on the qualified expression does not allow sliding,
666 -- but this check does (a relaxation from Ada 83).
669 and then not Subtypes_Statically_Match
671 then
672 Apply_Constraint_Check
675 -- The nonsliding check should really be performed
676 -- (unconditionally) against the subtype of the
677 -- qualified expression, but that causes a problem
678 -- with c34007g (see above), so for now we retain this.
680 else
681 Apply_Constraint_Check
685 -- For an access to unconstrained packed array, GIGI needs
686 -- to see an expression with a constrained subtype in order
687 -- to compute the proper size for the allocator.
692 then
693 declare
698 begin
702 Subtype_Indication =>
711 exception
716 -----------------------------
717 -- Expand_Array_Comparison --
718 -----------------------------
720 -- Expansion is only required in the case of array types. For the
721 -- unpacked case, an appropriate runtime routine is called. For
722 -- packed cases, and also in some other cases where a runtime
723 -- routine cannot be called, the form of the expansion is:
725 -- [body for greater_nn; boolean_expression]
727 -- The body is built by Make_Array_Comparison_Op, and the form of the
728 -- Boolean expression depends on the operator involved.
744 -- True for byte addressable target
747 -- Returns True if the length of the given operand is known to be
748 -- less than 4. Returns False if this length is known to be four
749 -- or greater or is not known at compile time.
751 ------------------------
752 -- Length_Less_Than_4 --
753 ------------------------
758 begin
762 else
763 declare
770 begin
773 else
779 else
788 -- Start of processing for Expand_Array_Comparison
790 begin
791 -- Deal first with unpacked case, where we can call a runtime routine
792 -- except that we avoid this for targets for which are not addressable
793 -- by bytes, and for the JVM, since the JVM does not support direct
794 -- addressing of array components.
797 and then Byte_Addressable
798 and then not Java_VM
799 then
800 -- The call we generate is:
802 -- Compare_Array_xn[_Unaligned]
803 -- (left'address, right'address, left'length, right'length) <op> 0
805 -- x = U for unsigned, S for signed
806 -- n = 8,16,32,64 for component size
807 -- Add _Unaligned if length < 4 and component size is 8.
808 -- <op> is the standard comparison operator
812 or else
814 then
817 else
821 else
824 else
832 else
839 else
846 else
884 -- Cases where we cannot make runtime call
886 -- For (a <= b) we convert to not (a > b)
891 Right_Opnd =>
898 -- For < the Boolean expression is
899 -- greater__nn (op2, op1)
904 -- Switch operands
909 -- For (a >= b) we convert to not (a < b)
914 Right_Opnd =>
921 -- For > the Boolean expression is
922 -- greater__nn (op1, op2)
924 else
930 Expr :=
939 exception
944 ---------------------------
945 -- Expand_Array_Equality --
946 ---------------------------
948 -- Expand an equality function for multi-dimensional arrays. Here is
949 -- an example of such a function for Nb_Dimension = 2
951 -- function Enn (A : atyp; B : btyp) return boolean is
952 -- begin
953 -- if (A'length (1) = 0 or else A'length (2) = 0)
954 -- and then
955 -- (B'length (1) = 0 or else B'length (2) = 0)
956 -- then
957 -- return True; -- RM 4.5.2(22)
958 -- end if;
960 -- if A'length (1) /= B'length (1)
961 -- or else
962 -- A'length (2) /= B'length (2)
963 -- then
964 -- return False; -- RM 4.5.2(23)
965 -- end if;
967 -- declare
968 -- A1 : Index_T1 := A'first (1);
969 -- B1 : Index_T1 := B'first (1);
970 -- begin
971 -- loop
972 -- declare
973 -- A2 : Index_T2 := A'first (2);
974 -- B2 : Index_T2 := B'first (2);
975 -- begin
976 -- loop
977 -- if A (A1, A2) /= B (B1, B2) then
978 -- return False;
979 -- end if;
981 -- exit when A2 = A'last (2);
982 -- A2 := Index_T2'succ (A2);
983 -- B2 := Index_T2'succ (B2);
984 -- end loop;
985 -- end;
987 -- exit when A1 = A'last (1);
988 -- A1 := Index_T1'succ (A1);
989 -- B1 := Index_T1'succ (B1);
990 -- end loop;
991 -- end;
993 -- return true;
994 -- end Enn;
996 -- Note on the formal types used (atyp and btyp). If either of the
997 -- arrays is of a private type, we use the underlying type, and
998 -- do an unchecked conversion of the actual. If either of the arrays
999 -- has a bound depending on a discriminant, then we use the base type
1000 -- since otherwise we have an escaped discriminant in the function.
1002 -- If both arrays are constrained and have the same bounds, we can
1003 -- generate a loop with an explicit iteration scheme using a 'Range
1004 -- attribute over the first array.
1006 function Expand_Array_Equality
1012 is
1028 -- The parameter types to be used for the formals
1030 function Arr_Attr
1034 -- This builds the attribute reference Arr'Nam (Expr)
1037 -- Create one statement to compare corresponding components,
1038 -- designated by a full set of indices.
1041 -- Given one of the arguments, computes the appropriate type to
1042 -- be used for that argument in the corresponding function formal
1044 function Handle_One_Dimension
1047 -- This procedure returns the following code
1048 --
1049 -- declare
1050 -- Bn : Index_T := B'First (N);
1051 -- begin
1052 -- loop
1053 -- xxx
1054 -- exit when An = A'Last (N);
1055 -- An := Index_T'Succ (An)
1056 -- Bn := Index_T'Succ (Bn)
1057 -- end loop;
1058 -- end;
1059 --
1060 -- If both indices are constrained and identical, the procedure
1061 -- returns a simpler loop:
1062 --
1063 -- for An in A'Range (N) loop
1064 -- xxx
1065 -- end loop
1066 --
1067 -- N is the dimension for which we are generating a loop. Index is the
1068 -- N'th index node, whose Etype is Index_Type_n in the above code.
1069 -- The xxx statement is either the loop or declare for the next
1070 -- dimension or if this is the last dimension the comparison
1071 -- of corresponding components of the arrays.
1072 --
1073 -- The actual way the code works is to return the comparison
1074 -- of corresponding components for the N+1 call. That's neater!
1077 -- This function constructs the test for both arrays being empty
1078 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1079 -- and then
1080 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1083 -- This function constructs the test for arrays having different
1084 -- lengths in at least one index position, in which case resull
1086 -- A'length (1) /= B'length (1)
1087 -- or else
1088 -- A'length (2) /= B'length (2)
1089 -- or else
1090 -- ...
1092 --------------
1093 -- Arr_Attr --
1094 --------------
1096 function Arr_Attr
1100 is
1101 begin
1102 return
1109 ------------------------
1110 -- Component_Equality --
1111 ------------------------
1117 begin
1118 -- if a(i1...) /= b(j1...) then return false; end if;
1120 L :=
1125 R :=
1130 Test := Expand_Composite_Equality
1133 -- If some (sub)component is an unchecked_union, the whole operation
1134 -- will raise program error.
1138 -- This node is going to be inserted at a location where a
1139 -- statement is expected: clear its Etype so analysis will
1140 -- set it to the expected Standard_Void_Type.
1145 else
1146 return
1155 ------------------
1156 -- Get_Arg_Type --
1157 ------------------
1163 begin
1169 else
1175 or else
1177 then
1189 --------------------------
1190 -- Handle_One_Dimension --
1191 ---------------------------
1193 function Handle_One_Dimension
1196 is
1198 Ltyp /= Rtyp
1200 -- If the index types are identical, and we are working with
1201 -- constrained types, then we can use the same index for both of
1202 -- the arrays.
1212 begin
1217 -- Case where we generate a loop
1222 Bn :=
1225 else
1237 -- Generate guard for loop, followed by increments of indices
1241 Condition =>
1249 Expression =>
1258 Expression =>
1265 -- If separate indexes, we need a declare block for An and Bn, and a
1266 -- loop without an iteration scheme.
1269 Loop_Stm :=
1272 return
1285 Handled_Statement_Sequence =>
1289 -- If no separate indexes, return loop statement with explicit
1290 -- iteration scheme on its own
1292 else
1293 Loop_Stm :=
1296 Iteration_Scheme =>
1298 Loop_Parameter_Specification =>
1301 Discrete_Subtype_Definition =>
1307 -----------------------
1308 -- Test_Empty_Arrays --
1309 -----------------------
1318 begin
1322 Atest :=
1327 Btest :=
1336 else
1337 Alist :=
1342 Blist :=
1349 return
1355 -----------------------------
1356 -- Test_Lengths_Correspond --
1357 -----------------------------
1363 begin
1366 Rtest :=
1373 else
1374 Result :=
1384 -- Start of processing for Expand_Array_Equality
1386 begin
1390 -- For now, if the argument types are not the same, go to the
1391 -- base type, since the code assumes that the formals have the
1392 -- same type. This is fixable in future ???
1400 -- Build list of formals for function
1413 -- Build statement sequence for function
1415 Func_Body :=
1417 Specification =>
1425 Handled_Statement_Sequence =>
1433 Expression =>
1440 Expression =>
1451 -- If the array type is distinct from the type of the arguments,
1452 -- it is the full view of a private type. Apply an unchecked
1453 -- conversion to insure that analysis of the call succeeds.
1455 declare
1458 begin
1464 then
1470 then
1479 return
1485 -----------------------------
1486 -- Expand_Boolean_Operator --
1487 -----------------------------
1489 -- Note that we first get the actual subtypes of the operands,
1490 -- since we always want to deal with types that have bounds.
1495 begin
1496 -- Special case of bit packed array where both operands are known
1497 -- to be properly aligned. In this case we use an efficient run time
1498 -- routine to carry out the operation (see System.Bit_Ops).
1503 then
1508 -- For the normal non-packed case, the general expansion is to build
1509 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1510 -- and then inserting it into the tree. The original operator node is
1511 -- then rewritten as a call to this function. We also use this in the
1512 -- packed case if either operand is a possibly unaligned object.
1514 declare
1521 begin
1530 then
1535 and then
1537 then
1539 else
1545 -- Now rewrite the expression with a call
1550 Parameter_Associations =>
1551 New_List (
1552 L,
1553 Make_Type_Conversion
1561 -------------------------------
1562 -- Expand_Composite_Equality --
1563 -------------------------------
1565 -- This function is only called for comparing internal fields of composite
1566 -- types when these fields are themselves composites. This is a special
1567 -- case because it is not possible to respect normal Ada visibility rules.
1569 function Expand_Composite_Equality
1575 is
1581 begin
1584 else
1588 -- Defense against malformed private types with no completion
1589 -- the error will be diagnosed later by check_completion
1599 -- If the operand is an elementary type other than a floating-point
1600 -- type, then we can simply use the built-in block bitwise equality,
1601 -- since the predefined equality operators always apply and bitwise
1602 -- equality is fine for all these cases.
1606 then
1609 -- For composite component types, and floating-point types, use
1610 -- the expansion. This deals with tagged component types (where
1611 -- we use the applicable equality routine) and floating-point,
1612 -- (where we need to worry about negative zeroes), and also the
1613 -- case of any composite type recursively containing such fields.
1615 else
1621 -- Call the primitive operation "=" of this type
1627 -- If this is derived from an untagged private type completed
1628 -- with a tagged type, it does not have a full view, so we
1629 -- use the primitive operations of the private type.
1630 -- This check should no longer be necessary when these
1631 -- types receive their full views ???
1638 then
1640 else
1644 loop
1656 return
1659 Parameter_Associations =>
1660 New_List
1670 -- Inherited equality from parent type. Convert the actuals
1671 -- to match signature of operation.
1673 declare
1676 begin
1677 return
1680 Parameter_Associations =>
1685 else
1686 -- Comparison between Unchecked_Union components
1689 declare
1695 begin
1696 -- Lhs subtype
1702 -- Rhs subtype
1708 -- Lhs of the composite equality
1712 -- Since the enclosing record can never be an
1713 -- Unchecked_Union (this code is executed for records
1714 -- that do not have variants), we may reference its
1715 -- discriminant(s).
1720 then
1721 Lhs_Discr_Val :=
1724 Selector_Name =>
1725 New_Copy (
1726 Get_Discriminant_Value (
1728 Lhs_Type,
1731 else
1733 Get_Discriminant_Value (
1735 Lhs_Type,
1739 else
1740 -- It is not possible to infer the discriminant since
1741 -- the subtype is not constrained.
1743 return
1748 -- Rhs of the composite equality
1754 then
1755 Rhs_Discr_Val :=
1758 Selector_Name =>
1759 New_Copy (
1760 Get_Discriminant_Value (
1762 Rhs_Type,
1765 else
1767 Get_Discriminant_Value (
1769 Rhs_Type,
1773 else
1774 return
1779 -- Call the TSS equality function with the inferred
1780 -- discriminant values.
1782 return
1786 Lhs,
1787 Rhs,
1788 Lhs_Discr_Val,
1789 Rhs_Discr_Val));
1793 -- Shouldn't this be an else, we can't fall through
1794 -- the above IF, right???
1796 return
1802 else
1806 else
1807 -- It can be a simple record or the full view of a scalar private
1813 ------------------------------
1814 -- Expand_Concatenate_Other --
1815 ------------------------------
1817 -- Let n be the number of array operands to be concatenated, Base_Typ
1818 -- their base type, Ind_Typ their index type, and Arr_Typ the original
1819 -- array type to which the concatenantion operator applies, then the
1820 -- following subprogram is constructed:
1822 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1823 -- L : Ind_Typ;
1824 -- begin
1825 -- if S1'Length /= 0 then
1826 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
1827 -- XXX = Arr_Typ'First otherwise
1828 -- elsif S2'Length /= 0 then
1829 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
1830 -- YYY = Arr_Typ'First otherwise
1831 -- ...
1832 -- elsif Sn-1'Length /= 0 then
1833 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
1834 -- ZZZ = Arr_Typ'First otherwise
1835 -- else
1836 -- return Sn;
1837 -- end if;
1839 -- declare
1840 -- P : Ind_Typ;
1841 -- H : Ind_Typ :=
1842 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1843 -- + Ind_Typ'Pos (L));
1844 -- R : Base_Typ (L .. H);
1845 -- begin
1846 -- if S1'Length /= 0 then
1847 -- P := S1'First;
1848 -- loop
1849 -- R (L) := S1 (P);
1850 -- L := Ind_Typ'Succ (L);
1851 -- exit when P = S1'Last;
1852 -- P := Ind_Typ'Succ (P);
1853 -- end loop;
1854 -- end if;
1855 --
1856 -- if S2'Length /= 0 then
1857 -- L := Ind_Typ'Succ (L);
1858 -- loop
1859 -- R (L) := S2 (P);
1860 -- L := Ind_Typ'Succ (L);
1861 -- exit when P = S2'Last;
1862 -- P := Ind_Typ'Succ (P);
1863 -- end loop;
1864 -- end if;
1866 -- ...
1868 -- if Sn'Length /= 0 then
1869 -- P := Sn'First;
1870 -- loop
1871 -- R (L) := Sn (P);
1872 -- L := Ind_Typ'Succ (L);
1873 -- exit when P = Sn'Last;
1874 -- P := Ind_Typ'Succ (P);
1875 -- end loop;
1876 -- end if;
1878 -- return R;
1879 -- end;
1880 -- end Cnn;]
1918 -- Builds the sequence of statement:
1919 -- P := Si'First;
1920 -- loop
1921 -- R (L) := Si (P);
1922 -- L := Ind_Typ'Succ (L);
1923 -- exit when P = Si'Last;
1924 -- P := Ind_Typ'Succ (P);
1925 -- end loop;
1926 --
1927 -- where i is the input parameter I given.
1928 -- If the flag Last is true, the exit statement is emitted before
1929 -- incrementing the lower bound, to prevent the creation out of
1930 -- bound values.
1933 -- Builds the statement:
1934 -- L := Arr_Typ'First; If Arr_Typ is constrained
1935 -- L := Si'First; otherwise (where I is the input param given)
1938 -- Builds reference to identifier H
1941 -- Builds expression Ind_Typ'Val (E);
1944 -- Builds reference to identifier L
1947 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
1948 -- expression to avoid universal_integer computations whenever possible,
1949 -- in the expression for the upper bound H.
1952 -- Builds expression Ind_Typ'Succ (L)
1955 -- Builds integer literal one
1958 -- Builds reference to identifier P
1961 -- Builds expression Ind_Typ'Succ (P)
1964 -- Builds reference to identifier R
1967 -- Builds reference to identifier Si, where I is the value given
1970 -- Builds expression Si'First, where I is the value given
1973 -- Builds expression Si'Last, where I is the value given
1976 -- Builds expression Si'Length, where I is the value given
1979 -- Builds expression Si'Length /= 0, where I is the value given
1981 -------------------
1982 -- Copy_Into_R_S --
1983 -------------------
1994 begin
1995 -- First construct the initializations
2002 -- Then build the loop
2024 Loop_Stmt :=
2027 else
2028 Loop_Stmt :=
2038 -------
2039 -- H --
2040 -------
2043 begin
2047 -------------
2048 -- Ind_Val --
2049 -------------
2052 begin
2053 return
2060 ------------
2061 -- Init_L --
2062 ------------
2067 begin
2073 else
2080 -------
2081 -- L --
2082 -------
2085 begin
2089 -----------
2090 -- L_Pos --
2091 -----------
2096 begin
2097 -- If the index type is an enumeration type, the computation
2098 -- can be done in standard integer. Otherwise, choose a large
2099 -- enough integer type.
2105 then
2107 else
2111 return
2114 Expression =>
2121 ------------
2122 -- L_Succ --
2123 ------------
2126 begin
2127 return
2134 ---------
2135 -- One --
2136 ---------
2139 begin
2143 -------
2144 -- P --
2145 -------
2148 begin
2152 ------------
2153 -- P_Succ --
2154 ------------
2157 begin
2158 return
2165 -------
2166 -- R --
2167 -------
2170 begin
2174 -------
2175 -- S --
2176 -------
2179 begin
2183 -------------
2184 -- S_First --
2185 -------------
2188 begin
2194 ------------
2195 -- S_Last --
2196 ------------
2199 begin
2205 --------------
2206 -- S_Length --
2207 --------------
2210 begin
2216 -------------------
2217 -- S_Length_Test --
2218 -------------------
2221 begin
2222 return
2228 -- Start of processing for Expand_Concatenate_Other
2230 begin
2231 -- Construct the parameter specs and the overall function spec
2235 Append_To
2238 Defining_Identifier =>
2244 Func_Spec :=
2250 -- Construct L's object declaration
2252 L_Decl :=
2259 -- Construct the if-then-elsif statements
2268 If_Stmt :=
2276 -- Construct the declaration for H
2278 P_Decl :=
2289 H_Decl :=
2295 -- Construct the declaration for R
2298 R_Constr :=
2302 R_Decl :=
2305 Object_Definition =>
2310 -- Construct the declarations for the declare block
2314 -- Construct list of statements for the declare block
2326 -- Construct the declare block
2330 Handled_Statement_Sequence =>
2333 -- Construct the list of function statements
2337 -- Construct the function body
2339 Func_Body :=
2343 Handled_Statement_Sequence =>
2346 -- Insert the newly generated function in the code. This is analyzed
2347 -- with all checks off, since we have completed all the checks.
2349 -- Note that this does *not* fix the array concatenation bug when the
2350 -- low bound is Integer'first sibce that bug comes from the pointer
2351 -- dereferencing an unconstrained array. An there we need a constraint
2352 -- check to make sure the length of the concatenated array is ok. ???
2356 -- Construct list of arguments for the function call
2365 -- Insert the function call
2367 Rewrite
2375 -------------------------------
2376 -- Expand_Concatenate_String --
2377 -------------------------------
2387 -- RE_Id value for function to be called
2389 begin
2390 -- In all cases, we build a call to a routine giving the list of
2391 -- arguments as the parameter list to the routine.
2399 else
2408 else
2413 -- If we have anything other than Standard_Character or
2414 -- Standard_String, then we must have had a serious error
2415 -- earlier, so we just abandon the attempt at expansion.
2417 else
2436 -- Now generate the appropriate call
2445 exception
2450 ------------------------
2451 -- Expand_N_Allocator --
2452 ------------------------
2462 begin
2463 -- RM E.2.3(22). We enforce that the expected type of an allocator
2464 -- shall not be a remote access-to-class-wide-limited-private type
2466 -- Why is this being done at expansion time, seems clearly wrong ???
2470 -- Set the Storage Pool
2483 else
2489 -- Under certain circumstances we can replace an allocator by an
2490 -- access to statically allocated storage. The conditions, as noted
2491 -- in AARM 3.10 (10c) are as follows:
2493 -- Size and initial value is known at compile time
2494 -- Access type is access-to-constant
2496 -- The allocator is not part of a constraint on a record component,
2497 -- because in that case the inserted actions are delayed until the
2498 -- record declaration is fully analyzed, which is too late for the
2499 -- analysis of the rewritten allocator.
2507 then
2508 -- Here we can do the optimization. For the allocator
2510 -- new x'(y)
2512 -- We insert an object declaration
2514 -- Tnn : aliased x := y;
2516 -- and replace the allocator by Tnn'Unrestricted_Access.
2517 -- Tnn is marked as requiring static allocation.
2519 Temp :=
2524 -- If context is constrained, use constrained subtype directly,
2525 -- so that the constant is not labelled as having a nomimally
2526 -- unconstrained subtype.
2547 -- We set the variable as statically allocated, since we don't
2548 -- want it going on the stack of the current procedure!
2554 -- Handle case of qualified expression (other than optimization above)
2559 -- If the allocator is for a type which requires initialization, and
2560 -- there is no initial value (i.e. operand is a subtype indication
2561 -- rather than a qualifed expression), then we must generate a call
2562 -- to the initialization routine. This is done using an expression
2563 -- actions node:
2564 --
2565 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2566 --
2567 -- Here ptr_T is the pointer type for the allocator, and T is the
2568 -- subtype of the allocator. A special case arises if the designated
2569 -- type of the access type is a task or contains tasks. In this case
2570 -- the call to Init (Temp.all ...) is replaced by code that ensures
2571 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2572 -- for details). In addition, if the type T is a task T, then the
2573 -- first argument to Init must be converted to the task record type.
2575 else
2576 declare
2589 begin
2593 -- Case of no initialization procedure present
2597 -- Case of simple initialization required
2610 -- No initialization required
2612 else
2616 -- Case of initialization procedure present, must be called
2618 else
2621 Temp :=
2624 -- Construct argument list for the initialization routine call
2625 -- The CPP constructor needs the address directly
2631 else
2632 Arg1 :=
2638 -- The initialization procedure expects a specific type.
2639 -- if the context is access to class wide, indicate that
2640 -- the object being allocated has the right specific type.
2647 -- If designated type is a concurrent type or if it is a
2648 -- private type whose definition is a concurrent type,
2649 -- the first argument in the Init routine has to be
2650 -- unchecked conversion to the corresponding record type.
2651 -- If the designated type is a derived type, we also
2652 -- convert the argument to its root type.
2655 Arg1 :=
2661 then
2662 Arg1 :=
2663 Unchecked_Convert_To
2668 declare
2671 begin
2679 -- For the task case, pass the Master_Id of the access type
2680 -- as the value of the _Master parameter, and _Chain as the
2681 -- value of the _Chain parameter (_Chain will be defined as
2682 -- part of the generated code for the allocator).
2687 -- The designated type was an incomplete type, and
2688 -- the access type did not get expanded. Salvage
2689 -- it now.
2691 Expand_N_Full_Type_Declaration
2695 -- If the context of the allocator is a declaration or
2696 -- an assignment, we can generate a meaningful image for
2697 -- it, even though subsequent assignments might remove
2698 -- the connection between task and entity. We build this
2699 -- image when the left-hand side is a simple variable,
2700 -- a simple indexed assignment or a simple selected
2701 -- component.
2704 declare
2707 begin
2709 Decls :=
2710 Build_Task_Image_Decls (
2711 Loc,
2712 New_Occurrence_Of
2718 then
2719 Decls :=
2720 Build_Task_Image_Decls
2722 else
2728 Decls :=
2729 Build_Task_Image_Decls (
2732 else
2737 New_Reference_To
2745 -- Has_Task is false, Decls not used
2747 else
2751 -- Add discriminants if discriminated type
2764 then
2765 Discr :=
2774 -- We set the allocator as analyzed so that when we analyze the
2775 -- expression actions node, we do not get an unwanted recursive
2776 -- expansion of the allocator expression.
2781 -- Here is the transformation:
2782 -- input: new T
2783 -- output: Temp : constant ptr_T := new T;
2784 -- Init (Temp.all, ...);
2785 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
2786 -- <CTRL> Initialize (Finalizable (Temp.all));
2788 -- Here ptr_T is the pointer type for the allocator, and T
2789 -- is the subtype of the allocator.
2791 Temp_Decl :=
2806 -- If the designated type is task type or contains tasks,
2807 -- Create block to activate created tasks, and insert
2808 -- declaration for Task_Image variable ahead of call.
2811 declare
2815 begin
2823 else
2834 else
2838 Make_Init_Call (
2843 Attach_Level)));
2851 else
2860 exception
2865 -----------------------
2866 -- Expand_N_And_Then --
2867 -----------------------
2869 -- Expand into conditional expression if Actions present, and also
2870 -- deal with optimizing case of arguments being True or False.
2879 begin
2880 -- Deal with non-standard booleans
2888 -- Check for cases of left argument is True or False
2892 -- If left argument is True, change (True and then Right) to Right.
2893 -- Any actions associated with Right will be executed unconditionally
2894 -- and can thus be inserted into the tree unconditionally.
2905 -- If left argument is False, change (False and then Right) to
2906 -- False. In this case we can forget the actions associated with
2907 -- Right, since they will never be executed.
2918 -- If Actions are present, we expand
2920 -- left and then right
2922 -- into
2924 -- if left then right else false end
2926 -- with the actions becoming the Then_Actions of the conditional
2927 -- expression. This conditional expression is then further expanded
2928 -- (and will eventually disappear)
2935 Left,
2936 Right,
2945 -- No actions present, check for cases of right argument True/False
2949 -- Change (Left and then True) to Left. Note that we know there
2950 -- are no actions associated with the True operand, since we
2951 -- just checked for this case above.
2956 -- Change (Left and then False) to False, making sure to preserve
2957 -- any side effects associated with the Left operand.
2961 Rewrite
2969 -------------------------------------
2970 -- Expand_N_Conditional_Expression --
2971 -------------------------------------
2973 -- Expand into expression actions if then/else actions present
2984 begin
2985 -- If either then or else actions are present, then given:
2987 -- if cond then then-expr else else-expr end
2989 -- we insert the following sequence of actions (using Insert_Actions):
2991 -- Cnn : typ;
2992 -- if cond then
2993 -- <<then actions>>
2994 -- Cnn := then-expr;
2995 -- else
2996 -- <<else actions>>
2997 -- Cnn := else-expr
2998 -- end if;
3000 -- and replace the conditional expression by a reference to Cnn
3005 New_If :=
3023 Insert_List_Before
3028 Insert_List_Before
3044 -----------------------------------
3045 -- Expand_N_Explicit_Dereference --
3046 -----------------------------------
3049 begin
3050 -- The only processing required is an insertion of an explicit
3051 -- dereference call for the checked storage pool case.
3056 -----------------
3057 -- Expand_N_In --
3058 -----------------
3068 -- Replaces node N by Lop'Valid. This is done when we have an explicit
3069 -- test for the left operand being in range of its subtype.
3071 ----------------------------
3072 -- Substitute_Valid_Check --
3073 ----------------------------
3076 begin
3089 -- Start of processing for Expand_N_In
3091 begin
3092 -- Check case of explicit test for an expression in range of its
3093 -- subtype. This is suspicious usage and we replace it with a 'Valid
3094 -- test and give a warning.
3100 then
3101 Substitute_Valid_Check;
3105 -- Case of explicit range
3108 declare
3118 begin
3119 -- If test is explicit x'first .. x'last, replace by valid check
3131 then
3132 Substitute_Valid_Check;
3136 -- If we have an explicit range, do a bit of optimization based
3137 -- on range analysis (we may be able to kill one or both checks).
3139 -- If either check is known to fail, replace result by False since
3140 -- the other check does not matter. Preserve the static flag for
3141 -- legality checks, because we are constant-folding beyond RM 4.9.
3150 -- If both checks are known to succeed, replace result
3151 -- by True, since we know we are in range.
3160 -- If lower bound check succeeds and upper bound check is
3161 -- not known to succeed or fail, then replace the range check
3162 -- with a comparison against the upper bound.
3172 -- If upper bound check succeeds and lower bound check is
3173 -- not known to succeed or fail, then replace the range check
3174 -- with a comparison against the lower bound.
3186 -- For all other cases of an explicit range, nothing to be done
3190 -- Here right operand is a subtype mark
3192 else
3193 declare
3199 begin
3202 -- For tagged type, do tagged membership operation
3206 -- No expansion will be performed when Java_VM, as the
3207 -- JVM back end will handle the membership tests directly
3208 -- (tags are not explicitly represented in Java objects,
3209 -- so the normal tagged membership expansion is not what
3210 -- we want).
3219 -- If type is scalar type, rewrite as x in t'first .. t'last
3220 -- This reason we do this is that the bounds may have the wrong
3221 -- type if they come from the original type definition.
3226 Low_Bound =>
3231 High_Bound =>
3238 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
3239 -- a membership test if the subtype mark denotes a constrained
3240 -- Unchecked_Union subtype and the expression lacks inferable
3241 -- discriminants.
3246 then
3251 -- Prevent Gigi from generating incorrect code by rewriting
3252 -- the test as a standard False.
3260 -- Here we have a non-scalar type
3271 -- For the constrained array case, we have to check the
3272 -- subscripts for an exact match if the lengths are
3273 -- non-zero (the lengths must match in any case).
3278 function Construct_Attribute_Reference
3282 -- Build attribute reference E'Nam(Dim)
3284 -----------------------------------
3285 -- Construct_Attribute_Reference --
3286 -----------------------------------
3288 function Construct_Attribute_Reference
3292 is
3293 begin
3294 return
3302 -- Start processing for Check_Subscripts
3304 begin
3308 Left_Opnd =>
3309 Construct_Attribute_Reference
3312 Right_Opnd =>
3313 Construct_Attribute_Reference
3318 Left_Opnd =>
3319 Construct_Attribute_Reference
3322 Right_Opnd =>
3323 Construct_Attribute_Reference
3328 Cond :=
3330 Left_Opnd =>
3341 -- These are the cases where constraint checks may be
3342 -- required, e.g. records with possible discriminants
3344 else
3345 -- Expand the test into a series of discriminant comparisons.
3346 -- The expression that is built is the negation of the one
3347 -- that is used for checking discriminant constraints.
3357 Left_Opnd =>
3364 else
3375 --------------------------------
3376 -- Expand_N_Indexed_Component --
3377 --------------------------------
3385 begin
3386 -- A special optimization, if we have an indexed component that
3387 -- is selecting from a slice, then we can eliminate the slice,
3388 -- since, for example, x (i .. j)(k) is identical to x(k). The
3389 -- only difference is the range check required by the slice. The
3390 -- range check for the slice itself has already been generated.
3391 -- The range check for the subscripting operation is ensured
3392 -- by converting the subject to the subtype of the slice.
3394 -- This optimization not only generates better code, avoiding
3395 -- slice messing especially in the packed case, but more importantly
3396 -- bypasses some problems in handling this peculiar case, for
3397 -- example, the issue of dealing specially with object renamings.
3404 Convert_To
3411 -- If the prefix is an access type, then we unconditionally rewrite
3412 -- if as an explicit deference. This simplifies processing for several
3413 -- cases, including packed array cases and certain cases in which
3414 -- checks must be generated. We used to try to do this only when it
3415 -- was necessary, but it cleans up the code to do it all the time.
3422 -- Generate index and validity checks
3430 -- All done for the non-packed case
3436 -- For packed arrays that are not bit-packed (i.e. the case of an array
3437 -- with one or more index types with a non-coniguous enumeration type),
3438 -- we can always use the normal packed element get circuit.
3445 -- For a reference to a component of a bit packed array, we have to
3446 -- convert it to a reference to the corresponding Packed_Array_Type.
3447 -- We only want to do this for simple references, and not for:
3449 -- Left side of assignment, or prefix of left side of assignment,
3450 -- or prefix of the prefix, to handle packed arrays of packed arrays,
3451 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3453 -- Renaming objects in renaming associations
3454 -- This case is handled when a use of the renamed variable occurs
3456 -- Actual parameters for a procedure call
3457 -- This case is handled in Exp_Ch6.Expand_Actuals
3459 -- The second expression in a 'Read attribute reference
3461 -- The prefix of an address or size attribute reference
3463 -- The following circuit detects these exceptions
3465 declare
3469 begin
3470 loop
3477 and then
3479 then
3484 or else
3487 then
3492 then
3495 -- If the expression is an index of an indexed component,
3496 -- it must be expanded regardless of context.
3500 then
3506 then
3512 then
3518 then
3521 else
3526 -- Keep looking up tree for unchecked expression, or if we are
3527 -- the prefix of a possible assignment left side.
3536 ---------------------
3537 -- Expand_N_Not_In --
3538 ---------------------
3540 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
3541 -- can be done. This avoids needing to duplicate this expansion code.
3548 begin
3551 Right_Opnd =>
3556 -- We want this tp appear as coming from source if original does (see
3557 -- tranformations in Expand_N_In).
3562 -- Now analyze tranformed node
3567 -------------------
3568 -- Expand_N_Null --
3569 -------------------
3571 -- The only replacement required is for the case of a null of type
3572 -- that is an access to protected subprogram. We represent such
3573 -- access values as a record, and so we must replace the occurrence
3574 -- of null by the equivalent record (with a null address and a null
3575 -- pointer in it), so that the backend creates the proper value.
3582 begin
3584 Agg :=
3593 -- For subsequent semantic analysis, the node must retain its
3594 -- type. Gigi in any case replaces this type by the corresponding
3595 -- record type before processing the node.
3600 exception
3605 ---------------------
3606 -- Expand_N_Op_Abs --
3607 ---------------------
3613 begin
3616 -- Deal with software overflow checking
3618 if not Backend_Overflow_Checks_On_Target
3621 then
3622 -- The only case to worry about is when the argument is
3623 -- equal to the largest negative number, so what we do is
3624 -- to insert the check:
3626 -- [constraint_error when Expr = typ'Base'First]
3628 -- with the usual Duplicate_Subexpr use coding for expr
3632 Condition =>
3635 Right_Opnd =>
3637 Prefix =>
3643 -- Vax floating-point types case
3650 ---------------------
3651 -- Expand_N_Op_Add --
3652 ---------------------
3657 begin
3660 -- N + 0 = 0 + N = N for integer types
3665 then
3671 then
3677 -- Arithmetic overflow checks for signed integer/fixed point types
3681 then
3685 -- Vax floating-point types case
3692 ---------------------
3693 -- Expand_N_Op_And --
3694 ---------------------
3699 begin
3713 ------------------------
3714 -- Expand_N_Op_Concat --
3715 ------------------------
3718 -- This is initialized the first time this routine is called. It records
3719 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3720 -- available in the run-time:
3721 --
3722 -- 0 None available
3723 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
3724 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3725 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3726 -- 5 All routines including RE_Str_Concat_5 available
3729 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3730 -- all three are available, False if any one of these is unavailable.
3734 -- List of operands to be concatenated
3737 -- Single operand for concatenation
3740 -- Node which is to be replaced by the result of concatenating
3741 -- the nodes in the list Opnds.
3744 -- Array type of concatenation result type
3747 -- Component type of concatenation represented by Cnode
3749 begin
3750 -- Initialize global variables showing run-time status
3761 else
3765 Char_Concat_Available :=
3767 and then
3769 and then
3773 -- Ensure validity of both operands
3777 -- If we are the left operand of a concatenation higher up the
3778 -- tree, then do nothing for now, since we want to deal with a
3779 -- series of concatenations as a unit.
3783 then
3787 -- We get here with a concatenation whose left operand may be a
3788 -- concatenation itself with a consistent type. We need to process
3789 -- these concatenation operands from left to right, which means
3790 -- from the deepest node in the tree to the highest node.
3797 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
3798 -- nodes above, so now we process bottom up, doing the operations. We
3799 -- gather a string that is as long as possible up to five operands
3801 -- The outer loop runs more than once if there are more than five
3802 -- concatenations of type Standard.String, the most we handle for
3803 -- this case, or if more than one concatenation type is involved.
3809 -- The inner loop gathers concatenation operands. We gather any
3810 -- number of these in the non-string case, or if no concatenation
3811 -- routines are available for string (since in that case we will
3812 -- treat string like any other non-string case). Otherwise we only
3813 -- gather as many operands as can be handled by the available
3814 -- procedures in the run-time library (normally 5, but may be
3815 -- less for the configurable run-time case).
3819 or else
3821 or else
3823 Max_Available_String_Operands)
3826 loop
3831 -- Here we process the collected operands. First we convert
3832 -- singleton operands to singleton aggregates. This is skipped
3833 -- however for the case of two operands of type String, since
3834 -- we have special routines for these cases.
3840 or else not Char_Concat_Available
3841 then
3843 loop
3856 -- Now call appropriate continuation routine
3860 then
3862 else
3871 ------------------------
3872 -- Expand_N_Op_Divide --
3873 ------------------------
3881 begin
3884 -- N / 1 = N for integer types
3889 then
3894 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3895 -- Is_Power_Of_2_For_Shift is set means that we know that our left
3896 -- operand is an unsigned integer, as required for this to work.
3901 -- We cannot do this transformation in configurable run time mode if we
3902 -- have 64-bit -- integers and long shifts are not available.
3904 and then
3907 then
3911 Right_Opnd =>
3917 -- Do required fixup of universal fixed operation
3924 -- Divisions with fixed-point results
3928 -- No special processing if Treat_Fixed_As_Integer is set,
3929 -- since from a semantic point of view such operations are
3930 -- simply integer operations and will be treated that way.
3935 else
3940 -- Other cases of division of fixed-point operands. Again we
3941 -- exclude the case where Treat_Fixed_As_Integer is set.
3946 then
3949 else
3954 -- Mixed-mode operations can appear in a non-static universal
3955 -- context, in which case the integer argument must be converted
3956 -- explicitly.
3960 then
3968 then
3974 -- Non-fixed point cases, do integer zero divide and overflow checks
3979 -- Check for 64-bit division available
3982 and then not Support_64_Bit_Divides_On_Target
3983 then
3987 -- Deal with Vax_Float
3995 --------------------
3996 -- Expand_N_Op_Eq --
3997 --------------------
4012 -- If a constructed equality exists for the type or for its parent,
4013 -- build and analyze call, adding conversions if the operation is
4014 -- inherited.
4017 -- Determines whether a type has a subcompoment of an unconstrained
4018 -- Unchecked_Union subtype. Typ is a record type.
4020 -------------------------
4021 -- Build_Equality_Call --
4022 -------------------------
4029 begin
4032 then
4037 -- If we have an Unchecked_Union, we need to add the inferred
4038 -- discriminant values as actuals in the function call. At this
4039 -- point, the expansion has determined that both operands have
4040 -- inferable discriminants.
4043 declare
4049 begin
4050 -- Per-object constrained selected components require special
4051 -- attention. If the enclosing scope of the component is an
4052 -- Unchecked_Union, we cannot reference its discriminants
4053 -- directly. This is why we use the two extra parameters of
4054 -- the equality function of the enclosing Unchecked_Union.
4056 -- type UU_Type (Discr : Integer := 0) is
4057 -- . . .
4058 -- end record;
4059 -- pragma Unchecked_Union (UU_Type);
4061 -- 1. Unchecked_Union enclosing record:
4063 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
4064 -- . . .
4065 -- Comp : UU_Type (Discr);
4066 -- . . .
4067 -- end Enclosing_UU_Type;
4068 -- pragma Unchecked_Union (Enclosing_UU_Type);
4070 -- Obj1 : Enclosing_UU_Type;
4071 -- Obj2 : Enclosing_UU_Type (1);
4073 -- [. . .] Obj1 = Obj2 [. . .]
4075 -- Generated code:
4077 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4079 -- A and B are the formal parameters of the equality function
4080 -- of Enclosing_UU_Type. The function always has two extra
4081 -- formals to capture the inferred discriminant values.
4083 -- 2. Non-Unchecked_Union enclosing record:
4085 -- type
4086 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
4087 -- is record
4088 -- . . .
4089 -- Comp : UU_Type (Discr);
4090 -- . . .
4091 -- end Enclosing_Non_UU_Type;
4093 -- Obj1 : Enclosing_Non_UU_Type;
4094 -- Obj2 : Enclosing_Non_UU_Type (1);
4096 -- ... Obj1 = Obj2 ...
4098 -- Generated code:
4100 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
4101 -- obj1.discr, obj2.discr)) then
4103 -- In this case we can directly reference the discriminants of
4104 -- the enclosing record.
4106 -- Lhs of equality
4109 and then Has_Per_Object_Constraint
4111 then
4112 -- Enclosing record is an Unchecked_Union, use formal A
4116 then
4117 Lhs_Discr_Val :=
4121 -- Enclosing record is of a non-Unchecked_Union type, it is
4122 -- possible to reference the discriminant.
4124 else
4125 Lhs_Discr_Val :=
4128 Selector_Name =>
4129 New_Copy
4130 (Get_Discriminant_Value
4132 Lhs_Type,
4136 -- Comment needed here ???
4138 else
4139 -- Infer the discriminant value
4141 Lhs_Discr_Val :=
4142 New_Copy
4143 (Get_Discriminant_Value
4145 Lhs_Type,
4149 -- Rhs of equality
4152 and then Has_Per_Object_Constraint
4154 then
4155 if Is_Unchecked_Union
4157 then
4158 Rhs_Discr_Val :=
4162 else
4163 Rhs_Discr_Val :=
4166 Selector_Name =>
4169 Rhs_Type,
4173 else
4174 Rhs_Discr_Val :=
4177 Rhs_Type,
4186 L_Exp,
4187 R_Exp,
4188 Lhs_Discr_Val,
4189 Rhs_Discr_Val)));
4192 -- Normal case, not an unchecked union
4194 else
4204 ------------------------------------
4205 -- Has_Unconstrained_UU_Component --
4206 ------------------------------------
4208 function Has_Unconstrained_UU_Component
4210 is
4216 function Component_Is_Unconstrained_UU
4218 -- Determines whether the subtype of the component is an
4219 -- unconstrained Unchecked_Union.
4221 function Variant_Is_Unconstrained_UU
4223 -- Determines whether a component of the variant has an unconstrained
4224 -- Unchecked_Union subtype.
4226 -----------------------------------
4227 -- Component_Is_Unconstrained_UU --
4228 -----------------------------------
4230 function Component_Is_Unconstrained_UU
4232 is
4233 begin
4238 declare
4242 begin
4243 -- Unconstrained nominal type. In the case of a constraint
4244 -- present, the node kind would have been N_Subtype_Indication.
4254 ---------------------------------
4255 -- Variant_Is_Unconstrained_UU --
4256 ---------------------------------
4258 function Variant_Is_Unconstrained_UU
4260 is
4263 begin
4268 -- We only need to test one component
4270 declare
4273 begin
4283 -- None of the components withing the variant were of
4284 -- unconstrained Unchecked_Union type.
4289 -- Start of processing for Has_Unconstrained_UU_Component
4291 begin
4299 -- Inspect available components
4302 declare
4305 begin
4308 -- One component is sufficent
4319 -- Inspect available components withing variants
4322 declare
4325 begin
4328 -- One component within a variant is sufficent
4339 -- Neither the available components, nor the components inside the
4340 -- variant parts were of an unconstrained Unchecked_Union subtype.
4345 -- Start of processing for Expand_N_Op_Eq
4347 begin
4354 else
4358 -- It may happen in error situations that the underlying type is not
4359 -- set. The error will be detected later, here we just defend the
4360 -- expander code.
4368 -- Boolean types (requiring handling of non-standard case)
4376 -- Array types
4380 -- If we are doing full validity checking, then expand out array
4381 -- comparisons to make sure that we check the array elements.
4384 declare
4386 Force_Validity_Checks;
4387 begin
4390 Expand_Array_Equality
4394 Bodies,
4395 Typl));
4401 -- Packed case where both operands are known aligned
4406 then
4409 -- Where the component type is elementary we can use a block bit
4410 -- comparison (if supported on the target) exception in the case
4411 -- of floating-point (negative zero issues require element by
4412 -- element comparison), and atomic types (where we must be sure
4413 -- to load elements independently) and possibly unaligned arrays.
4420 and then Support_Composite_Compare_On_Target
4421 then
4424 -- For composite and floating-point cases, expand equality loop
4425 -- to make sure of using proper comparisons for tagged types,
4426 -- and correctly handling the floating-point case.
4428 else
4430 Expand_Array_Equality
4434 Bodies,
4435 Typl));
4440 -- Record Types
4444 -- For tagged types, use the primitive "="
4448 -- If this is derived from an untagged private type completed
4449 -- with a tagged type, it does not have a full view, so we
4450 -- use the primitive operations of the private type.
4451 -- This check should no longer be necessary when these
4452 -- types receive their full views ???
4458 then
4459 -- Search for equality operation, checking that the
4460 -- operands have the same type. Note that we must find
4461 -- a matching entry, or something is very wrong!
4469 and then
4478 -- Find the type's predefined equality or an overriding
4479 -- user-defined equality. The reason for not simply calling
4480 -- Find_Prim_Op here is that there may be a user-defined
4481 -- overloaded equality op that precedes the equality that
4482 -- we want, so we have to explicitly search (e.g., there
4483 -- could be an equality with two different parameter types).
4485 else
4495 and then
4507 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
4508 -- predefined equality operator for a type which has a subcomponent
4509 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
4516 -- Prevent Gigi from generating incorrect code by rewriting the
4517 -- equality as a standard False.
4524 -- If we can infer the discriminants of the operands, we make a
4525 -- call to the TSS equality function.
4528 and then
4530 then
4531 Build_Equality_Call
4534 else
4535 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4536 -- the predefined equality operator for an Unchecked_Union type
4537 -- if either of the operands lack inferable discriminants.
4543 -- Prevent Gigi from generating incorrect code by rewriting
4544 -- the equality as a standard False.
4551 -- If a type support function is present (for complex cases), use it
4554 Build_Equality_Call
4557 -- Otherwise expand the component by component equality. Note that
4558 -- we never use block-bit coparisons for records, because of the
4559 -- problems with gaps. The backend will often be able to recombine
4560 -- the separate comparisons that we generate here.
4562 else
4573 -- If we still have an equality comparison (i.e. it was not rewritten
4574 -- in some way), then we can test if result is known at compile time).
4580 -- If we still have comparison for Vax_Float, process it
4588 -----------------------
4589 -- Expand_N_Op_Expon --
4590 -----------------------
4608 begin
4611 -- If either operand is of a private type, then we have the use of
4612 -- an intrinsic operator, and we get rid of the privateness, by using
4613 -- root types of underlying types for the actual operation. Otherwise
4614 -- the private types will cause trouble if we expand multiplications
4615 -- or shifts etc. We also do this transformation if the result type
4616 -- is different from the base type.
4619 or else
4621 or else
4623 or else
4625 then
4626 declare
4630 begin
4641 -- Test for case of known right argument
4646 -- We only fold small non-negative exponents. You might think we
4647 -- could fold small negative exponents for the real case, but we
4648 -- can't because we are required to raise Constraint_Error for
4649 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
4650 -- See ACVC test C4A012B.
4654 -- X ** 0 = 1 (or 1.0)
4659 else
4663 -- X ** 1 = X
4668 -- X ** 2 = X * X
4671 Xnode :=
4676 -- X ** 3 = X * X * X
4679 Xnode :=
4681 Left_Opnd =>
4687 -- X ** 4 ->
4688 -- En : constant base'type := base * base;
4689 -- ...
4690 -- En * En
4693 Temp :=
4701 Expression =>
4706 Xnode :=
4718 -- Case of (2 ** expression) appearing as an argument of an integer
4719 -- multiplication, or as the right argument of a division of a non-
4720 -- negative integer. In such cases we leave the node untouched, setting
4721 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
4722 -- of the higher level node converts it into a shift.
4729 and then not Ovflo
4731 then
4732 declare
4737 begin
4739 and then
4741 or else
4745 or else
4751 then
4758 -- Fall through if exponentiation must be done using a runtime routine
4760 -- First deal with modular case
4764 -- Non-binary case, we call the special exponentiation routine for
4765 -- the non-binary case, converting the argument to Long_Long_Integer
4766 -- and passing the modulus value. Then the result is converted back
4767 -- to the base type.
4777 Exp))));
4779 -- Binary case, in this case, we call one of two routines, either
4780 -- the unsigned integer case, or the unsigned long long integer
4781 -- case, with a final "and" operation to do the required mod.
4783 else
4786 else
4793 Left_Opnd =>
4798 Exp)),
4799 Right_Opnd =>
4804 -- Common exit point for modular type case
4809 -- Signed integer cases, done using either Integer or Long_Long_Integer.
4810 -- It is not worth having routines for Short_[Short_]Integer, since for
4811 -- most machines it would not help, and it would generate more code that
4812 -- might need certification in the HI-E case.
4814 -- In the integer cases, we have two routines, one for when overflow
4815 -- checks are required, and one when they are not required, since
4816 -- there is a real gain in ommitting checks on many machines.
4820 and then
4823 then
4828 else
4837 else
4841 -- Floating-point cases, always done using Long_Long_Float. We do not
4842 -- need separate routines for the overflow case here, since in the case
4843 -- of floating-point, we generate infinities anyway as a rule (either
4844 -- that or we automatically trap overflow), and if there is an infinity
4845 -- generated and a range check is required, the check will fail anyway.
4847 else
4853 -- Common processing for integer cases and floating-point cases.
4854 -- If we are in the right type, we can call runtime routine directly
4859 then
4865 -- Otherwise we have to introduce conversions (conversions are also
4866 -- required in the universal cases, since the runtime routine is
4867 -- typed using one of the standard types.
4869 else
4876 Exp))));
4882 exception
4887 --------------------
4888 -- Expand_N_Op_Ge --
4889 --------------------
4897 begin
4914 -- If we still have comparison, and Vax_Float type, process it
4922 --------------------
4923 -- Expand_N_Op_Gt --
4924 --------------------
4932 begin
4949 -- If we still have comparison, and Vax_Float type, process it
4957 --------------------
4958 -- Expand_N_Op_Le --
4959 --------------------
4967 begin
4984 -- If we still have comparison, and Vax_Float type, process it
4992 --------------------
4993 -- Expand_N_Op_Lt --
4994 --------------------
5002 begin
5019 -- If we still have comparison, and Vax_Float type, process it
5027 -----------------------
5028 -- Expand_N_Op_Minus --
5029 -----------------------
5035 begin
5038 if not Backend_Overflow_Checks_On_Target
5041 then
5042 -- Software overflow checking expands -expr into (0 - expr)
5051 -- Vax floating-point types case
5058 ---------------------
5059 -- Expand_N_Op_Mod --
5060 ---------------------
5078 begin
5084 -- Convert mod to rem if operands are known non-negative. We do this
5085 -- since it is quite likely that this will improve the quality of code,
5086 -- (the operation now corresponds to the hardware remainder), and it
5087 -- does not seem likely that it could be harmful.
5090 and then
5092 then
5098 -- Instead of reanalyzing the node we do the analysis manually.
5099 -- This avoids anomalies when the replacement is done in an
5100 -- instance and is epsilon more efficient.
5109 -- Otherwise, normal mod processing
5111 else
5116 -- Apply optimization x mod 1 = 0. We don't really need that with
5117 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5118 -- certainly harmless.
5123 then
5129 -- Deal with annoying case of largest negative number remainder
5130 -- minus one. Gigi does not handle this case correctly, because
5131 -- it generates a divide instruction which may trap in this case.
5133 -- In fact the check is quite easy, if the right operand is -1,
5134 -- then the mod value is always 0, and we can just ignore the
5135 -- left operand completely in this case.
5137 -- The operand type may be private (e.g. in the expansion of an
5138 -- an intrinsic operation) so we must use the underlying type to
5139 -- get the bounds, and convert the literals explicitly.
5141 LLB :=
5142 Expr_Value
5146 and then
5148 then
5154 Right_Opnd =>
5167 --------------------------
5168 -- Expand_N_Op_Multiply --
5169 --------------------------
5188 begin
5191 -- Special optimizations for integer types
5195 -- N * 0 = 0 * N = 0 for integer types
5199 or else
5202 then
5208 -- N * 1 = 1 * N = N for integer types
5210 -- This optimisation is not done if we are going to
5211 -- rewrite the product 1 * 2 ** N to a shift.
5215 and then not Lp2
5216 then
5222 and then not Rp2
5223 then
5229 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5230 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5231 -- operand is an integer, as required for this to work.
5236 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
5241 Right_Opnd =>
5248 else
5252 Right_Opnd =>
5258 -- Same processing for the operands the other way round
5264 Right_Opnd =>
5270 -- Do required fixup of universal fixed operation
5277 -- Multiplications with fixed-point results
5281 -- No special processing if Treat_Fixed_As_Integer is set,
5282 -- since from a semantic point of view such operations are
5283 -- simply integer operations and will be treated that way.
5287 -- Case of fixed * integer => fixed
5292 -- Case of integer * fixed => fixed
5297 -- Case of fixed * fixed => fixed
5299 else
5304 -- Other cases of multiplication of fixed-point operands. Again
5305 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
5309 then
5312 else
5317 -- Mixed-mode operations can appear in a non-static universal
5318 -- context, in which case the integer argument must be converted
5319 -- explicitly.
5323 then
5330 then
5335 -- Non-fixed point cases, check software overflow checking required
5340 -- Deal with VAX float case
5348 --------------------
5349 -- Expand_N_Op_Ne --
5350 --------------------
5355 begin
5356 -- Case of elementary type with standard operator
5360 then
5363 -- Boolean types (requiring handling of non-standard case)
5374 -- If we still have comparison for Vax_Float, process it
5381 -- For all cases other than elementary types, we rewrite node as the
5382 -- negation of an equality operation, and reanalyze. The equality to be
5383 -- used is defined in the same scope and has the same signature. This
5384 -- signature must be set explicitly since in an instance it may not have
5385 -- the same visibility as in the generic unit. This avoids duplicating
5386 -- or factoring the complex code for record/array equality tests etc.
5388 else
5389 declare
5394 begin
5397 Neg :=
5399 Right_Opnd =>
5409 -- For navigation purposes, the inequality is treated as an
5410 -- implicit reference to the corresponding equality. Preserve the
5411 -- Comes_From_ source flag so that the proper Xref entry is
5412 -- generated.
5422 ---------------------
5423 -- Expand_N_Op_Not --
5424 ---------------------
5426 -- If the argument is other than a Boolean array type, there is no
5427 -- special expansion required.
5429 -- For the packed case, we call the special routine in Exp_Pakd, except
5430 -- that if the component size is greater than one, we use the standard
5431 -- routine generating a gruesome loop (it is so peculiar to have packed
5432 -- arrays with non-standard Boolean representations anyway, so it does
5433 -- not matter that we do not handle this case efficiently).
5435 -- For the unpacked case (and for the special packed case where we have
5436 -- non standard Booleans, as discussed above), we generate and insert
5437 -- into the tree the following function definition:
5439 -- function Nnnn (A : arr) is
5440 -- B : arr;
5441 -- begin
5442 -- for J in a'range loop
5443 -- B (J) := not A (J);
5444 -- end loop;
5445 -- return B;
5446 -- end Nnnn;
5448 -- Here arr is the actual subtype of the parameter (and hence always
5449 -- constrained). Then we replace the not with a call to this function.
5465 begin
5468 -- For boolean operand, deal with non-standard booleans
5477 -- Only array types need any other processing
5483 -- Case of array operand. If bit packed with a component size of 1,
5484 -- handle it in Exp_Pakd if the operand is known to be aligned.
5489 then
5494 -- Case of array operand which is not bit-packed. If the context is
5495 -- a safe assignment, call in-place operation, If context is a larger
5496 -- boolean expression in the context of a safe assignment, expansion is
5497 -- done by enclosing operation.
5509 -- Special case the negation of a binary operation
5514 and then Safe_In_Place_Array_Op
5516 then
5523 then
5524 declare
5529 begin
5533 then
5534 -- (not A) op (not B) can be reduced to a single call
5540 then
5541 -- A xor (not B) can also be special-cased
5553 A_J :=
5558 B_J :=
5563 Loop_Statement :=
5567 Iteration_Scheme =>
5569 Loop_Parameter_Specification =>
5572 Discrete_Subtype_Definition =>
5587 Specification =>
5601 Handled_Statement_Sequence =>
5604 Loop_Statement,
5606 Expression =>
5617 --------------------
5618 -- Expand_N_Op_Or --
5619 --------------------
5624 begin
5638 ----------------------
5639 -- Expand_N_Op_Plus --
5640 ----------------------
5643 begin
5647 ---------------------
5648 -- Expand_N_Op_Rem --
5649 ---------------------
5666 begin
5673 -- Apply optimization x rem 1 = 0. We don't really need that with
5674 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5675 -- certainly harmless.
5680 then
5686 -- Deal with annoying case of largest negative number remainder
5687 -- minus one. Gigi does not handle this case correctly, because
5688 -- it generates a divide instruction which may trap in this case.
5690 -- In fact the check is quite easy, if the right operand is -1,
5691 -- then the remainder is always 0, and we can just ignore the
5692 -- left operand completely in this case.
5697 -- The operand type may be private (e.g. in the expansion of an
5698 -- an intrinsic operation) so we must use the underlying type to
5699 -- get the bounds, and convert the literals explicitly.
5701 LLB :=
5702 Expr_Value
5705 -- Now perform the test, generating code only if needed
5708 and then
5710 then
5716 Right_Opnd =>
5730 -----------------------------
5731 -- Expand_N_Op_Rotate_Left --
5732 -----------------------------
5735 begin
5739 ------------------------------
5740 -- Expand_N_Op_Rotate_Right --
5741 ------------------------------
5744 begin
5748 ----------------------------
5749 -- Expand_N_Op_Shift_Left --
5750 ----------------------------
5753 begin
5757 -----------------------------
5758 -- Expand_N_Op_Shift_Right --
5759 -----------------------------
5762 begin
5766 ----------------------------------------
5767 -- Expand_N_Op_Shift_Right_Arithmetic --
5768 ----------------------------------------
5771 begin
5775 --------------------------
5776 -- Expand_N_Op_Subtract --
5777 --------------------------
5782 begin
5785 -- N - 0 = N for integer types
5790 then
5795 -- Arithemtic overflow checks for signed integer/fixed point types
5799 then
5802 -- Vax floating-point types case
5809 ---------------------
5810 -- Expand_N_Op_Xor --
5811 ---------------------
5816 begin
5830 ----------------------
5831 -- Expand_N_Or_Else --
5832 ----------------------
5834 -- Expand into conditional expression if Actions present, and also
5835 -- deal with optimizing case of arguments being True or False.
5844 begin
5845 -- Deal with non-standard booleans
5853 -- Check for cases of left argument is True or False
5857 -- If left argument is False, change (False or else Right) to Right.
5858 -- Any actions associated with Right will be executed unconditionally
5859 -- and can thus be inserted into the tree unconditionally.
5870 -- If left argument is True, change (True and then Right) to
5871 -- True. In this case we can forget the actions associated with
5872 -- Right, since they will never be executed.
5883 -- If Actions are present, we expand
5885 -- left or else right
5887 -- into
5889 -- if left then True else right end
5891 -- with the actions becoming the Else_Actions of the conditional
5892 -- expression. This conditional expression is then further expanded
5893 -- (and will eventually disappear)
5900 Left,
5902 Right)));
5910 -- No actions present, check for cases of right argument True/False
5914 -- Change (Left or else False) to Left. Note that we know there
5915 -- are no actions associated with the True operand, since we
5916 -- just checked for this case above.
5921 -- Change (Left or else True) to True, making sure to preserve
5922 -- any side effects associated with the Left operand.
5926 Rewrite
5934 -----------------------------------
5935 -- Expand_N_Qualified_Expression --
5936 -----------------------------------
5942 begin
5946 ---------------------------------
5947 -- Expand_N_Selected_Component --
5948 ---------------------------------
5950 -- If the selector is a discriminant of a concurrent object, rewrite the
5951 -- prefix to denote the corresponding record type.
5963 -- Gigi needs a temporary for prefixes that depend on a discriminant,
5964 -- unless the context of an assignment can provide size information.
5965 -- Don't we have a general routine that does this???
5967 -----------------------
5968 -- In_Left_Hand_Side --
5969 -----------------------
5972 begin
5980 -- Start of processing for Expand_N_Selected_Component
5982 begin
5983 -- Insert explicit dereference if required
5991 then
5998 -- Deal with discriminant check required
6002 -- Present the discrminant checking function to the backend,
6003 -- so that it can inline the call to the function.
6005 Add_Inlined_Body
6006 (Discriminant_Checking_Func
6009 -- Now reset the flag and generate the call
6015 -- Gigi cannot handle unchecked conversions that are the prefix of a
6016 -- selected component with discriminants. This must be checked during
6017 -- expansion, because during analysis the type of the selector is not
6018 -- known at the point the prefix is analyzed. If the conversion is the
6019 -- target of an assignment, then we cannot force the evaluation.
6024 then
6028 -- Remaining processing applies only if selector is a discriminant
6032 -- If the selector is a discriminant of a constrained record type,
6033 -- we may be able to rewrite the expression with the actual value
6034 -- of the discriminant, a useful optimization in some cases.
6039 then
6040 -- Do this optimization for discrete types only, and not for
6041 -- access types (access discriminants get us into trouble!)
6046 -- Don't do this on the left hand of an assignment statement.
6047 -- Normally one would think that references like this would
6048 -- not occur, but they do in generated code, and mean that
6049 -- we really do want to assign the discriminant!
6053 then
6056 -- Don't do this optimization for the prefix of an attribute
6057 -- or the operand of an object renaming declaration since these
6058 -- are contexts where we do not want the value anyway.
6063 then
6066 -- Don't do this optimization if we are within the code for a
6067 -- discriminant check, since the whole point of such a check may
6068 -- be to verify the condition on which the code below depends!
6073 -- Green light to see if we can do the optimization. There is
6074 -- still one condition that inhibits the optimization below
6075 -- but now is the time to check the particular discriminant.
6077 else
6078 -- Loop through discriminants to find the matching
6079 -- discriminant constraint to see if we can copy it.
6085 -- Check if this is the matching discriminant
6089 -- Here we have the matching discriminant. Check for
6090 -- the case of a discriminant of a component that is
6091 -- constrained by an outer discriminant, which cannot
6092 -- be optimized away.
6094 if
6095 Denotes_Discriminant
6097 then
6100 -- In the context of a case statement, the expression
6101 -- may have the base type of the discriminant, and we
6102 -- need to preserve the constraint to avoid spurious
6103 -- errors on missing cases.
6107 then
6110 Subtype_Mark =>
6112 Expression =>
6116 -- In case that comes out as a static expression,
6117 -- reset it (a selected component is never static).
6122 -- Otherwise we can just copy the constraint, but the
6123 -- result is certainly not static! In some cases the
6124 -- discriminant constraint has been analyzed in the
6125 -- context of the original subtype indication, but for
6126 -- itypes the constraint might not have been analyzed
6127 -- yet, and this must be done now.
6129 else
6141 -- Note: the above loop should always find a matching
6142 -- discriminant, but if it does not, we just missed an
6143 -- optimization due to some glitch (perhaps a previous
6144 -- error), so ignore.
6149 -- The only remaining processing is in the case of a discriminant of
6150 -- a concurrent object, where we rewrite the prefix to denote the
6151 -- corresponding record type. If the type is derived and has renamed
6152 -- discriminants, use corresponding discriminant, which is the one
6153 -- that appears in the corresponding record.
6163 then
6167 New_N :=
6169 Prefix =>
6179 --------------------
6180 -- Expand_N_Slice --
6181 --------------------
6190 -- Check whether the argument is an actual for a procedure call,
6191 -- in which case the expansion of a bit-packed slice is deferred
6192 -- until the call itself is expanded. The reason this is required
6193 -- is that we might have an IN OUT or OUT parameter, and the copy out
6194 -- is essential, and that copy out would be missed if we created a
6195 -- temporary here in Expand_N_Slice. Note that we don't bother
6196 -- to test specifically for an IN OUT or OUT mode parameter, since it
6197 -- is a bit tricky to do, and it is harmless to defer expansion
6198 -- in the IN case, since the call processing will still generate the
6199 -- appropriate copy in operation, which will take care of the slice.
6202 -- Create a named variable for the value of the slice, in
6203 -- cases where the back-end cannot handle it properly, e.g.
6204 -- when packed types or unaligned slices are involved.
6206 -------------------------
6207 -- Is_Procedure_Actual --
6208 -------------------------
6213 begin
6214 loop
6215 -- If our parent is a procedure call we can return
6220 -- If our parent is a type conversion, keep climbing the
6221 -- tree, since a type conversion can be a procedure actual.
6222 -- Also keep climbing if parameter association or a qualified
6223 -- expression, since these are additional cases that do can
6224 -- appear on procedure actuals.
6229 then
6232 -- Any other case is not what we are looking for
6234 else
6240 --------------------
6241 -- Make_Temporary --
6242 --------------------
6248 begin
6249 Decl :=
6257 Decl,
6266 -- Start of processing for Expand_N_Slice
6268 begin
6269 -- Special handling for access types
6282 -- Range checks are potentially also needed for cases involving
6283 -- a slice indexed by a subtype indication, but Do_Range_Check
6284 -- can currently only be set for expressions ???
6290 then
6294 -- The remaining case to be handled is packed slices. We can leave
6295 -- packed slices as they are in the following situations:
6297 -- 1. Right or left side of an assignment (we can handle this
6298 -- situation correctly in the assignment statement expansion).
6300 -- 2. Prefix of indexed component (the slide is optimized away
6301 -- in this case, see the start of Expand_N_Slice.
6303 -- 3. Object renaming declaration, since we want the name of
6304 -- the slice, not the value.
6306 -- 4. Argument to procedure call, since copy-in/copy-out handling
6307 -- may be required, and this is handled in the expansion of
6308 -- call itself.
6310 -- 5. Prefix of an address attribute (this is an error which
6311 -- is caught elsewhere, and the expansion would intefere
6312 -- with generating the error message).
6316 -- Apply transformation for actuals of a function call,
6317 -- where Expand_Actuals is not used.
6321 then
6322 Make_Temporary;
6328 then
6334 then
6339 then
6342 else
6343 Make_Temporary;
6347 ------------------------------
6348 -- Expand_N_Type_Conversion --
6349 ------------------------------
6358 -- This is called in the case of record and array type conversions
6359 -- to see if there is a change of representation to be handled.
6360 -- Change of representation is actually handled at the assignment
6361 -- statement level, and what this procedure does is rewrite node N
6362 -- conversion as an assignment to temporary. If there is no change
6363 -- of representation, then the conversion node is unchanged.
6366 -- Handles generation of range check for real target value
6368 -----------------------------------
6369 -- Handle_Changed_Representation --
6370 -----------------------------------
6380 begin
6381 -- Nothing to do if no change of representation
6386 -- The real change of representation work is done by the assignment
6387 -- statement processing. So if this type conversion is appearing as
6388 -- the expression of an assignment statement, nothing needs to be
6389 -- done to the conversion.
6394 -- Otherwise we need to generate a temporary variable, and do the
6395 -- change of representation assignment into that temporary variable.
6396 -- The conversion is then replaced by a reference to this variable.
6398 else
6401 -- If type is unconstrained we have to add a constraint,
6402 -- copied from the actual value of the left hand side.
6417 Selector_Name =>
6428 -- We convert the bounds explicitly. We use an unchecked
6429 -- conversion because bounds checks are done elsewhere.
6433 Low_Bound =>
6436 Prefix =>
6437 Duplicate_Subexpr_No_Checks
6443 High_Bound =>
6446 Prefix =>
6447 Duplicate_Subexpr_No_Checks
6461 Odef :=
6464 Constraint =>
6470 Decl :=
6477 -- Insert required actions. It is essential to suppress checks
6478 -- since we have suppressed default initialization, which means
6479 -- that the variable we create may have no discriminants.
6482 New_List (
6483 Decl,
6494 ----------------------
6495 -- Real_Range_Check --
6496 ----------------------
6498 -- Case of conversions to floating-point or fixed-point. If range
6499 -- checks are enabled and the target type has a range constraint,
6500 -- we convert:
6502 -- typ (x)
6504 -- to
6506 -- Tnn : typ'Base := typ'Base (x);
6507 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
6508 -- Tnn
6510 -- This is necessary when there is a conversion of integer to float
6511 -- or to fixed-point to ensure that the correct checks are made. It
6512 -- is not necessary for float to float where it is enough to simply
6513 -- set the Do_Range_Check flag.
6523 begin
6524 -- Nothing to do if conversion was rewritten
6530 -- Nothing to do if range checks suppressed, or target has the
6531 -- same range as the base type (or is the base type).
6535 and then
6537 then
6541 -- Nothing to do if expression is an entity on which checks
6542 -- have been suppressed.
6546 then
6550 -- Nothing to do if bounds are all static and we can tell that
6551 -- the expression is within the bounds of the target. Note that
6552 -- if the operand is of an unconstrained floating-point type,
6553 -- then we do not trust it to be in range (might be infinite)
6555 declare
6559 begin
6566 then
6567 declare
6573 begin
6577 else
6585 then
6593 -- For float to float conversions, we are done
6596 and then
6598 then
6602 -- Otherwise rewrite the conversion as described above
6605 Rewrite
6609 -- Enable overflow except for case of integer to float conversions,
6610 -- where it is never required, since we can never have overflow in
6611 -- this case.
6617 Tnn :=
6628 Condition =>
6630 Left_Opnd =>
6633 Right_Opnd =>
6636 Prefix =>
6639 Right_Opnd =>
6642 Right_Opnd =>
6645 Prefix =>
6653 -- Start of processing for Expand_N_Type_Conversion
6655 begin
6656 -- Nothing at all to do if conversion is to the identical type
6657 -- so remove the conversion completely, it is useless.
6664 -- Nothing to do if this is the second argument of read. This
6665 -- is a "backwards" conversion that will be handled by the
6666 -- specialized code in attribute processing.
6671 then
6675 -- Here if we may need to expand conversion
6677 -- Special case of converting from non-standard boolean type
6681 then
6687 -- Case of converting to an access type
6691 -- Apply an accessibility check if the operand is an
6692 -- access parameter. Note that other checks may still
6693 -- need to be applied below (such as tagged type checks).
6698 then
6701 -- If the level of the operand type is statically deeper
6702 -- then the level of the target type, then force Program_Error.
6703 -- Note that this can only occur for cases where the attribute
6704 -- is within the body of an instantiation (otherwise the
6705 -- conversion will already have been rejected as illegal).
6706 -- Note: warnings are issued by the analyzer for the instance
6707 -- cases.
6709 elsif In_Instance_Body
6712 then
6718 -- When the operand is a selected access discriminant
6719 -- the check needs to be made against the level of the
6720 -- object denoted by the prefix of the selected name.
6721 -- Force Program_Error for this case as well (this
6722 -- accessibility violation can only happen if within
6723 -- the body of an instantiation).
6725 elsif In_Instance_Body
6730 then
6738 -- Case of conversions of tagged types and access to tagged types
6740 -- When needed, that is to say when the expression is class-wide,
6741 -- Add runtime a tag check for (strict) downward conversion by using
6742 -- the membership test, generating:
6744 -- [constraint_error when Operand not in Target_Type'Class]
6746 -- or in the access type case
6748 -- [constraint_error
6749 -- when Operand /= null
6750 -- and then Operand.all not in
6751 -- Designated_Type (Target_Type)'Class]
6756 then
6757 -- Do not do any expansion in the access type case if the
6758 -- parent is a renaming, since this is an error situation
6759 -- which will be caught by Sem_Ch8, and the expansion can
6760 -- intefere with this error check.
6764 then
6768 -- Oherwise, proceed with processing tagged conversion
6770 declare
6776 begin
6781 else
6788 and then Is_Ancestor
6790 Actual_Target_Type)
6792 then
6793 -- The conversion is valid for any descendant of the
6794 -- target type
6799 Cond :=
6801 Left_Opnd =>
6806 Right_Opnd =>
6808 Left_Opnd =>
6810 Prefix =>
6812 Right_Opnd =>
6815 else
6816 Cond :=
6819 Right_Opnd =>
6828 declare
6830 begin
6831 Conv :=
6841 -- Case of other access type conversions
6846 -- Case of conversions from a fixed-point type
6848 -- These conversions require special expansion and processing, found
6849 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
6850 -- set, since from a semantic point of view, these are simple integer
6851 -- conversions, which do not need further processing.
6855 then
6856 -- We should never see universal fixed at this case, since the
6857 -- expansion of the constituent divide or multiply should have
6858 -- eliminated the explicit mention of universal fixed.
6862 -- Check for special case of the conversion to universal real
6863 -- that occurs as a result of the use of a round attribute.
6864 -- In this case, the real type for the conversion is taken
6865 -- from the target type of the Round attribute and the
6866 -- result must be marked as rounded.
6871 then
6876 -- Otherwise do correct fixed-conversion, but skip these if the
6877 -- Conversion_OK flag is set, because from a semantic point of
6878 -- view these are simple integer conversions needing no further
6879 -- processing (the backend will simply treat them as integers)
6884 Real_Range_Check;
6889 else
6892 Real_Range_Check;
6896 -- Case of conversions to a fixed-point type
6898 -- These conversions require special expansion and processing, found
6899 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6900 -- is set, since from a semantic point of view, these are simple
6901 -- integer conversions, which do not need further processing.
6905 then
6908 Real_Range_Check;
6909 else
6912 Real_Range_Check;
6915 -- Case of float-to-integer conversions
6917 -- We also handle float-to-fixed conversions with Conversion_OK set
6918 -- since semantically the fixed-point target is treated as though it
6919 -- were an integer in such cases.
6922 and then
6924 or else
6926 then
6927 -- Special processing required if the conversion is the expression
6928 -- of a Truncation attribute reference. In this case we replace:
6930 -- ityp (ftyp'Truncation (x))
6932 -- by
6934 -- ityp (x)
6936 -- with the Float_Truncate flag set. This is clearly more efficient
6940 then
6946 -- One more check here, gcc is still not able to do conversions of
6947 -- this type with proper overflow checking, and so gigi is doing an
6948 -- approximation of what is required by doing floating-point compares
6949 -- with the end-point. But that can lose precision in some cases, and
6950 -- give a wrong result. Converting the operand to Universal_Real is
6951 -- helpful, but still does not catch all cases with 64-bit integers
6952 -- on targets with only 64-bit floats ???
6957 Subtype_Mark =>
6959 Expression =>
6967 -- Case of array conversions
6969 -- Expansion of array conversions, add required length/range checks
6970 -- but only do this if there is no change of representation. For
6971 -- handling of this case, see Handle_Changed_Representation.
6977 else
6981 Handle_Changed_Representation;
6983 -- Case of conversions of discriminated types
6985 -- Add required discriminant checks if target is constrained. Again
6986 -- this change is skipped if we have a change of representation.
6990 then
6992 Handle_Changed_Representation;
6994 -- Case of all other record conversions. The only processing required
6995 -- is to check for a change of representation requiring the special
6996 -- assignment processing.
7000 -- Ada 2005 (AI-216): Program_Error is raised when converting from
7001 -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
7002 -- Union type if the operand lacks inferable discriminants.
7009 then
7010 -- To prevent Gigi from generating illegal code, we make a
7011 -- Program_Error node, but we give it the target type of the
7012 -- conversion.
7014 declare
7018 begin
7023 else
7024 Handle_Changed_Representation;
7027 -- Case of conversions of enumeration types
7031 -- Special processing is required if there is a change of
7032 -- representation (from enumeration representation clauses)
7036 -- Convert: x(y) to x'val (ytyp'val (y))
7051 -- Case of conversions to floating-point
7054 Real_Range_Check;
7057 -- At this stage, either the conversion node has been transformed
7058 -- into some other equivalent expression, or left as a conversion
7059 -- that can be handled by Gigi. The conversions that Gigi can handle
7060 -- are the following:
7062 -- Conversions with no change of representation or type
7064 -- Numeric conversions involving integer values, floating-point
7065 -- values, and fixed-point values. Fixed-point values are allowed
7066 -- only if Conversion_OK is set, i.e. if the fixed-point values
7067 -- are to be treated as integers.
7069 -- No other conversions should be passed to Gigi
7071 -- Check: are these rules stated in sinfo??? if so, why restate here???
7073 -- The only remaining step is to generate a range check if we still
7074 -- have a type conversion at this stage and Do_Range_Check is set.
7075 -- For now we do this only for conversions of discrete types.
7079 then
7080 declare
7085 begin
7088 then
7091 -- Before we do a range check, we have to deal with treating
7092 -- a fixed-point operand as an integer. The way we do this
7093 -- is simply to do an unchecked conversion to an appropriate
7094 -- integer type large enough to hold the result.
7096 -- This code is not active yet, because we are only dealing
7097 -- with discrete types so far ???
7101 then
7106 else
7113 -- Reset overflow flag, since the range check will include
7114 -- dealing with possible overflow, and generate the check
7115 -- If Address is either source or target type, suppress
7116 -- range check to avoid typing anomalies when it is a visible
7117 -- integer type.
7122 then
7123 Generate_Range_Check
7130 -- Final step, if the result is a type conversion involving Vax_Float
7131 -- types, then it is subject for further special processing.
7135 then
7141 -----------------------------------
7142 -- Expand_N_Unchecked_Expression --
7143 -----------------------------------
7145 -- Remove the unchecked expression node from the tree. It's job was simply
7146 -- to make sure that its constituent expression was handled with checks
7147 -- off, and now that that is done, we can remove it from the tree, and
7148 -- indeed must, since gigi does not expect to see these nodes.
7153 begin
7158 ----------------------------------------
7159 -- Expand_N_Unchecked_Type_Conversion --
7160 ----------------------------------------
7162 -- If this cannot be handled by Gigi and we haven't already made
7163 -- a temporary for it, do it now.
7170 begin
7171 -- If we have a conversion of a compile time known value to a target
7172 -- type and the value is in range of the target type, then we can simply
7173 -- replace the construct by an integer literal of the correct type. We
7174 -- only apply this to integer types being converted. Possibly it may
7175 -- apply in other cases, but it is too much trouble to worry about.
7177 -- Note that we do not do this transformation if the Kill_Range_Check
7178 -- flag is set, since then the value may be outside the expected range.
7179 -- This happens in the Normalize_Scalars case.
7185 then
7186 declare
7189 begin
7191 and then
7193 and then
7195 and then
7197 then
7200 -- If Address is the target type, just set the type
7201 -- to avoid a spurious type error on the literal when
7202 -- Address is a visible integer type.
7206 else
7215 -- Nothing to do if conversion is safe
7221 -- Otherwise force evaluation unless Assignment_OK flag is set (this
7222 -- flag indicates ??? -- more comments needed here)
7226 else
7231 ----------------------------
7232 -- Expand_Record_Equality --
7233 ----------------------------
7235 -- For non-variant records, Equality is expanded when needed into:
7237 -- and then Lhs.Discr1 = Rhs.Discr1
7238 -- and then ...
7239 -- and then Lhs.Discrn = Rhs.Discrn
7240 -- and then Lhs.Cmp1 = Rhs.Cmp1
7241 -- and then ...
7242 -- and then Lhs.Cmpn = Rhs.Cmpn
7244 -- The expression is folded by the back-end for adjacent fields. This
7245 -- function is called for tagged record in only one occasion: for imple-
7246 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
7247 -- otherwise the primitive "=" is used directly.
7249 function Expand_Record_Equality
7255 is
7264 -- Return the first field to compare beginning with C, skipping the
7265 -- inherited components.
7267 ----------------------
7268 -- Suitable_Element --
7269 ----------------------
7272 begin
7278 then
7283 then
7288 then
7291 else
7296 -- Start of processing for Expand_Record_Equality
7298 begin
7299 -- Generates the following code: (assuming that Typ has one Discr and
7300 -- component C2 is also a record)
7302 -- True
7303 -- and then Lhs.Discr1 = Rhs.Discr1
7304 -- and then Lhs.C1 = Rhs.C1
7305 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
7306 -- and then ...
7307 -- and then Lhs.Cmpn = Rhs.Cmpn
7313 declare
7318 begin
7323 else
7328 Check :=
7330 Lhs =>
7334 Rhs =>
7340 -- If some (sub)component is an unchecked_union, the whole
7341 -- operation will raise program error.
7347 else
7348 Result :=
7361 -------------------------------------
7362 -- Fixup_Universal_Fixed_Operation --
7363 -------------------------------------
7368 begin
7369 -- We must have a type conversion immediately above us
7373 -- Normally the type conversion gives our target type. The exception
7374 -- occurs in the case of the Round attribute, where the conversion
7375 -- will be to universal real, and our real type comes from the Round
7376 -- attribute (as well as an indication that we must round the result)
7380 then
7384 -- Normal case where type comes from conversion above us
7386 else
7391 ------------------------------
7392 -- Get_Allocator_Final_List --
7393 ------------------------------
7395 function Get_Allocator_Final_List
7399 is
7403 -- The entity whose finalisation list must be used to attach the
7404 -- allocated object.
7406 begin
7409 in N_Subprogram_Specification
7410 then
7411 -- If the context is an access parameter, we need to create
7412 -- a non-anonymous access type in order to have a usable
7413 -- final list, because there is otherwise no pool to which
7414 -- the allocated object can belong. We create both the type
7415 -- and the finalization chain here, because freezing an
7416 -- internal type does not create such a chain. The Final_Chain
7417 -- that is thus created is shared by the access parameter.
7423 Type_Definition =>
7425 Subtype_Indication =>
7431 else
7432 -- Case of an access discriminant, or (Ada 2005) of
7433 -- an anonymous access component: find the final list
7434 -- associated with the scope of the type.
7443 ---------------------------------
7444 -- Has_Inferable_Discriminants --
7445 ---------------------------------
7450 -- Determines whether the left-most prefix of a selected component is a
7451 -- formal parameter in a subprogram. Assumes N is a selected component.
7453 --------------------------------
7454 -- Prefix_Is_Formal_Parameter --
7455 --------------------------------
7460 begin
7461 -- Move to the left-most prefix by climbing up the tree
7465 loop
7472 -- Start of processing for Has_Inferable_Discriminants
7474 begin
7475 -- For identifiers and indexed components, it is sufficent to have a
7476 -- constrained Unchecked_Union nominal subtype.
7479 or else
7481 then
7483 and then
7486 -- For selected components, the subtype of the selector must be a
7487 -- constrained Unchecked_Union. If the component is subject to a
7488 -- per-object constraint, then the enclosing object must have inferable
7489 -- discriminants.
7494 -- A small hack. If we have a per-object constrained selected
7495 -- component of a formal parameter, return True since we do not
7496 -- know the actual parameter association yet.
7502 -- Otherwise, check the enclosing object and the selector
7505 and then
7509 -- The call to Has_Inferable_Discriminants will determine whether
7510 -- the selector has a constrained Unchecked_Union nominal type.
7514 -- A qualified expression has inferable discriminants if its subtype
7515 -- mark is a constrained Unchecked_Union subtype.
7519 and then
7527 -------------------------------
7528 -- Insert_Dereference_Action --
7529 -------------------------------
7538 -- Return true if type of P is derived from Checked_Pool;
7540 -----------------------------
7541 -- Is_Checked_Storage_Pool --
7542 -----------------------------
7547 begin
7556 else
7564 -- Start of processing for Insert_Dereference_Action
7566 begin
7571 then
7582 -- Pool
7586 -- Storage_Address. We use the attribute Pool_Address,
7587 -- which uses the pointer itself to find the address of
7588 -- the object, and which handles unconstrained arrays
7589 -- properly by computing the address of the template.
7590 -- i.e. the correct address of the corresponding allocation.
7596 -- Size_In_Storage_Elements
7599 Left_Opnd =>
7601 Prefix =>
7605 Right_Opnd =>
7608 -- Alignment
7611 Prefix =>
7616 exception
7621 ------------------------------
7622 -- Make_Array_Comparison_Op --
7623 ------------------------------
7625 -- This is a hand-coded expansion of the following generic function:
7627 -- generic
7628 -- type elem is (<>);
7629 -- type index is (<>);
7630 -- type a is array (index range <>) of elem;
7631 --
7632 -- function Gnnn (X : a; Y: a) return boolean is
7633 -- J : index := Y'first;
7634 --
7635 -- begin
7636 -- if X'length = 0 then
7637 -- return false;
7638 --
7639 -- elsif Y'length = 0 then
7640 -- return true;
7641 --
7642 -- else
7643 -- for I in X'range loop
7644 -- if X (I) = Y (J) then
7645 -- if J = Y'last then
7646 -- exit;
7647 -- else
7648 -- J := index'succ (J);
7649 -- end if;
7650 --
7651 -- else
7652 -- return X (I) > Y (J);
7653 -- end if;
7654 -- end loop;
7655 --
7656 -- return X'length > Y'length;
7657 -- end if;
7658 -- end Gnnn;
7660 -- Note that since we are essentially doing this expansion by hand, we
7661 -- do not need to generate an actual or formal generic part, just the
7662 -- instantiated function itself.
7664 function Make_Array_Comparison_Op
7667 is
7688 begin
7689 -- if J = Y'last then
7690 -- exit;
7691 -- else
7692 -- J := index'succ (J);
7693 -- end if;
7695 Inner_If :=
7697 Condition =>
7700 Right_Opnd =>
7708 Else_Statements =>
7709 New_List (
7712 Expression =>
7718 -- if X (I) = Y (J) then
7719 -- if ... end if;
7720 -- else
7721 -- return X (I) > Y (J);
7722 -- end if;
7724 Loop_Body :=
7726 Condition =>
7728 Left_Opnd =>
7733 Right_Opnd =>
7742 Expression =>
7744 Left_Opnd =>
7749 Right_Opnd =>
7755 -- for I in X'range loop
7756 -- if ... end if;
7757 -- end loop;
7759 Loop_Statement :=
7763 Iteration_Scheme =>
7765 Loop_Parameter_Specification =>
7768 Discrete_Subtype_Definition =>
7775 -- if X'length = 0 then
7776 -- return false;
7777 -- elsif Y'length = 0 then
7778 -- return true;
7779 -- else
7780 -- for ... loop ... end loop;
7781 -- return X'length > Y'length;
7782 -- end if;
7784 Length1 :=
7789 Length2 :=
7794 Final_Expr :=
7799 If_Stat :=
7801 Condition =>
7803 Left_Opnd =>
7807 Right_Opnd =>
7810 Then_Statements =>
7811 New_List (
7817 Condition =>
7819 Left_Opnd =>
7823 Right_Opnd =>
7826 Then_Statements =>
7827 New_List (
7832 Loop_Statement,
7836 -- (X : a; Y: a)
7847 -- function Gnnn (...) return boolean is
7848 -- J : index := Y'first;
7849 -- begin
7850 -- if ... end if;
7851 -- end Gnnn;
7855 Func_Body :=
7857 Specification =>
7867 Expression =>
7872 Handled_Statement_Sequence =>
7879 ---------------------------
7880 -- Make_Boolean_Array_Op --
7881 ---------------------------
7883 -- For logical operations on boolean arrays, expand in line the
7884 -- following, replacing 'and' with 'or' or 'xor' where needed:
7886 -- function Annn (A : typ; B: typ) return typ is
7887 -- C : typ;
7888 -- begin
7889 -- for J in A'range loop
7890 -- C (J) := A (J) op B (J);
7891 -- end loop;
7892 -- return C;
7893 -- end Annn;
7895 -- Here typ is the boolean array type
7897 function Make_Boolean_Array_Op
7900 is
7918 begin
7919 A_J :=
7924 B_J :=
7929 C_J :=
7935 Op :=
7941 Op :=
7946 else
7947 Op :=
7953 Loop_Statement :=
7957 Iteration_Scheme =>
7959 Loop_Parameter_Specification =>
7962 Discrete_Subtype_Definition =>
7981 Func_Name :=
7985 Func_Body :=
7987 Specification =>
7998 Handled_Statement_Sequence =>
8001 Loop_Statement,
8008 ------------------------
8009 -- Rewrite_Comparison --
8010 ------------------------
8018 -- Res indicates if compare outcome can be determined at compile time
8023 begin
8034 and then Constant_Condition_Warnings
8037 and then not In_Instance
8040 then
8041 Error_Msg_N
8058 and then Constant_Condition_Warnings
8061 and then not In_Instance
8064 then
8065 Error_Msg_N
8088 ----------------------------
8089 -- Safe_In_Place_Array_Op --
8090 ----------------------------
8092 function Safe_In_Place_Array_Op
8096 is
8100 -- Operand is safe if it cannot overlap part of the target of the
8101 -- operation. If the operand and the target are identical, the operand
8102 -- is safe. The operand can be empty in the case of negation.
8105 -- Check that N is a stand-alone entity
8107 ------------------
8108 -- Is_Unaliased --
8109 ------------------
8112 begin
8113 return
8119 ---------------------
8120 -- Is_Safe_Operand --
8121 ---------------------
8124 begin
8133 then
8137 return
8144 else
8149 -- Start of processing for Is_Safe_In_Place_Array_Op
8151 begin
8152 -- We skip this processing if the component size is not the
8153 -- same as a system storage unit (since at least for NOT
8154 -- this would cause problems).
8159 -- Cannot do in place stuff on Java_VM since cannot pass addresses
8164 -- Cannot do in place stuff if non-standard Boolean representation
8171 else
8174 return
8180 -----------------------
8181 -- Tagged_Membership --
8182 -----------------------
8184 -- There are two different cases to consider depending on whether
8185 -- the right operand is a class-wide type or not. If not we just
8186 -- compare the actual tag of the left expr to the target type tag:
8187 --
8188 -- Left_Expr.Tag = Right_Type'Tag;
8189 --
8190 -- If it is a class-wide type we use the RT function CW_Membership which
8191 -- is usually implemented by looking in the ancestor tables contained in
8192 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
8203 begin
8211 Obj_Tag :=
8214 Selector_Name =>
8219 -- Ada 2005 (AI-251): Class-wide applied to interfaces
8223 -- Give support to: "Iface_CW_Typ in Typ'Class"
8226 then
8227 return
8234 New_Reference_To (
8235 Node (First_Elmt
8237 Loc)));
8239 -- Ada 95: Normal case
8241 else
8242 return
8246 Obj_Tag,
8247 New_Reference_To (
8248 Node (First_Elmt
8250 Loc)));
8253 else
8254 return
8257 Right_Opnd =>
8258 New_Reference_To
8263 ------------------------------
8264 -- Unary_Op_Validity_Checks --
8265 ------------------------------
8268 begin