| blob | e1da11baedf820ae66feedfe9995b0f1c0300e8d |
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 -- if N is the node for a comparison whose outcome can be determined at
196 -- compile time, then the node N can be rewritten with True or False. If
197 -- the outcome cannot be determined at compile time, the call has no
198 -- effect. If N is a type conversion, then this processing is applied to
199 -- its expression. If N is neither comparison nor a type conversion, the
200 -- call has no effect.
203 -- Construct the expression corresponding to the tagged membership test.
204 -- Deals with a second operand being (or not) a class-wide type.
206 function Safe_In_Place_Array_Op
210 -- In the context of an assignment, where the right-hand side is a
211 -- boolean operation on arrays, check whether operation can be performed
212 -- in place.
216 -- Performs validity checks for a unary operator
218 -------------------------------
219 -- Binary_Op_Validity_Checks --
220 -------------------------------
223 begin
230 ------------------------------------
231 -- Build_Boolean_Array_Proc_Call --
232 ------------------------------------
234 procedure Build_Boolean_Array_Proc_Call
238 is
251 begin
255 -- Use negated version of the binary operators
267 Call_Node :=
272 Target,
285 else
288 Call_Node :=
292 Target,
303 else
304 -- We use the following equivalences:
306 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
307 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
308 -- (not X) xor (not Y) = X xor Y
309 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
318 else
322 else
333 else
338 Call_Node :=
342 Target,
357 exception
362 ---------------------------------
363 -- Expand_Allocator_Expression --
364 ---------------------------------
378 -- Type used as source for tag assignment
381 -- Target reference for tag assignment
388 begin
391 -- Actions inserted before:
392 -- Temp : constant ptr_T := new T'(Expression);
393 -- <no CW> Temp._tag := T'tag;
394 -- <CTRL> Adjust (Finalizable (Temp.all));
395 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
397 -- We analyze by hand the new internal allocator to avoid
398 -- any recursion and inappropriate call to Initialize
404 Temp :=
407 -- For a class wide allocation generate the following code:
409 -- type Equiv_Record is record ... end record;
410 -- implicit subtype CW is <Class_Wide_Subytpe>;
411 -- temp : PtrT := new CW'(CW!(expr));
423 Tmp_Node :=
427 Expression =>
431 Set_Comes_From_Source
439 then
440 -- Create local finalization list for access parameter
446 else
457 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
458 -- type, generate an accessibility check to verify that the level of
459 -- the type of the created object is not deeper than the level of the
460 -- access type. If the type of the qualified expression is class-
461 -- wide, then always generate the check. Otherwise, only generate the
462 -- check if the level of the qualified expression type is statically
463 -- deeper than the access type. Although the static accessibility
464 -- will generally have been performed as a legality check, it won't
465 -- have been done in cases where the allocator appears in generic
466 -- body, so a run-time check is needed in general.
471 and then
473 or else
475 then
478 Condition =>
480 Left_Opnd =>
482 Name =>
484 Parameter_Associations =>
486 Prefix =>
488 Attribute_Name =>
489 Name_Tag))),
490 Right_Opnd =>
497 -- Suppress the tag assignment when Java_VM because JVM tags
498 -- are represented implicitly in objects.
508 then
517 Tag_Assign :=
519 Name =>
522 Selector_Name =>
525 Expression =>
527 New_Reference_To
529 Loc)));
531 -- The previous assignment has to be done in any case
539 then
540 declare
545 begin
546 -- If it is an allocation on the secondary stack
547 -- (i.e. a value returned from a function), the object
548 -- is attached on the caller side as soon as the call
549 -- is completed (see Expand_Ctrl_Function_Call)
552 declare
556 begin
567 -- Normal case, not a secondary stack allocation
569 else
572 then
573 -- Create local finalization list for access parameter
575 Flist :=
577 else
586 Make_Adjust_Call (
587 Ref =>
589 -- An unchecked conversion is needed in the
590 -- classwide case because the designated type
591 -- can be an ancestor of the subtype mark of
592 -- the allocator.
609 Temp :=
611 Tmp_Node :=
618 Set_Comes_From_Source
630 then
631 -- Apply constraint to designated subtype indication
639 -- Propagate constraint_error to enclosing allocator
643 else
644 -- First check against the type of the qualified expression
645 --
646 -- NOTE: The commented call should be correct, but for
647 -- some reason causes the compiler to bomb (sigsegv) on
648 -- ACVC test c34007g, so for now we just perform the old
649 -- (incorrect) test against the designated subtype with
650 -- no sliding in the else part of the if statement below.
651 -- ???
652 --
653 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
655 -- A check is also needed in cases where the designated
656 -- subtype is constrained and differs from the subtype
657 -- given in the qualified expression. Note that the check
658 -- on the qualified expression does not allow sliding,
659 -- but this check does (a relaxation from Ada 83).
662 and then not Subtypes_Statically_Match
664 then
665 Apply_Constraint_Check
668 -- The nonsliding check should really be performed
669 -- (unconditionally) against the subtype of the
670 -- qualified expression, but that causes a problem
671 -- with c34007g (see above), so for now we retain this.
673 else
674 Apply_Constraint_Check
678 -- For an access to unconstrained packed array, GIGI needs
679 -- to see an expression with a constrained subtype in order
680 -- to compute the proper size for the allocator.
685 then
686 declare
691 begin
695 Subtype_Indication =>
704 exception
709 -----------------------------
710 -- Expand_Array_Comparison --
711 -----------------------------
713 -- Expansion is only required in the case of array types. For the
714 -- unpacked case, an appropriate runtime routine is called. For
715 -- packed cases, and also in some other cases where a runtime
716 -- routine cannot be called, the form of the expansion is:
718 -- [body for greater_nn; boolean_expression]
720 -- The body is built by Make_Array_Comparison_Op, and the form of the
721 -- Boolean expression depends on the operator involved.
737 -- True for byte addressable target
740 -- Returns True if the length of the given operand is known to be
741 -- less than 4. Returns False if this length is known to be four
742 -- or greater or is not known at compile time.
744 ------------------------
745 -- Length_Less_Than_4 --
746 ------------------------
751 begin
755 else
756 declare
763 begin
766 else
772 else
781 -- Start of processing for Expand_Array_Comparison
783 begin
784 -- Deal first with unpacked case, where we can call a runtime routine
785 -- except that we avoid this for targets for which are not addressable
786 -- by bytes, and for the JVM, since the JVM does not support direct
787 -- addressing of array components.
790 and then Byte_Addressable
791 and then not Java_VM
792 then
793 -- The call we generate is:
795 -- Compare_Array_xn[_Unaligned]
796 -- (left'address, right'address, left'length, right'length) <op> 0
798 -- x = U for unsigned, S for signed
799 -- n = 8,16,32,64 for component size
800 -- Add _Unaligned if length < 4 and component size is 8.
801 -- <op> is the standard comparison operator
805 or else
807 then
810 else
814 else
817 else
825 else
832 else
839 else
877 -- Cases where we cannot make runtime call
879 -- For (a <= b) we convert to not (a > b)
884 Right_Opnd =>
891 -- For < the Boolean expression is
892 -- greater__nn (op2, op1)
897 -- Switch operands
902 -- For (a >= b) we convert to not (a < b)
907 Right_Opnd =>
914 -- For > the Boolean expression is
915 -- greater__nn (op1, op2)
917 else
923 Expr :=
932 exception
937 ---------------------------
938 -- Expand_Array_Equality --
939 ---------------------------
941 -- Expand an equality function for multi-dimensional arrays. Here is
942 -- an example of such a function for Nb_Dimension = 2
944 -- function Enn (A : atyp; B : btyp) return boolean is
945 -- begin
946 -- if (A'length (1) = 0 or else A'length (2) = 0)
947 -- and then
948 -- (B'length (1) = 0 or else B'length (2) = 0)
949 -- then
950 -- return True; -- RM 4.5.2(22)
951 -- end if;
953 -- if A'length (1) /= B'length (1)
954 -- or else
955 -- A'length (2) /= B'length (2)
956 -- then
957 -- return False; -- RM 4.5.2(23)
958 -- end if;
960 -- declare
961 -- A1 : Index_T1 := A'first (1);
962 -- B1 : Index_T1 := B'first (1);
963 -- begin
964 -- loop
965 -- declare
966 -- A2 : Index_T2 := A'first (2);
967 -- B2 : Index_T2 := B'first (2);
968 -- begin
969 -- loop
970 -- if A (A1, A2) /= B (B1, B2) then
971 -- return False;
972 -- end if;
974 -- exit when A2 = A'last (2);
975 -- A2 := Index_T2'succ (A2);
976 -- B2 := Index_T2'succ (B2);
977 -- end loop;
978 -- end;
980 -- exit when A1 = A'last (1);
981 -- A1 := Index_T1'succ (A1);
982 -- B1 := Index_T1'succ (B1);
983 -- end loop;
984 -- end;
986 -- return true;
987 -- end Enn;
989 -- Note on the formal types used (atyp and btyp). If either of the
990 -- arrays is of a private type, we use the underlying type, and
991 -- do an unchecked conversion of the actual. If either of the arrays
992 -- has a bound depending on a discriminant, then we use the base type
993 -- since otherwise we have an escaped discriminant in the function.
995 -- If both arrays are constrained and have the same bounds, we can
996 -- generate a loop with an explicit iteration scheme using a 'Range
997 -- attribute over the first array.
999 function Expand_Array_Equality
1005 is
1021 -- The parameter types to be used for the formals
1023 function Arr_Attr
1027 -- This builds the attribute reference Arr'Nam (Expr)
1030 -- Create one statement to compare corresponding components,
1031 -- designated by a full set of indices.
1034 -- Given one of the arguments, computes the appropriate type to
1035 -- be used for that argument in the corresponding function formal
1037 function Handle_One_Dimension
1040 -- This procedure returns the following code
1041 --
1042 -- declare
1043 -- Bn : Index_T := B'First (N);
1044 -- begin
1045 -- loop
1046 -- xxx
1047 -- exit when An = A'Last (N);
1048 -- An := Index_T'Succ (An)
1049 -- Bn := Index_T'Succ (Bn)
1050 -- end loop;
1051 -- end;
1052 --
1053 -- If both indices are constrained and identical, the procedure
1054 -- returns a simpler loop:
1055 --
1056 -- for An in A'Range (N) loop
1057 -- xxx
1058 -- end loop
1059 --
1060 -- N is the dimension for which we are generating a loop. Index is the
1061 -- N'th index node, whose Etype is Index_Type_n in the above code.
1062 -- The xxx statement is either the loop or declare for the next
1063 -- dimension or if this is the last dimension the comparison
1064 -- of corresponding components of the arrays.
1065 --
1066 -- The actual way the code works is to return the comparison
1067 -- of corresponding components for the N+1 call. That's neater!
1070 -- This function constructs the test for both arrays being empty
1071 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1072 -- and then
1073 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1076 -- This function constructs the test for arrays having different
1077 -- lengths in at least one index position, in which case resull
1079 -- A'length (1) /= B'length (1)
1080 -- or else
1081 -- A'length (2) /= B'length (2)
1082 -- or else
1083 -- ...
1085 --------------
1086 -- Arr_Attr --
1087 --------------
1089 function Arr_Attr
1093 is
1094 begin
1095 return
1102 ------------------------
1103 -- Component_Equality --
1104 ------------------------
1110 begin
1111 -- if a(i1...) /= b(j1...) then return false; end if;
1113 L :=
1118 R :=
1123 Test := Expand_Composite_Equality
1126 -- If some (sub)component is an unchecked_union, the whole operation
1127 -- will raise program error.
1131 -- This node is going to be inserted at a location where a
1132 -- statement is expected: clear its Etype so analysis will
1133 -- set it to the expected Standard_Void_Type.
1138 else
1139 return
1148 ------------------
1149 -- Get_Arg_Type --
1150 ------------------
1156 begin
1162 else
1168 or else
1170 then
1182 --------------------------
1183 -- Handle_One_Dimension --
1184 ---------------------------
1186 function Handle_One_Dimension
1189 is
1191 Ltyp /= Rtyp
1193 -- If the index types are identical, and we are working with
1194 -- constrained types, then we can use the same index for both of
1195 -- the arrays.
1205 begin
1210 -- Case where we generate a loop
1215 Bn :=
1218 else
1230 -- Generate guard for loop, followed by increments of indices
1234 Condition =>
1242 Expression =>
1251 Expression =>
1258 -- If separate indexes, we need a declare block for An and Bn, and a
1259 -- loop without an iteration scheme.
1262 Loop_Stm :=
1265 return
1278 Handled_Statement_Sequence =>
1282 -- If no separate indexes, return loop statement with explicit
1283 -- iteration scheme on its own
1285 else
1286 Loop_Stm :=
1289 Iteration_Scheme =>
1291 Loop_Parameter_Specification =>
1294 Discrete_Subtype_Definition =>
1300 -----------------------
1301 -- Test_Empty_Arrays --
1302 -----------------------
1311 begin
1315 Atest :=
1320 Btest :=
1329 else
1330 Alist :=
1335 Blist :=
1342 return
1348 -----------------------------
1349 -- Test_Lengths_Correspond --
1350 -----------------------------
1356 begin
1359 Rtest :=
1366 else
1367 Result :=
1377 -- Start of processing for Expand_Array_Equality
1379 begin
1383 -- For now, if the argument types are not the same, go to the
1384 -- base type, since the code assumes that the formals have the
1385 -- same type. This is fixable in future ???
1393 -- Build list of formals for function
1406 -- Build statement sequence for function
1408 Func_Body :=
1410 Specification =>
1418 Handled_Statement_Sequence =>
1426 Expression =>
1433 Expression =>
1444 -- If the array type is distinct from the type of the arguments,
1445 -- it is the full view of a private type. Apply an unchecked
1446 -- conversion to insure that analysis of the call succeeds.
1448 declare
1451 begin
1457 then
1463 then
1472 return
1478 -----------------------------
1479 -- Expand_Boolean_Operator --
1480 -----------------------------
1482 -- Note that we first get the actual subtypes of the operands,
1483 -- since we always want to deal with types that have bounds.
1488 begin
1489 -- Special case of bit packed array where both operands are known
1490 -- to be properly aligned. In this case we use an efficient run time
1491 -- routine to carry out the operation (see System.Bit_Ops).
1496 then
1501 -- For the normal non-packed case, the general expansion is to build
1502 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1503 -- and then inserting it into the tree. The original operator node is
1504 -- then rewritten as a call to this function. We also use this in the
1505 -- packed case if either operand is a possibly unaligned object.
1507 declare
1514 begin
1523 then
1528 and then
1530 then
1532 else
1538 -- Now rewrite the expression with a call
1543 Parameter_Associations =>
1544 New_List (
1545 L,
1546 Make_Type_Conversion
1554 -------------------------------
1555 -- Expand_Composite_Equality --
1556 -------------------------------
1558 -- This function is only called for comparing internal fields of composite
1559 -- types when these fields are themselves composites. This is a special
1560 -- case because it is not possible to respect normal Ada visibility rules.
1562 function Expand_Composite_Equality
1568 is
1574 begin
1577 else
1581 -- Defense against malformed private types with no completion
1582 -- the error will be diagnosed later by check_completion
1592 -- If the operand is an elementary type other than a floating-point
1593 -- type, then we can simply use the built-in block bitwise equality,
1594 -- since the predefined equality operators always apply and bitwise
1595 -- equality is fine for all these cases.
1599 then
1602 -- For composite component types, and floating-point types, use
1603 -- the expansion. This deals with tagged component types (where
1604 -- we use the applicable equality routine) and floating-point,
1605 -- (where we need to worry about negative zeroes), and also the
1606 -- case of any composite type recursively containing such fields.
1608 else
1614 -- Call the primitive operation "=" of this type
1620 -- If this is derived from an untagged private type completed
1621 -- with a tagged type, it does not have a full view, so we
1622 -- use the primitive operations of the private type.
1623 -- This check should no longer be necessary when these
1624 -- types receive their full views ???
1631 then
1633 else
1637 loop
1649 return
1652 Parameter_Associations =>
1653 New_List
1663 -- Inherited equality from parent type. Convert the actuals
1664 -- to match signature of operation.
1666 declare
1669 begin
1670 return
1673 Parameter_Associations =>
1678 else
1679 -- Comparison between Unchecked_Union components
1682 declare
1688 begin
1689 -- Lhs subtype
1695 -- Rhs subtype
1701 -- Lhs of the composite equality
1705 -- Since the enclosing record can never be an
1706 -- Unchecked_Union (this code is executed for records
1707 -- that do not have variants), we may reference its
1708 -- discriminant(s).
1713 then
1714 Lhs_Discr_Val :=
1717 Selector_Name =>
1718 New_Copy (
1719 Get_Discriminant_Value (
1721 Lhs_Type,
1724 else
1726 Get_Discriminant_Value (
1728 Lhs_Type,
1732 else
1733 -- It is not possible to infer the discriminant since
1734 -- the subtype is not constrained.
1736 return
1741 -- Rhs of the composite equality
1747 then
1748 Rhs_Discr_Val :=
1751 Selector_Name =>
1752 New_Copy (
1753 Get_Discriminant_Value (
1755 Rhs_Type,
1758 else
1760 Get_Discriminant_Value (
1762 Rhs_Type,
1766 else
1767 return
1772 -- Call the TSS equality function with the inferred
1773 -- discriminant values.
1775 return
1779 Lhs,
1780 Rhs,
1781 Lhs_Discr_Val,
1782 Rhs_Discr_Val));
1786 -- Shouldn't this be an else, we can't fall through
1787 -- the above IF, right???
1789 return
1795 else
1799 else
1800 -- It can be a simple record or the full view of a scalar private
1806 ------------------------------
1807 -- Expand_Concatenate_Other --
1808 ------------------------------
1810 -- Let n be the number of array operands to be concatenated, Base_Typ
1811 -- their base type, Ind_Typ their index type, and Arr_Typ the original
1812 -- array type to which the concatenantion operator applies, then the
1813 -- following subprogram is constructed:
1815 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1816 -- L : Ind_Typ;
1817 -- begin
1818 -- if S1'Length /= 0 then
1819 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
1820 -- XXX = Arr_Typ'First otherwise
1821 -- elsif S2'Length /= 0 then
1822 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
1823 -- YYY = Arr_Typ'First otherwise
1824 -- ...
1825 -- elsif Sn-1'Length /= 0 then
1826 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
1827 -- ZZZ = Arr_Typ'First otherwise
1828 -- else
1829 -- return Sn;
1830 -- end if;
1832 -- declare
1833 -- P : Ind_Typ;
1834 -- H : Ind_Typ :=
1835 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1836 -- + Ind_Typ'Pos (L));
1837 -- R : Base_Typ (L .. H);
1838 -- begin
1839 -- if S1'Length /= 0 then
1840 -- P := S1'First;
1841 -- loop
1842 -- R (L) := S1 (P);
1843 -- L := Ind_Typ'Succ (L);
1844 -- exit when P = S1'Last;
1845 -- P := Ind_Typ'Succ (P);
1846 -- end loop;
1847 -- end if;
1848 --
1849 -- if S2'Length /= 0 then
1850 -- L := Ind_Typ'Succ (L);
1851 -- loop
1852 -- R (L) := S2 (P);
1853 -- L := Ind_Typ'Succ (L);
1854 -- exit when P = S2'Last;
1855 -- P := Ind_Typ'Succ (P);
1856 -- end loop;
1857 -- end if;
1859 -- ...
1861 -- if Sn'Length /= 0 then
1862 -- P := Sn'First;
1863 -- loop
1864 -- R (L) := Sn (P);
1865 -- L := Ind_Typ'Succ (L);
1866 -- exit when P = Sn'Last;
1867 -- P := Ind_Typ'Succ (P);
1868 -- end loop;
1869 -- end if;
1871 -- return R;
1872 -- end;
1873 -- end Cnn;]
1911 -- Builds the sequence of statement:
1912 -- P := Si'First;
1913 -- loop
1914 -- R (L) := Si (P);
1915 -- L := Ind_Typ'Succ (L);
1916 -- exit when P = Si'Last;
1917 -- P := Ind_Typ'Succ (P);
1918 -- end loop;
1919 --
1920 -- where i is the input parameter I given.
1921 -- If the flag Last is true, the exit statement is emitted before
1922 -- incrementing the lower bound, to prevent the creation out of
1923 -- bound values.
1926 -- Builds the statement:
1927 -- L := Arr_Typ'First; If Arr_Typ is constrained
1928 -- L := Si'First; otherwise (where I is the input param given)
1931 -- Builds reference to identifier H
1934 -- Builds expression Ind_Typ'Val (E);
1937 -- Builds reference to identifier L
1940 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
1941 -- expression to avoid universal_integer computations whenever possible,
1942 -- in the expression for the upper bound H.
1945 -- Builds expression Ind_Typ'Succ (L)
1948 -- Builds integer literal one
1951 -- Builds reference to identifier P
1954 -- Builds expression Ind_Typ'Succ (P)
1957 -- Builds reference to identifier R
1960 -- Builds reference to identifier Si, where I is the value given
1963 -- Builds expression Si'First, where I is the value given
1966 -- Builds expression Si'Last, where I is the value given
1969 -- Builds expression Si'Length, where I is the value given
1972 -- Builds expression Si'Length /= 0, where I is the value given
1974 -------------------
1975 -- Copy_Into_R_S --
1976 -------------------
1987 begin
1988 -- First construct the initializations
1995 -- Then build the loop
2017 Loop_Stmt :=
2020 else
2021 Loop_Stmt :=
2031 -------
2032 -- H --
2033 -------
2036 begin
2040 -------------
2041 -- Ind_Val --
2042 -------------
2045 begin
2046 return
2053 ------------
2054 -- Init_L --
2055 ------------
2060 begin
2066 else
2073 -------
2074 -- L --
2075 -------
2078 begin
2082 -----------
2083 -- L_Pos --
2084 -----------
2089 begin
2090 -- If the index type is an enumeration type, the computation
2091 -- can be done in standard integer. Otherwise, choose a large
2092 -- enough integer type.
2098 then
2100 else
2104 return
2107 Expression =>
2114 ------------
2115 -- L_Succ --
2116 ------------
2119 begin
2120 return
2127 ---------
2128 -- One --
2129 ---------
2132 begin
2136 -------
2137 -- P --
2138 -------
2141 begin
2145 ------------
2146 -- P_Succ --
2147 ------------
2150 begin
2151 return
2158 -------
2159 -- R --
2160 -------
2163 begin
2167 -------
2168 -- S --
2169 -------
2172 begin
2176 -------------
2177 -- S_First --
2178 -------------
2181 begin
2187 ------------
2188 -- S_Last --
2189 ------------
2192 begin
2198 --------------
2199 -- S_Length --
2200 --------------
2203 begin
2209 -------------------
2210 -- S_Length_Test --
2211 -------------------
2214 begin
2215 return
2221 -- Start of processing for Expand_Concatenate_Other
2223 begin
2224 -- Construct the parameter specs and the overall function spec
2228 Append_To
2231 Defining_Identifier =>
2237 Func_Spec :=
2243 -- Construct L's object declaration
2245 L_Decl :=
2252 -- Construct the if-then-elsif statements
2261 If_Stmt :=
2269 -- Construct the declaration for H
2271 P_Decl :=
2282 H_Decl :=
2288 -- Construct the declaration for R
2291 R_Constr :=
2295 R_Decl :=
2298 Object_Definition =>
2303 -- Construct the declarations for the declare block
2307 -- Construct list of statements for the declare block
2319 -- Construct the declare block
2323 Handled_Statement_Sequence =>
2326 -- Construct the list of function statements
2330 -- Construct the function body
2332 Func_Body :=
2336 Handled_Statement_Sequence =>
2339 -- Insert the newly generated function in the code. This is analyzed
2340 -- with all checks off, since we have completed all the checks.
2342 -- Note that this does *not* fix the array concatenation bug when the
2343 -- low bound is Integer'first sibce that bug comes from the pointer
2344 -- dereferencing an unconstrained array. An there we need a constraint
2345 -- check to make sure the length of the concatenated array is ok. ???
2349 -- Construct list of arguments for the function call
2358 -- Insert the function call
2360 Rewrite
2368 -------------------------------
2369 -- Expand_Concatenate_String --
2370 -------------------------------
2380 -- RE_Id value for function to be called
2382 begin
2383 -- In all cases, we build a call to a routine giving the list of
2384 -- arguments as the parameter list to the routine.
2392 else
2401 else
2406 -- If we have anything other than Standard_Character or
2407 -- Standard_String, then we must have had a serious error
2408 -- earlier, so we just abandon the attempt at expansion.
2410 else
2429 -- Now generate the appropriate call
2438 exception
2443 ------------------------
2444 -- Expand_N_Allocator --
2445 ------------------------
2455 begin
2456 -- RM E.2.3(22). We enforce that the expected type of an allocator
2457 -- shall not be a remote access-to-class-wide-limited-private type
2459 -- Why is this being done at expansion time, seems clearly wrong ???
2463 -- Set the Storage Pool
2476 else
2482 -- Under certain circumstances we can replace an allocator by an
2483 -- access to statically allocated storage. The conditions, as noted
2484 -- in AARM 3.10 (10c) are as follows:
2486 -- Size and initial value is known at compile time
2487 -- Access type is access-to-constant
2489 -- The allocator is not part of a constraint on a record component,
2490 -- because in that case the inserted actions are delayed until the
2491 -- record declaration is fully analyzed, which is too late for the
2492 -- analysis of the rewritten allocator.
2500 then
2501 -- Here we can do the optimization. For the allocator
2503 -- new x'(y)
2505 -- We insert an object declaration
2507 -- Tnn : aliased x := y;
2509 -- and replace the allocator by Tnn'Unrestricted_Access.
2510 -- Tnn is marked as requiring static allocation.
2512 Temp :=
2517 -- If context is constrained, use constrained subtype directly,
2518 -- so that the constant is not labelled as having a nomimally
2519 -- unconstrained subtype.
2540 -- We set the variable as statically allocated, since we don't
2541 -- want it going on the stack of the current procedure!
2547 -- Handle case of qualified expression (other than optimization above)
2552 -- If the allocator is for a type which requires initialization, and
2553 -- there is no initial value (i.e. operand is a subtype indication
2554 -- rather than a qualifed expression), then we must generate a call
2555 -- to the initialization routine. This is done using an expression
2556 -- actions node:
2557 --
2558 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2559 --
2560 -- Here ptr_T is the pointer type for the allocator, and T is the
2561 -- subtype of the allocator. A special case arises if the designated
2562 -- type of the access type is a task or contains tasks. In this case
2563 -- the call to Init (Temp.all ...) is replaced by code that ensures
2564 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2565 -- for details). In addition, if the type T is a task T, then the
2566 -- first argument to Init must be converted to the task record type.
2568 else
2569 declare
2582 begin
2586 -- Case of no initialization procedure present
2590 -- Case of simple initialization required
2603 -- No initialization required
2605 else
2609 -- Case of initialization procedure present, must be called
2611 else
2614 Temp :=
2617 -- Construct argument list for the initialization routine call
2618 -- The CPP constructor needs the address directly
2624 else
2625 Arg1 :=
2631 -- The initialization procedure expects a specific type.
2632 -- if the context is access to class wide, indicate that
2633 -- the object being allocated has the right specific type.
2640 -- If designated type is a concurrent type or if it is a
2641 -- private type whose definition is a concurrent type,
2642 -- the first argument in the Init routine has to be
2643 -- unchecked conversion to the corresponding record type.
2644 -- If the designated type is a derived type, we also
2645 -- convert the argument to its root type.
2648 Arg1 :=
2654 then
2655 Arg1 :=
2656 Unchecked_Convert_To
2661 declare
2664 begin
2672 -- For the task case, pass the Master_Id of the access type
2673 -- as the value of the _Master parameter, and _Chain as the
2674 -- value of the _Chain parameter (_Chain will be defined as
2675 -- part of the generated code for the allocator).
2680 -- The designated type was an incomplete type, and
2681 -- the access type did not get expanded. Salvage
2682 -- it now.
2684 Expand_N_Full_Type_Declaration
2688 -- If the context of the allocator is a declaration or
2689 -- an assignment, we can generate a meaningful image for
2690 -- it, even though subsequent assignments might remove
2691 -- the connection between task and entity. We build this
2692 -- image when the left-hand side is a simple variable,
2693 -- a simple indexed assignment or a simple selected
2694 -- component.
2697 declare
2700 begin
2702 Decls :=
2703 Build_Task_Image_Decls (
2704 Loc,
2705 New_Occurrence_Of
2711 then
2712 Decls :=
2713 Build_Task_Image_Decls
2715 else
2721 Decls :=
2722 Build_Task_Image_Decls (
2725 else
2730 New_Reference_To
2738 -- Has_Task is false, Decls not used
2740 else
2744 -- Add discriminants if discriminated type
2757 then
2758 Discr :=
2767 -- We set the allocator as analyzed so that when we analyze the
2768 -- expression actions node, we do not get an unwanted recursive
2769 -- expansion of the allocator expression.
2774 -- Here is the transformation:
2775 -- input: new T
2776 -- output: Temp : constant ptr_T := new T;
2777 -- Init (Temp.all, ...);
2778 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
2779 -- <CTRL> Initialize (Finalizable (Temp.all));
2781 -- Here ptr_T is the pointer type for the allocator, and T
2782 -- is the subtype of the allocator.
2784 Temp_Decl :=
2799 -- If the designated type is task type or contains tasks,
2800 -- Create block to activate created tasks, and insert
2801 -- declaration for Task_Image variable ahead of call.
2804 declare
2808 begin
2816 else
2827 else
2831 Make_Init_Call (
2836 Attach_Level)));
2844 else
2853 exception
2858 -----------------------
2859 -- Expand_N_And_Then --
2860 -----------------------
2862 -- Expand into conditional expression if Actions present, and also
2863 -- deal with optimizing case of arguments being True or False.
2872 begin
2873 -- Deal with non-standard booleans
2881 -- Check for cases of left argument is True or False
2885 -- If left argument is True, change (True and then Right) to Right.
2886 -- Any actions associated with Right will be executed unconditionally
2887 -- and can thus be inserted into the tree unconditionally.
2898 -- If left argument is False, change (False and then Right) to
2899 -- False. In this case we can forget the actions associated with
2900 -- Right, since they will never be executed.
2911 -- If Actions are present, we expand
2913 -- left and then right
2915 -- into
2917 -- if left then right else false end
2919 -- with the actions becoming the Then_Actions of the conditional
2920 -- expression. This conditional expression is then further expanded
2921 -- (and will eventually disappear)
2928 Left,
2929 Right,
2938 -- No actions present, check for cases of right argument True/False
2942 -- Change (Left and then True) to Left. Note that we know there
2943 -- are no actions associated with the True operand, since we
2944 -- just checked for this case above.
2949 -- Change (Left and then False) to False, making sure to preserve
2950 -- any side effects associated with the Left operand.
2954 Rewrite
2962 -------------------------------------
2963 -- Expand_N_Conditional_Expression --
2964 -------------------------------------
2966 -- Expand into expression actions if then/else actions present
2977 begin
2978 -- If either then or else actions are present, then given:
2980 -- if cond then then-expr else else-expr end
2982 -- we insert the following sequence of actions (using Insert_Actions):
2984 -- Cnn : typ;
2985 -- if cond then
2986 -- <<then actions>>
2987 -- Cnn := then-expr;
2988 -- else
2989 -- <<else actions>>
2990 -- Cnn := else-expr
2991 -- end if;
2993 -- and replace the conditional expression by a reference to Cnn
2998 New_If :=
3016 Insert_List_Before
3021 Insert_List_Before
3037 -----------------------------------
3038 -- Expand_N_Explicit_Dereference --
3039 -----------------------------------
3042 begin
3043 -- The only processing required is an insertion of an explicit
3044 -- dereference call for the checked storage pool case.
3049 -----------------
3050 -- Expand_N_In --
3051 -----------------
3061 -- Replaces node N by Lop'Valid. This is done when we have an explicit
3062 -- test for the left operand being in range of its subtype.
3064 ----------------------------
3065 -- Substitute_Valid_Check --
3066 ----------------------------
3069 begin
3082 -- Start of processing for Expand_N_In
3084 begin
3085 -- Check case of explicit test for an expression in range of its
3086 -- subtype. This is suspicious usage and we replace it with a 'Valid
3087 -- test and give a warning.
3093 then
3094 Substitute_Valid_Check;
3098 -- Case of explicit range
3101 declare
3111 begin
3112 -- If test is explicit x'first .. x'last, replace by valid check
3124 then
3125 Substitute_Valid_Check;
3129 -- If we have an explicit range, do a bit of optimization based
3130 -- on range analysis (we may be able to kill one or both checks).
3132 -- If either check is known to fail, replace result by False since
3133 -- the other check does not matter. Preserve the static flag for
3134 -- legality checks, because we are constant-folding beyond RM 4.9.
3143 -- If both checks are known to succeed, replace result
3144 -- by True, since we know we are in range.
3153 -- If lower bound check succeeds and upper bound check is
3154 -- not known to succeed or fail, then replace the range check
3155 -- with a comparison against the upper bound.
3165 -- If upper bound check succeeds and lower bound check is
3166 -- not known to succeed or fail, then replace the range check
3167 -- with a comparison against the lower bound.
3179 -- For all other cases of an explicit range, nothing to be done
3183 -- Here right operand is a subtype mark
3185 else
3186 declare
3192 begin
3195 -- For tagged type, do tagged membership operation
3199 -- No expansion will be performed when Java_VM, as the
3200 -- JVM back end will handle the membership tests directly
3201 -- (tags are not explicitly represented in Java objects,
3202 -- so the normal tagged membership expansion is not what
3203 -- we want).
3212 -- If type is scalar type, rewrite as x in t'first .. t'last
3213 -- This reason we do this is that the bounds may have the wrong
3214 -- type if they come from the original type definition.
3219 Low_Bound =>
3224 High_Bound =>
3231 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
3232 -- a membership test if the subtype mark denotes a constrained
3233 -- Unchecked_Union subtype and the expression lacks inferable
3234 -- discriminants.
3239 then
3244 -- Prevent Gigi from generating incorrect code by rewriting
3245 -- the test as a standard False.
3253 -- Here we have a non-scalar type
3264 -- For the constrained array case, we have to check the
3265 -- subscripts for an exact match if the lengths are
3266 -- non-zero (the lengths must match in any case).
3271 function Construct_Attribute_Reference
3275 -- Build attribute reference E'Nam(Dim)
3277 -----------------------------------
3278 -- Construct_Attribute_Reference --
3279 -----------------------------------
3281 function Construct_Attribute_Reference
3285 is
3286 begin
3287 return
3295 -- Start processing for Check_Subscripts
3297 begin
3301 Left_Opnd =>
3302 Construct_Attribute_Reference
3305 Right_Opnd =>
3306 Construct_Attribute_Reference
3311 Left_Opnd =>
3312 Construct_Attribute_Reference
3315 Right_Opnd =>
3316 Construct_Attribute_Reference
3321 Cond :=
3323 Left_Opnd =>
3334 -- These are the cases where constraint checks may be
3335 -- required, e.g. records with possible discriminants
3337 else
3338 -- Expand the test into a series of discriminant comparisons.
3339 -- The expression that is built is the negation of the one
3340 -- that is used for checking discriminant constraints.
3350 Left_Opnd =>
3357 else
3368 --------------------------------
3369 -- Expand_N_Indexed_Component --
3370 --------------------------------
3378 begin
3379 -- A special optimization, if we have an indexed component that
3380 -- is selecting from a slice, then we can eliminate the slice,
3381 -- since, for example, x (i .. j)(k) is identical to x(k). The
3382 -- only difference is the range check required by the slice. The
3383 -- range check for the slice itself has already been generated.
3384 -- The range check for the subscripting operation is ensured
3385 -- by converting the subject to the subtype of the slice.
3387 -- This optimization not only generates better code, avoiding
3388 -- slice messing especially in the packed case, but more importantly
3389 -- bypasses some problems in handling this peculiar case, for
3390 -- example, the issue of dealing specially with object renamings.
3397 Convert_To
3404 -- If the prefix is an access type, then we unconditionally rewrite
3405 -- if as an explicit deference. This simplifies processing for several
3406 -- cases, including packed array cases and certain cases in which
3407 -- checks must be generated. We used to try to do this only when it
3408 -- was necessary, but it cleans up the code to do it all the time.
3415 -- Generate index and validity checks
3423 -- All done for the non-packed case
3429 -- For packed arrays that are not bit-packed (i.e. the case of an array
3430 -- with one or more index types with a non-coniguous enumeration type),
3431 -- we can always use the normal packed element get circuit.
3438 -- For a reference to a component of a bit packed array, we have to
3439 -- convert it to a reference to the corresponding Packed_Array_Type.
3440 -- We only want to do this for simple references, and not for:
3442 -- Left side of assignment, or prefix of left side of assignment,
3443 -- or prefix of the prefix, to handle packed arrays of packed arrays,
3444 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3446 -- Renaming objects in renaming associations
3447 -- This case is handled when a use of the renamed variable occurs
3449 -- Actual parameters for a procedure call
3450 -- This case is handled in Exp_Ch6.Expand_Actuals
3452 -- The second expression in a 'Read attribute reference
3454 -- The prefix of an address or size attribute reference
3456 -- The following circuit detects these exceptions
3458 declare
3462 begin
3463 loop
3470 and then
3472 then
3477 or else
3480 then
3485 then
3488 -- If the expression is an index of an indexed component,
3489 -- it must be expanded regardless of context.
3493 then
3499 then
3505 then
3511 then
3514 else
3519 -- Keep looking up tree for unchecked expression, or if we are
3520 -- the prefix of a possible assignment left side.
3528 ---------------------
3529 -- Expand_N_Not_In --
3530 ---------------------
3532 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
3533 -- can be done. This avoids needing to duplicate this expansion code.
3540 begin
3543 Right_Opnd =>
3548 -- We want this tp appear as coming from source if original does (see
3549 -- tranformations in Expand_N_In).
3554 -- Now analyze tranformed node
3559 -------------------
3560 -- Expand_N_Null --
3561 -------------------
3563 -- The only replacement required is for the case of a null of type
3564 -- that is an access to protected subprogram. We represent such
3565 -- access values as a record, and so we must replace the occurrence
3566 -- of null by the equivalent record (with a null address and a null
3567 -- pointer in it), so that the backend creates the proper value.
3574 begin
3576 Agg :=
3585 -- For subsequent semantic analysis, the node must retain its
3586 -- type. Gigi in any case replaces this type by the corresponding
3587 -- record type before processing the node.
3592 exception
3597 ---------------------
3598 -- Expand_N_Op_Abs --
3599 ---------------------
3605 begin
3608 -- Deal with software overflow checking
3610 if not Backend_Overflow_Checks_On_Target
3613 then
3614 -- The only case to worry about is when the argument is
3615 -- equal to the largest negative number, so what we do is
3616 -- to insert the check:
3618 -- [constraint_error when Expr = typ'Base'First]
3620 -- with the usual Duplicate_Subexpr use coding for expr
3624 Condition =>
3627 Right_Opnd =>
3629 Prefix =>
3635 -- Vax floating-point types case
3642 ---------------------
3643 -- Expand_N_Op_Add --
3644 ---------------------
3649 begin
3652 -- N + 0 = 0 + N = N for integer types
3657 then
3663 then
3669 -- Arithmetic overflow checks for signed integer/fixed point types
3673 then
3677 -- Vax floating-point types case
3684 ---------------------
3685 -- Expand_N_Op_And --
3686 ---------------------
3691 begin
3705 ------------------------
3706 -- Expand_N_Op_Concat --
3707 ------------------------
3710 -- This is initialized the first time this routine is called. It records
3711 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3712 -- available in the run-time:
3713 --
3714 -- 0 None available
3715 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
3716 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3717 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3718 -- 5 All routines including RE_Str_Concat_5 available
3721 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3722 -- all three are available, False if any one of these is unavailable.
3726 -- List of operands to be concatenated
3729 -- Single operand for concatenation
3732 -- Node which is to be replaced by the result of concatenating
3733 -- the nodes in the list Opnds.
3736 -- Array type of concatenation result type
3739 -- Component type of concatenation represented by Cnode
3741 begin
3742 -- Initialize global variables showing run-time status
3753 else
3757 Char_Concat_Available :=
3759 and then
3761 and then
3765 -- Ensure validity of both operands
3769 -- If we are the left operand of a concatenation higher up the
3770 -- tree, then do nothing for now, since we want to deal with a
3771 -- series of concatenations as a unit.
3775 then
3779 -- We get here with a concatenation whose left operand may be a
3780 -- concatenation itself with a consistent type. We need to process
3781 -- these concatenation operands from left to right, which means
3782 -- from the deepest node in the tree to the highest node.
3789 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
3790 -- nodes above, so now we process bottom up, doing the operations. We
3791 -- gather a string that is as long as possible up to five operands
3793 -- The outer loop runs more than once if there are more than five
3794 -- concatenations of type Standard.String, the most we handle for
3795 -- this case, or if more than one concatenation type is involved.
3801 -- The inner loop gathers concatenation operands. We gather any
3802 -- number of these in the non-string case, or if no concatenation
3803 -- routines are available for string (since in that case we will
3804 -- treat string like any other non-string case). Otherwise we only
3805 -- gather as many operands as can be handled by the available
3806 -- procedures in the run-time library (normally 5, but may be
3807 -- less for the configurable run-time case).
3811 or else
3813 or else
3815 Max_Available_String_Operands)
3818 loop
3823 -- Here we process the collected operands. First we convert
3824 -- singleton operands to singleton aggregates. This is skipped
3825 -- however for the case of two operands of type String, since
3826 -- we have special routines for these cases.
3832 or else not Char_Concat_Available
3833 then
3835 loop
3848 -- Now call appropriate continuation routine
3852 then
3854 else
3863 ------------------------
3864 -- Expand_N_Op_Divide --
3865 ------------------------
3873 begin
3876 -- N / 1 = N for integer types
3881 then
3886 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3887 -- Is_Power_Of_2_For_Shift is set means that we know that our left
3888 -- operand is an unsigned integer, as required for this to work.
3893 -- We cannot do this transformation in configurable run time mode if we
3894 -- have 64-bit -- integers and long shifts are not available.
3896 and then
3899 then
3903 Right_Opnd =>
3909 -- Do required fixup of universal fixed operation
3916 -- Divisions with fixed-point results
3920 -- No special processing if Treat_Fixed_As_Integer is set,
3921 -- since from a semantic point of view such operations are
3922 -- simply integer operations and will be treated that way.
3927 else
3932 -- Other cases of division of fixed-point operands. Again we
3933 -- exclude the case where Treat_Fixed_As_Integer is set.
3938 then
3941 else
3946 -- Mixed-mode operations can appear in a non-static universal
3947 -- context, in which case the integer argument must be converted
3948 -- explicitly.
3952 then
3960 then
3966 -- Non-fixed point cases, do integer zero divide and overflow checks
3971 -- Check for 64-bit division available
3974 and then not Support_64_Bit_Divides_On_Target
3975 then
3979 -- Deal with Vax_Float
3987 --------------------
3988 -- Expand_N_Op_Eq --
3989 --------------------
4004 -- If a constructed equality exists for the type or for its parent,
4005 -- build and analyze call, adding conversions if the operation is
4006 -- inherited.
4009 -- Determines whether a type has a subcompoment of an unconstrained
4010 -- Unchecked_Union subtype. Typ is a record type.
4012 -------------------------
4013 -- Build_Equality_Call --
4014 -------------------------
4021 begin
4024 then
4029 -- If we have an Unchecked_Union, we need to add the inferred
4030 -- discriminant values as actuals in the function call. At this
4031 -- point, the expansion has determined that both operands have
4032 -- inferable discriminants.
4035 declare
4041 begin
4042 -- Per-object constrained selected components require special
4043 -- attention. If the enclosing scope of the component is an
4044 -- Unchecked_Union, we cannot reference its discriminants
4045 -- directly. This is why we use the two extra parameters of
4046 -- the equality function of the enclosing Unchecked_Union.
4048 -- type UU_Type (Discr : Integer := 0) is
4049 -- . . .
4050 -- end record;
4051 -- pragma Unchecked_Union (UU_Type);
4053 -- 1. Unchecked_Union enclosing record:
4055 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
4056 -- . . .
4057 -- Comp : UU_Type (Discr);
4058 -- . . .
4059 -- end Enclosing_UU_Type;
4060 -- pragma Unchecked_Union (Enclosing_UU_Type);
4062 -- Obj1 : Enclosing_UU_Type;
4063 -- Obj2 : Enclosing_UU_Type (1);
4065 -- [. . .] Obj1 = Obj2 [. . .]
4067 -- Generated code:
4069 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4071 -- A and B are the formal parameters of the equality function
4072 -- of Enclosing_UU_Type. The function always has two extra
4073 -- formals to capture the inferred discriminant values.
4075 -- 2. Non-Unchecked_Union enclosing record:
4077 -- type
4078 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
4079 -- is record
4080 -- . . .
4081 -- Comp : UU_Type (Discr);
4082 -- . . .
4083 -- end Enclosing_Non_UU_Type;
4085 -- Obj1 : Enclosing_Non_UU_Type;
4086 -- Obj2 : Enclosing_Non_UU_Type (1);
4088 -- ... Obj1 = Obj2 ...
4090 -- Generated code:
4092 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
4093 -- obj1.discr, obj2.discr)) then
4095 -- In this case we can directly reference the discriminants of
4096 -- the enclosing record.
4098 -- Lhs of equality
4101 and then Has_Per_Object_Constraint
4103 then
4104 -- Enclosing record is an Unchecked_Union, use formal A
4108 then
4109 Lhs_Discr_Val :=
4113 -- Enclosing record is of a non-Unchecked_Union type, it is
4114 -- possible to reference the discriminant.
4116 else
4117 Lhs_Discr_Val :=
4120 Selector_Name =>
4121 New_Copy
4122 (Get_Discriminant_Value
4124 Lhs_Type,
4128 -- Comment needed here ???
4130 else
4131 -- Infer the discriminant value
4133 Lhs_Discr_Val :=
4134 New_Copy
4135 (Get_Discriminant_Value
4137 Lhs_Type,
4141 -- Rhs of equality
4144 and then Has_Per_Object_Constraint
4146 then
4147 if Is_Unchecked_Union
4149 then
4150 Rhs_Discr_Val :=
4154 else
4155 Rhs_Discr_Val :=
4158 Selector_Name =>
4161 Rhs_Type,
4165 else
4166 Rhs_Discr_Val :=
4169 Rhs_Type,
4178 L_Exp,
4179 R_Exp,
4180 Lhs_Discr_Val,
4181 Rhs_Discr_Val)));
4184 -- Normal case, not an unchecked union
4186 else
4196 ------------------------------------
4197 -- Has_Unconstrained_UU_Component --
4198 ------------------------------------
4200 function Has_Unconstrained_UU_Component
4202 is
4208 function Component_Is_Unconstrained_UU
4210 -- Determines whether the subtype of the component is an
4211 -- unconstrained Unchecked_Union.
4213 function Variant_Is_Unconstrained_UU
4215 -- Determines whether a component of the variant has an unconstrained
4216 -- Unchecked_Union subtype.
4218 -----------------------------------
4219 -- Component_Is_Unconstrained_UU --
4220 -----------------------------------
4222 function Component_Is_Unconstrained_UU
4224 is
4225 begin
4230 declare
4234 begin
4235 -- Unconstrained nominal type. In the case of a constraint
4236 -- present, the node kind would have been N_Subtype_Indication.
4246 ---------------------------------
4247 -- Variant_Is_Unconstrained_UU --
4248 ---------------------------------
4250 function Variant_Is_Unconstrained_UU
4252 is
4255 begin
4260 -- We only need to test one component
4262 declare
4265 begin
4275 -- None of the components withing the variant were of
4276 -- unconstrained Unchecked_Union type.
4281 -- Start of processing for Has_Unconstrained_UU_Component
4283 begin
4291 -- Inspect available components
4294 declare
4297 begin
4300 -- One component is sufficent
4311 -- Inspect available components withing variants
4314 declare
4317 begin
4320 -- One component within a variant is sufficent
4331 -- Neither the available components, nor the components inside the
4332 -- variant parts were of an unconstrained Unchecked_Union subtype.
4337 -- Start of processing for Expand_N_Op_Eq
4339 begin
4346 else
4350 -- It may happen in error situations that the underlying type is not
4351 -- set. The error will be detected later, here we just defend the
4352 -- expander code.
4360 -- Boolean types (requiring handling of non-standard case)
4368 -- Array types
4372 -- If we are doing full validity checking, then expand out array
4373 -- comparisons to make sure that we check the array elements.
4376 declare
4378 Force_Validity_Checks;
4379 begin
4382 Expand_Array_Equality
4386 Bodies,
4387 Typl));
4393 -- Packed case where both operands are known aligned
4398 then
4401 -- Where the component type is elementary we can use a block bit
4402 -- comparison (if supported on the target) exception in the case
4403 -- of floating-point (negative zero issues require element by
4404 -- element comparison), and atomic types (where we must be sure
4405 -- to load elements independently) and possibly unaligned arrays.
4412 and then Support_Composite_Compare_On_Target
4413 then
4416 -- For composite and floating-point cases, expand equality loop
4417 -- to make sure of using proper comparisons for tagged types,
4418 -- and correctly handling the floating-point case.
4420 else
4422 Expand_Array_Equality
4426 Bodies,
4427 Typl));
4432 -- Record Types
4436 -- For tagged types, use the primitive "="
4440 -- If this is derived from an untagged private type completed
4441 -- with a tagged type, it does not have a full view, so we
4442 -- use the primitive operations of the private type.
4443 -- This check should no longer be necessary when these
4444 -- types receive their full views ???
4450 then
4451 -- Search for equality operation, checking that the
4452 -- operands have the same type. Note that we must find
4453 -- a matching entry, or something is very wrong!
4461 and then
4470 -- Find the type's predefined equality or an overriding
4471 -- user-defined equality. The reason for not simply calling
4472 -- Find_Prim_Op here is that there may be a user-defined
4473 -- overloaded equality op that precedes the equality that
4474 -- we want, so we have to explicitly search (e.g., there
4475 -- could be an equality with two different parameter types).
4477 else
4487 and then
4499 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
4500 -- predefined equality operator for a type which has a subcomponent
4501 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
4508 -- Prevent Gigi from generating incorrect code by rewriting the
4509 -- equality as a standard False.
4516 -- If we can infer the discriminants of the operands, we make a
4517 -- call to the TSS equality function.
4520 and then
4522 then
4523 Build_Equality_Call
4526 else
4527 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4528 -- the predefined equality operator for an Unchecked_Union type
4529 -- if either of the operands lack inferable discriminants.
4535 -- Prevent Gigi from generating incorrect code by rewriting
4536 -- the equality as a standard False.
4543 -- If a type support function is present (for complex cases), use it
4546 Build_Equality_Call
4549 -- Otherwise expand the component by component equality. Note that
4550 -- we never use block-bit coparisons for records, because of the
4551 -- problems with gaps. The backend will often be able to recombine
4552 -- the separate comparisons that we generate here.
4554 else
4565 -- Test if result is known at compile time
4569 -- If we still have comparison for Vax_Float, process it
4577 -----------------------
4578 -- Expand_N_Op_Expon --
4579 -----------------------
4597 begin
4600 -- If either operand is of a private type, then we have the use of
4601 -- an intrinsic operator, and we get rid of the privateness, by using
4602 -- root types of underlying types for the actual operation. Otherwise
4603 -- the private types will cause trouble if we expand multiplications
4604 -- or shifts etc. We also do this transformation if the result type
4605 -- is different from the base type.
4608 or else
4610 or else
4612 or else
4614 then
4615 declare
4619 begin
4630 -- Test for case of known right argument
4635 -- We only fold small non-negative exponents. You might think we
4636 -- could fold small negative exponents for the real case, but we
4637 -- can't because we are required to raise Constraint_Error for
4638 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
4639 -- See ACVC test C4A012B.
4643 -- X ** 0 = 1 (or 1.0)
4648 else
4652 -- X ** 1 = X
4657 -- X ** 2 = X * X
4660 Xnode :=
4665 -- X ** 3 = X * X * X
4668 Xnode :=
4670 Left_Opnd =>
4676 -- X ** 4 ->
4677 -- En : constant base'type := base * base;
4678 -- ...
4679 -- En * En
4682 Temp :=
4690 Expression =>
4695 Xnode :=
4707 -- Case of (2 ** expression) appearing as an argument of an integer
4708 -- multiplication, or as the right argument of a division of a non-
4709 -- negative integer. In such cases we leave the node untouched, setting
4710 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
4711 -- of the higher level node converts it into a shift.
4718 and then not Ovflo
4720 then
4721 declare
4726 begin
4728 and then
4730 or else
4734 or else
4740 then
4747 -- Fall through if exponentiation must be done using a runtime routine
4749 -- First deal with modular case
4753 -- Non-binary case, we call the special exponentiation routine for
4754 -- the non-binary case, converting the argument to Long_Long_Integer
4755 -- and passing the modulus value. Then the result is converted back
4756 -- to the base type.
4766 Exp))));
4768 -- Binary case, in this case, we call one of two routines, either
4769 -- the unsigned integer case, or the unsigned long long integer
4770 -- case, with a final "and" operation to do the required mod.
4772 else
4775 else
4782 Left_Opnd =>
4787 Exp)),
4788 Right_Opnd =>
4793 -- Common exit point for modular type case
4798 -- Signed integer cases, done using either Integer or Long_Long_Integer.
4799 -- It is not worth having routines for Short_[Short_]Integer, since for
4800 -- most machines it would not help, and it would generate more code that
4801 -- might need certification in the HI-E case.
4803 -- In the integer cases, we have two routines, one for when overflow
4804 -- checks are required, and one when they are not required, since
4805 -- there is a real gain in ommitting checks on many machines.
4809 and then
4812 then
4817 else
4826 else
4830 -- Floating-point cases, always done using Long_Long_Float. We do not
4831 -- need separate routines for the overflow case here, since in the case
4832 -- of floating-point, we generate infinities anyway as a rule (either
4833 -- that or we automatically trap overflow), and if there is an infinity
4834 -- generated and a range check is required, the check will fail anyway.
4836 else
4842 -- Common processing for integer cases and floating-point cases.
4843 -- If we are in the right type, we can call runtime routine directly
4848 then
4854 -- Otherwise we have to introduce conversions (conversions are also
4855 -- required in the universal cases, since the runtime routine is
4856 -- typed using one of the standard types.
4858 else
4865 Exp))));
4871 exception
4876 --------------------
4877 -- Expand_N_Op_Ge --
4878 --------------------
4886 begin
4903 -- If we still have comparison, and Vax_Float type, process it
4911 --------------------
4912 -- Expand_N_Op_Gt --
4913 --------------------
4921 begin
4938 -- If we still have comparison, and Vax_Float type, process it
4946 --------------------
4947 -- Expand_N_Op_Le --
4948 --------------------
4956 begin
4973 -- If we still have comparison, and Vax_Float type, process it
4981 --------------------
4982 -- Expand_N_Op_Lt --
4983 --------------------
4991 begin
5008 -- If we still have comparison, and Vax_Float type, process it
5016 -----------------------
5017 -- Expand_N_Op_Minus --
5018 -----------------------
5024 begin
5027 if not Backend_Overflow_Checks_On_Target
5030 then
5031 -- Software overflow checking expands -expr into (0 - expr)
5040 -- Vax floating-point types case
5047 ---------------------
5048 -- Expand_N_Op_Mod --
5049 ---------------------
5067 begin
5073 -- Convert mod to rem if operands are known non-negative. We do this
5074 -- since it is quite likely that this will improve the quality of code,
5075 -- (the operation now corresponds to the hardware remainder), and it
5076 -- does not seem likely that it could be harmful.
5079 and then
5081 then
5087 -- Instead of reanalyzing the node we do the analysis manually.
5088 -- This avoids anomalies when the replacement is done in an
5089 -- instance and is epsilon more efficient.
5098 -- Otherwise, normal mod processing
5100 else
5105 -- Apply optimization x mod 1 = 0. We don't really need that with
5106 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5107 -- certainly harmless.
5112 then
5118 -- Deal with annoying case of largest negative number remainder
5119 -- minus one. Gigi does not handle this case correctly, because
5120 -- it generates a divide instruction which may trap in this case.
5122 -- In fact the check is quite easy, if the right operand is -1,
5123 -- then the mod value is always 0, and we can just ignore the
5124 -- left operand completely in this case.
5126 -- The operand type may be private (e.g. in the expansion of an
5127 -- an intrinsic operation) so we must use the underlying type to
5128 -- get the bounds, and convert the literals explicitly.
5130 LLB :=
5131 Expr_Value
5135 and then
5137 then
5143 Right_Opnd =>
5156 --------------------------
5157 -- Expand_N_Op_Multiply --
5158 --------------------------
5177 begin
5180 -- Special optimizations for integer types
5184 -- N * 0 = 0 * N = 0 for integer types
5188 or else
5191 then
5197 -- N * 1 = 1 * N = N for integer types
5199 -- This optimisation is not done if we are going to
5200 -- rewrite the product 1 * 2 ** N to a shift.
5204 and then not Lp2
5205 then
5211 and then not Rp2
5212 then
5218 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5219 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5220 -- operand is an integer, as required for this to work.
5225 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
5230 Right_Opnd =>
5237 else
5241 Right_Opnd =>
5247 -- Same processing for the operands the other way round
5253 Right_Opnd =>
5259 -- Do required fixup of universal fixed operation
5266 -- Multiplications with fixed-point results
5270 -- No special processing if Treat_Fixed_As_Integer is set,
5271 -- since from a semantic point of view such operations are
5272 -- simply integer operations and will be treated that way.
5276 -- Case of fixed * integer => fixed
5281 -- Case of integer * fixed => fixed
5286 -- Case of fixed * fixed => fixed
5288 else
5293 -- Other cases of multiplication of fixed-point operands. Again
5294 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
5298 then
5301 else
5306 -- Mixed-mode operations can appear in a non-static universal
5307 -- context, in which case the integer argument must be converted
5308 -- explicitly.
5312 then
5319 then
5324 -- Non-fixed point cases, check software overflow checking required
5329 -- Deal with VAX float case
5337 --------------------
5338 -- Expand_N_Op_Ne --
5339 --------------------
5344 begin
5345 -- Case of elementary type with standard operator
5349 then
5352 -- Boolean types (requiring handling of non-standard case)
5363 -- If we still have comparison for Vax_Float, process it
5370 -- For all cases other than elementary types, we rewrite node as the
5371 -- negation of an equality operation, and reanalyze. The equality to be
5372 -- used is defined in the same scope and has the same signature. This
5373 -- signature must be set explicitly since in an instance it may not have
5374 -- the same visibility as in the generic unit. This avoids duplicating
5375 -- or factoring the complex code for record/array equality tests etc.
5377 else
5378 declare
5383 begin
5386 Neg :=
5388 Right_Opnd =>
5398 -- For navigation purposes, the inequality is treated as an
5399 -- implicit reference to the corresponding equality. Preserve the
5400 -- Comes_From_ source flag so that the proper Xref entry is
5401 -- generated.
5411 ---------------------
5412 -- Expand_N_Op_Not --
5413 ---------------------
5415 -- If the argument is other than a Boolean array type, there is no
5416 -- special expansion required.
5418 -- For the packed case, we call the special routine in Exp_Pakd, except
5419 -- that if the component size is greater than one, we use the standard
5420 -- routine generating a gruesome loop (it is so peculiar to have packed
5421 -- arrays with non-standard Boolean representations anyway, so it does
5422 -- not matter that we do not handle this case efficiently).
5424 -- For the unpacked case (and for the special packed case where we have
5425 -- non standard Booleans, as discussed above), we generate and insert
5426 -- into the tree the following function definition:
5428 -- function Nnnn (A : arr) is
5429 -- B : arr;
5430 -- begin
5431 -- for J in a'range loop
5432 -- B (J) := not A (J);
5433 -- end loop;
5434 -- return B;
5435 -- end Nnnn;
5437 -- Here arr is the actual subtype of the parameter (and hence always
5438 -- constrained). Then we replace the not with a call to this function.
5454 begin
5457 -- For boolean operand, deal with non-standard booleans
5466 -- Only array types need any other processing
5472 -- Case of array operand. If bit packed with a component size of 1,
5473 -- handle it in Exp_Pakd if the operand is known to be aligned.
5478 then
5483 -- Case of array operand which is not bit-packed. If the context is
5484 -- a safe assignment, call in-place operation, If context is a larger
5485 -- boolean expression in the context of a safe assignment, expansion is
5486 -- done by enclosing operation.
5498 -- Special case the negation of a binary operation
5503 and then Safe_In_Place_Array_Op
5505 then
5512 then
5513 declare
5518 begin
5522 then
5523 -- (not A) op (not B) can be reduced to a single call
5529 then
5530 -- A xor (not B) can also be special-cased
5542 A_J :=
5547 B_J :=
5552 Loop_Statement :=
5556 Iteration_Scheme =>
5558 Loop_Parameter_Specification =>
5561 Discrete_Subtype_Definition =>
5576 Specification =>
5590 Handled_Statement_Sequence =>
5593 Loop_Statement,
5595 Expression =>
5606 --------------------
5607 -- Expand_N_Op_Or --
5608 --------------------
5613 begin
5627 ----------------------
5628 -- Expand_N_Op_Plus --
5629 ----------------------
5632 begin
5636 ---------------------
5637 -- Expand_N_Op_Rem --
5638 ---------------------
5655 begin
5662 -- Apply optimization x rem 1 = 0. We don't really need that with
5663 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5664 -- certainly harmless.
5669 then
5675 -- Deal with annoying case of largest negative number remainder
5676 -- minus one. Gigi does not handle this case correctly, because
5677 -- it generates a divide instruction which may trap in this case.
5679 -- In fact the check is quite easy, if the right operand is -1,
5680 -- then the remainder is always 0, and we can just ignore the
5681 -- left operand completely in this case.
5686 -- The operand type may be private (e.g. in the expansion of an
5687 -- an intrinsic operation) so we must use the underlying type to
5688 -- get the bounds, and convert the literals explicitly.
5690 LLB :=
5691 Expr_Value
5694 -- Now perform the test, generating code only if needed
5697 and then
5699 then
5705 Right_Opnd =>
5719 -----------------------------
5720 -- Expand_N_Op_Rotate_Left --
5721 -----------------------------
5724 begin
5728 ------------------------------
5729 -- Expand_N_Op_Rotate_Right --
5730 ------------------------------
5733 begin
5737 ----------------------------
5738 -- Expand_N_Op_Shift_Left --
5739 ----------------------------
5742 begin
5746 -----------------------------
5747 -- Expand_N_Op_Shift_Right --
5748 -----------------------------
5751 begin
5755 ----------------------------------------
5756 -- Expand_N_Op_Shift_Right_Arithmetic --
5757 ----------------------------------------
5760 begin
5764 --------------------------
5765 -- Expand_N_Op_Subtract --
5766 --------------------------
5771 begin
5774 -- N - 0 = N for integer types
5779 then
5784 -- Arithemtic overflow checks for signed integer/fixed point types
5788 then
5791 -- Vax floating-point types case
5798 ---------------------
5799 -- Expand_N_Op_Xor --
5800 ---------------------
5805 begin
5819 ----------------------
5820 -- Expand_N_Or_Else --
5821 ----------------------
5823 -- Expand into conditional expression if Actions present, and also
5824 -- deal with optimizing case of arguments being True or False.
5833 begin
5834 -- Deal with non-standard booleans
5842 -- Check for cases of left argument is True or False
5846 -- If left argument is False, change (False or else Right) to Right.
5847 -- Any actions associated with Right will be executed unconditionally
5848 -- and can thus be inserted into the tree unconditionally.
5859 -- If left argument is True, change (True and then Right) to
5860 -- True. In this case we can forget the actions associated with
5861 -- Right, since they will never be executed.
5872 -- If Actions are present, we expand
5874 -- left or else right
5876 -- into
5878 -- if left then True else right end
5880 -- with the actions becoming the Else_Actions of the conditional
5881 -- expression. This conditional expression is then further expanded
5882 -- (and will eventually disappear)
5889 Left,
5891 Right)));
5899 -- No actions present, check for cases of right argument True/False
5903 -- Change (Left or else False) to Left. Note that we know there
5904 -- are no actions associated with the True operand, since we
5905 -- just checked for this case above.
5910 -- Change (Left or else True) to True, making sure to preserve
5911 -- any side effects associated with the Left operand.
5915 Rewrite
5923 -----------------------------------
5924 -- Expand_N_Qualified_Expression --
5925 -----------------------------------
5931 begin
5935 ---------------------------------
5936 -- Expand_N_Selected_Component --
5937 ---------------------------------
5939 -- If the selector is a discriminant of a concurrent object, rewrite the
5940 -- prefix to denote the corresponding record type.
5952 -- Gigi needs a temporary for prefixes that depend on a discriminant,
5953 -- unless the context of an assignment can provide size information.
5954 -- Don't we have a general routine that does this???
5956 -----------------------
5957 -- In_Left_Hand_Side --
5958 -----------------------
5961 begin
5969 -- Start of processing for Expand_N_Selected_Component
5971 begin
5972 -- Insert explicit dereference if required
5980 then
5987 -- Deal with discriminant check required
5991 -- Present the discrminant checking function to the backend,
5992 -- so that it can inline the call to the function.
5994 Add_Inlined_Body
5995 (Discriminant_Checking_Func
5998 -- Now reset the flag and generate the call
6004 -- Gigi cannot handle unchecked conversions that are the prefix of a
6005 -- selected component with discriminants. This must be checked during
6006 -- expansion, because during analysis the type of the selector is not
6007 -- known at the point the prefix is analyzed. If the conversion is the
6008 -- target of an assignment, then we cannot force the evaluation.
6013 then
6017 -- Remaining processing applies only if selector is a discriminant
6021 -- If the selector is a discriminant of a constrained record type,
6022 -- we may be able to rewrite the expression with the actual value
6023 -- of the discriminant, a useful optimization in some cases.
6028 then
6029 -- Do this optimization for discrete types only, and not for
6030 -- access types (access discriminants get us into trouble!)
6035 -- Don't do this on the left hand of an assignment statement.
6036 -- Normally one would think that references like this would
6037 -- not occur, but they do in generated code, and mean that
6038 -- we really do want to assign the discriminant!
6042 then
6045 -- Don't do this optimization for the prefix of an attribute
6046 -- or the operand of an object renaming declaration since these
6047 -- are contexts where we do not want the value anyway.
6052 then
6055 -- Don't do this optimization if we are within the code for a
6056 -- discriminant check, since the whole point of such a check may
6057 -- be to verify the condition on which the code below depends!
6062 -- Green light to see if we can do the optimization. There is
6063 -- still one condition that inhibits the optimization below
6064 -- but now is the time to check the particular discriminant.
6066 else
6067 -- Loop through discriminants to find the matching
6068 -- discriminant constraint to see if we can copy it.
6074 -- Check if this is the matching discriminant
6078 -- Here we have the matching discriminant. Check for
6079 -- the case of a discriminant of a component that is
6080 -- constrained by an outer discriminant, which cannot
6081 -- be optimized away.
6083 if
6084 Denotes_Discriminant
6086 then
6089 -- In the context of a case statement, the expression
6090 -- may have the base type of the discriminant, and we
6091 -- need to preserve the constraint to avoid spurious
6092 -- errors on missing cases.
6096 then
6099 Subtype_Mark =>
6101 Expression =>
6105 -- In case that comes out as a static expression,
6106 -- reset it (a selected component is never static).
6111 -- Otherwise we can just copy the constraint, but the
6112 -- result is certainly not static! In some cases the
6113 -- discriminant constraint has been analyzed in the
6114 -- context of the original subtype indication, but for
6115 -- itypes the constraint might not have been analyzed
6116 -- yet, and this must be done now.
6118 else
6130 -- Note: the above loop should always find a matching
6131 -- discriminant, but if it does not, we just missed an
6132 -- optimization due to some glitch (perhaps a previous
6133 -- error), so ignore.
6138 -- The only remaining processing is in the case of a discriminant of
6139 -- a concurrent object, where we rewrite the prefix to denote the
6140 -- corresponding record type. If the type is derived and has renamed
6141 -- discriminants, use corresponding discriminant, which is the one
6142 -- that appears in the corresponding record.
6152 then
6156 New_N :=
6158 Prefix =>
6168 --------------------
6169 -- Expand_N_Slice --
6170 --------------------
6179 -- Check whether the argument is an actual for a procedure call,
6180 -- in which case the expansion of a bit-packed slice is deferred
6181 -- until the call itself is expanded. The reason this is required
6182 -- is that we might have an IN OUT or OUT parameter, and the copy out
6183 -- is essential, and that copy out would be missed if we created a
6184 -- temporary here in Expand_N_Slice. Note that we don't bother
6185 -- to test specifically for an IN OUT or OUT mode parameter, since it
6186 -- is a bit tricky to do, and it is harmless to defer expansion
6187 -- in the IN case, since the call processing will still generate the
6188 -- appropriate copy in operation, which will take care of the slice.
6191 -- Create a named variable for the value of the slice, in
6192 -- cases where the back-end cannot handle it properly, e.g.
6193 -- when packed types or unaligned slices are involved.
6195 -------------------------
6196 -- Is_Procedure_Actual --
6197 -------------------------
6202 begin
6203 loop
6204 -- If our parent is a procedure call we can return
6209 -- If our parent is a type conversion, keep climbing the
6210 -- tree, since a type conversion can be a procedure actual.
6211 -- Also keep climbing if parameter association or a qualified
6212 -- expression, since these are additional cases that do can
6213 -- appear on procedure actuals.
6218 then
6221 -- Any other case is not what we are looking for
6223 else
6229 --------------------
6230 -- Make_Temporary --
6231 --------------------
6237 begin
6238 Decl :=
6246 Decl,
6255 -- Start of processing for Expand_N_Slice
6257 begin
6258 -- Special handling for access types
6271 -- Range checks are potentially also needed for cases involving
6272 -- a slice indexed by a subtype indication, but Do_Range_Check
6273 -- can currently only be set for expressions ???
6279 then
6283 -- The remaining case to be handled is packed slices. We can leave
6284 -- packed slices as they are in the following situations:
6286 -- 1. Right or left side of an assignment (we can handle this
6287 -- situation correctly in the assignment statement expansion).
6289 -- 2. Prefix of indexed component (the slide is optimized away
6290 -- in this case, see the start of Expand_N_Slice.
6292 -- 3. Object renaming declaration, since we want the name of
6293 -- the slice, not the value.
6295 -- 4. Argument to procedure call, since copy-in/copy-out handling
6296 -- may be required, and this is handled in the expansion of
6297 -- call itself.
6299 -- 5. Prefix of an address attribute (this is an error which
6300 -- is caught elsewhere, and the expansion would intefere
6301 -- with generating the error message).
6305 -- Apply transformation for actuals of a function call,
6306 -- where Expand_Actuals is not used.
6310 then
6311 Make_Temporary;
6317 then
6323 then
6328 then
6331 else
6332 Make_Temporary;
6336 ------------------------------
6337 -- Expand_N_Type_Conversion --
6338 ------------------------------
6347 -- This is called in the case of record and array type conversions
6348 -- to see if there is a change of representation to be handled.
6349 -- Change of representation is actually handled at the assignment
6350 -- statement level, and what this procedure does is rewrite node N
6351 -- conversion as an assignment to temporary. If there is no change
6352 -- of representation, then the conversion node is unchanged.
6355 -- Handles generation of range check for real target value
6357 -----------------------------------
6358 -- Handle_Changed_Representation --
6359 -----------------------------------
6369 begin
6370 -- Nothing to do if no change of representation
6375 -- The real change of representation work is done by the assignment
6376 -- statement processing. So if this type conversion is appearing as
6377 -- the expression of an assignment statement, nothing needs to be
6378 -- done to the conversion.
6383 -- Otherwise we need to generate a temporary variable, and do the
6384 -- change of representation assignment into that temporary variable.
6385 -- The conversion is then replaced by a reference to this variable.
6387 else
6390 -- If type is unconstrained we have to add a constraint,
6391 -- copied from the actual value of the left hand side.
6406 Selector_Name =>
6417 -- We convert the bounds explicitly. We use an unchecked
6418 -- conversion because bounds checks are done elsewhere.
6422 Low_Bound =>
6425 Prefix =>
6426 Duplicate_Subexpr_No_Checks
6432 High_Bound =>
6435 Prefix =>
6436 Duplicate_Subexpr_No_Checks
6450 Odef :=
6453 Constraint =>
6459 Decl :=
6466 -- Insert required actions. It is essential to suppress checks
6467 -- since we have suppressed default initialization, which means
6468 -- that the variable we create may have no discriminants.
6471 New_List (
6472 Decl,
6483 ----------------------
6484 -- Real_Range_Check --
6485 ----------------------
6487 -- Case of conversions to floating-point or fixed-point. If range
6488 -- checks are enabled and the target type has a range constraint,
6489 -- we convert:
6491 -- typ (x)
6493 -- to
6495 -- Tnn : typ'Base := typ'Base (x);
6496 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
6497 -- Tnn
6499 -- This is necessary when there is a conversion of integer to float
6500 -- or to fixed-point to ensure that the correct checks are made. It
6501 -- is not necessary for float to float where it is enough to simply
6502 -- set the Do_Range_Check flag.
6512 begin
6513 -- Nothing to do if conversion was rewritten
6519 -- Nothing to do if range checks suppressed, or target has the
6520 -- same range as the base type (or is the base type).
6524 and then
6526 then
6530 -- Nothing to do if expression is an entity on which checks
6531 -- have been suppressed.
6535 then
6539 -- Nothing to do if bounds are all static and we can tell that
6540 -- the expression is within the bounds of the target. Note that
6541 -- if the operand is of an unconstrained floating-point type,
6542 -- then we do not trust it to be in range (might be infinite)
6544 declare
6548 begin
6555 then
6556 declare
6562 begin
6566 else
6574 then
6582 -- For float to float conversions, we are done
6585 and then
6587 then
6591 -- Otherwise rewrite the conversion as described above
6594 Rewrite
6598 -- Enable overflow except for case of integer to float conversions,
6599 -- where it is never required, since we can never have overflow in
6600 -- this case.
6606 Tnn :=
6617 Condition =>
6619 Left_Opnd =>
6622 Right_Opnd =>
6625 Prefix =>
6628 Right_Opnd =>
6631 Right_Opnd =>
6634 Prefix =>
6642 -- Start of processing for Expand_N_Type_Conversion
6644 begin
6645 -- Nothing at all to do if conversion is to the identical type
6646 -- so remove the conversion completely, it is useless.
6653 -- Nothing to do if this is the second argument of read. This
6654 -- is a "backwards" conversion that will be handled by the
6655 -- specialized code in attribute processing.
6660 then
6664 -- Here if we may need to expand conversion
6666 -- Special case of converting from non-standard boolean type
6670 then
6676 -- Case of converting to an access type
6680 -- Apply an accessibility check if the operand is an
6681 -- access parameter. Note that other checks may still
6682 -- need to be applied below (such as tagged type checks).
6687 then
6690 -- If the level of the operand type is statically deeper
6691 -- then the level of the target type, then force Program_Error.
6692 -- Note that this can only occur for cases where the attribute
6693 -- is within the body of an instantiation (otherwise the
6694 -- conversion will already have been rejected as illegal).
6695 -- Note: warnings are issued by the analyzer for the instance
6696 -- cases.
6698 elsif In_Instance_Body
6701 then
6707 -- When the operand is a selected access discriminant
6708 -- the check needs to be made against the level of the
6709 -- object denoted by the prefix of the selected name.
6710 -- Force Program_Error for this case as well (this
6711 -- accessibility violation can only happen if within
6712 -- the body of an instantiation).
6714 elsif In_Instance_Body
6719 then
6727 -- Case of conversions of tagged types and access to tagged types
6729 -- When needed, that is to say when the expression is class-wide,
6730 -- Add runtime a tag check for (strict) downward conversion by using
6731 -- the membership test, generating:
6733 -- [constraint_error when Operand not in Target_Type'Class]
6735 -- or in the access type case
6737 -- [constraint_error
6738 -- when Operand /= null
6739 -- and then Operand.all not in
6740 -- Designated_Type (Target_Type)'Class]
6745 then
6746 -- Do not do any expansion in the access type case if the
6747 -- parent is a renaming, since this is an error situation
6748 -- which will be caught by Sem_Ch8, and the expansion can
6749 -- intefere with this error check.
6753 then
6757 -- Oherwise, proceed with processing tagged conversion
6759 declare
6765 begin
6770 else
6777 and then Is_Ancestor
6779 Actual_Target_Type)
6781 then
6782 -- The conversion is valid for any descendant of the
6783 -- target type
6788 Cond :=
6790 Left_Opnd =>
6795 Right_Opnd =>
6797 Left_Opnd =>
6799 Prefix =>
6801 Right_Opnd =>
6804 else
6805 Cond :=
6808 Right_Opnd =>
6817 declare
6819 begin
6820 Conv :=
6830 -- Case of other access type conversions
6835 -- Case of conversions from a fixed-point type
6837 -- These conversions require special expansion and processing, found
6838 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
6839 -- set, since from a semantic point of view, these are simple integer
6840 -- conversions, which do not need further processing.
6844 then
6845 -- We should never see universal fixed at this case, since the
6846 -- expansion of the constituent divide or multiply should have
6847 -- eliminated the explicit mention of universal fixed.
6851 -- Check for special case of the conversion to universal real
6852 -- that occurs as a result of the use of a round attribute.
6853 -- In this case, the real type for the conversion is taken
6854 -- from the target type of the Round attribute and the
6855 -- result must be marked as rounded.
6860 then
6865 -- Otherwise do correct fixed-conversion, but skip these if the
6866 -- Conversion_OK flag is set, because from a semantic point of
6867 -- view these are simple integer conversions needing no further
6868 -- processing (the backend will simply treat them as integers)
6873 Real_Range_Check;
6878 else
6881 Real_Range_Check;
6885 -- Case of conversions to a fixed-point type
6887 -- These conversions require special expansion and processing, found
6888 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6889 -- is set, since from a semantic point of view, these are simple
6890 -- integer conversions, which do not need further processing.
6894 then
6897 Real_Range_Check;
6898 else
6901 Real_Range_Check;
6904 -- Case of float-to-integer conversions
6906 -- We also handle float-to-fixed conversions with Conversion_OK set
6907 -- since semantically the fixed-point target is treated as though it
6908 -- were an integer in such cases.
6911 and then
6913 or else
6915 then
6916 -- Special processing required if the conversion is the expression
6917 -- of a Truncation attribute reference. In this case we replace:
6919 -- ityp (ftyp'Truncation (x))
6921 -- by
6923 -- ityp (x)
6925 -- with the Float_Truncate flag set. This is clearly more efficient
6929 then
6935 -- One more check here, gcc is still not able to do conversions of
6936 -- this type with proper overflow checking, and so gigi is doing an
6937 -- approximation of what is required by doing floating-point compares
6938 -- with the end-point. But that can lose precision in some cases, and
6939 -- give a wrong result. Converting the operand to Universal_Real is
6940 -- helpful, but still does not catch all cases with 64-bit integers
6941 -- on targets with only 64-bit floats ???
6946 Subtype_Mark =>
6948 Expression =>
6956 -- Case of array conversions
6958 -- Expansion of array conversions, add required length/range checks
6959 -- but only do this if there is no change of representation. For
6960 -- handling of this case, see Handle_Changed_Representation.
6966 else
6970 Handle_Changed_Representation;
6972 -- Case of conversions of discriminated types
6974 -- Add required discriminant checks if target is constrained. Again
6975 -- this change is skipped if we have a change of representation.
6979 then
6981 Handle_Changed_Representation;
6983 -- Case of all other record conversions. The only processing required
6984 -- is to check for a change of representation requiring the special
6985 -- assignment processing.
6989 -- Ada 2005 (AI-216): Program_Error is raised when converting from
6990 -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
6991 -- Union type if the operand lacks inferable discriminants.
6998 then
6999 -- To prevent Gigi from generating illegal code, we make a
7000 -- Program_Error node, but we give it the target type of the
7001 -- conversion.
7003 declare
7007 begin
7012 else
7013 Handle_Changed_Representation;
7016 -- Case of conversions of enumeration types
7020 -- Special processing is required if there is a change of
7021 -- representation (from enumeration representation clauses)
7025 -- Convert: x(y) to x'val (ytyp'val (y))
7040 -- Case of conversions to floating-point
7043 Real_Range_Check;
7046 -- At this stage, either the conversion node has been transformed
7047 -- into some other equivalent expression, or left as a conversion
7048 -- that can be handled by Gigi. The conversions that Gigi can handle
7049 -- are the following:
7051 -- Conversions with no change of representation or type
7053 -- Numeric conversions involving integer values, floating-point
7054 -- values, and fixed-point values. Fixed-point values are allowed
7055 -- only if Conversion_OK is set, i.e. if the fixed-point values
7056 -- are to be treated as integers.
7058 -- No other conversions should be passed to Gigi
7060 -- Check: are these rules stated in sinfo??? if so, why restate here???
7062 -- The only remaining step is to generate a range check if we still
7063 -- have a type conversion at this stage and Do_Range_Check is set.
7064 -- For now we do this only for conversions of discrete types.
7068 then
7069 declare
7074 begin
7077 then
7080 -- Before we do a range check, we have to deal with treating
7081 -- a fixed-point operand as an integer. The way we do this
7082 -- is simply to do an unchecked conversion to an appropriate
7083 -- integer type large enough to hold the result.
7085 -- This code is not active yet, because we are only dealing
7086 -- with discrete types so far ???
7090 then
7095 else
7102 -- Reset overflow flag, since the range check will include
7103 -- dealing with possible overflow, and generate the check
7104 -- If Address is either source or target type, suppress
7105 -- range check to avoid typing anomalies when it is a visible
7106 -- integer type.
7111 then
7112 Generate_Range_Check
7119 -- Final step, if the result is a type conversion involving Vax_Float
7120 -- types, then it is subject for further special processing.
7124 then
7130 -----------------------------------
7131 -- Expand_N_Unchecked_Expression --
7132 -----------------------------------
7134 -- Remove the unchecked expression node from the tree. It's job was simply
7135 -- to make sure that its constituent expression was handled with checks
7136 -- off, and now that that is done, we can remove it from the tree, and
7137 -- indeed must, since gigi does not expect to see these nodes.
7142 begin
7147 ----------------------------------------
7148 -- Expand_N_Unchecked_Type_Conversion --
7149 ----------------------------------------
7151 -- If this cannot be handled by Gigi and we haven't already made
7152 -- a temporary for it, do it now.
7159 begin
7160 -- If we have a conversion of a compile time known value to a target
7161 -- type and the value is in range of the target type, then we can simply
7162 -- replace the construct by an integer literal of the correct type. We
7163 -- only apply this to integer types being converted. Possibly it may
7164 -- apply in other cases, but it is too much trouble to worry about.
7166 -- Note that we do not do this transformation if the Kill_Range_Check
7167 -- flag is set, since then the value may be outside the expected range.
7168 -- This happens in the Normalize_Scalars case.
7174 then
7175 declare
7178 begin
7180 and then
7182 and then
7184 and then
7186 then
7189 -- If Address is the target type, just set the type
7190 -- to avoid a spurious type error on the literal when
7191 -- Address is a visible integer type.
7195 else
7204 -- Nothing to do if conversion is safe
7210 -- Otherwise force evaluation unless Assignment_OK flag is set (this
7211 -- flag indicates ??? -- more comments needed here)
7215 else
7220 ----------------------------
7221 -- Expand_Record_Equality --
7222 ----------------------------
7224 -- For non-variant records, Equality is expanded when needed into:
7226 -- and then Lhs.Discr1 = Rhs.Discr1
7227 -- and then ...
7228 -- and then Lhs.Discrn = Rhs.Discrn
7229 -- and then Lhs.Cmp1 = Rhs.Cmp1
7230 -- and then ...
7231 -- and then Lhs.Cmpn = Rhs.Cmpn
7233 -- The expression is folded by the back-end for adjacent fields. This
7234 -- function is called for tagged record in only one occasion: for imple-
7235 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
7236 -- otherwise the primitive "=" is used directly.
7238 function Expand_Record_Equality
7244 is
7253 -- Return the first field to compare beginning with C, skipping the
7254 -- inherited components.
7256 ----------------------
7257 -- Suitable_Element --
7258 ----------------------
7261 begin
7267 then
7272 then
7277 then
7280 else
7285 -- Start of processing for Expand_Record_Equality
7287 begin
7288 -- Generates the following code: (assuming that Typ has one Discr and
7289 -- component C2 is also a record)
7291 -- True
7292 -- and then Lhs.Discr1 = Rhs.Discr1
7293 -- and then Lhs.C1 = Rhs.C1
7294 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
7295 -- and then ...
7296 -- and then Lhs.Cmpn = Rhs.Cmpn
7302 declare
7307 begin
7312 else
7317 Check :=
7319 Lhs =>
7323 Rhs =>
7329 -- If some (sub)component is an unchecked_union, the whole
7330 -- operation will raise program error.
7336 else
7337 Result :=
7350 -------------------------------------
7351 -- Fixup_Universal_Fixed_Operation --
7352 -------------------------------------
7357 begin
7358 -- We must have a type conversion immediately above us
7362 -- Normally the type conversion gives our target type. The exception
7363 -- occurs in the case of the Round attribute, where the conversion
7364 -- will be to universal real, and our real type comes from the Round
7365 -- attribute (as well as an indication that we must round the result)
7369 then
7373 -- Normal case where type comes from conversion above us
7375 else
7380 ------------------------------
7381 -- Get_Allocator_Final_List --
7382 ------------------------------
7384 function Get_Allocator_Final_List
7388 is
7392 -- The entity whose finalisation list must be used to attach the
7393 -- allocated object.
7395 begin
7398 in N_Subprogram_Specification
7399 then
7400 -- If the context is an access parameter, we need to create
7401 -- a non-anonymous access type in order to have a usable
7402 -- final list, because there is otherwise no pool to which
7403 -- the allocated object can belong. We create both the type
7404 -- and the finalization chain here, because freezing an
7405 -- internal type does not create such a chain. The Final_Chain
7406 -- that is thus created is shared by the access parameter.
7412 Type_Definition =>
7414 Subtype_Indication =>
7420 else
7421 -- Case of an access discriminant, or (Ada 2005) of
7422 -- an anonymous access component: find the final list
7423 -- associated with the scope of the type.
7432 ---------------------------------
7433 -- Has_Inferable_Discriminants --
7434 ---------------------------------
7439 -- Determines whether the left-most prefix of a selected component is a
7440 -- formal parameter in a subprogram. Assumes N is a selected component.
7442 --------------------------------
7443 -- Prefix_Is_Formal_Parameter --
7444 --------------------------------
7449 begin
7450 -- Move to the left-most prefix by climbing up the tree
7454 loop
7461 -- Start of processing for Has_Inferable_Discriminants
7463 begin
7464 -- For identifiers and indexed components, it is sufficent to have a
7465 -- constrained Unchecked_Union nominal subtype.
7468 or else
7470 then
7472 and then
7475 -- For selected components, the subtype of the selector must be a
7476 -- constrained Unchecked_Union. If the component is subject to a
7477 -- per-object constraint, then the enclosing object must have inferable
7478 -- discriminants.
7483 -- A small hack. If we have a per-object constrained selected
7484 -- component of a formal parameter, return True since we do not
7485 -- know the actual parameter association yet.
7491 -- Otherwise, check the enclosing object and the selector
7494 and then
7498 -- The call to Has_Inferable_Discriminants will determine whether
7499 -- the selector has a constrained Unchecked_Union nominal type.
7503 -- A qualified expression has inferable discriminants if its subtype
7504 -- mark is a constrained Unchecked_Union subtype.
7508 and then
7516 -------------------------------
7517 -- Insert_Dereference_Action --
7518 -------------------------------
7527 -- Return true if type of P is derived from Checked_Pool;
7529 -----------------------------
7530 -- Is_Checked_Storage_Pool --
7531 -----------------------------
7536 begin
7545 else
7553 -- Start of processing for Insert_Dereference_Action
7555 begin
7560 then
7571 -- Pool
7575 -- Storage_Address. We use the attribute Pool_Address,
7576 -- which uses the pointer itself to find the address of
7577 -- the object, and which handles unconstrained arrays
7578 -- properly by computing the address of the template.
7579 -- i.e. the correct address of the corresponding allocation.
7585 -- Size_In_Storage_Elements
7588 Left_Opnd =>
7590 Prefix =>
7594 Right_Opnd =>
7597 -- Alignment
7600 Prefix =>
7605 exception
7610 ------------------------------
7611 -- Make_Array_Comparison_Op --
7612 ------------------------------
7614 -- This is a hand-coded expansion of the following generic function:
7616 -- generic
7617 -- type elem is (<>);
7618 -- type index is (<>);
7619 -- type a is array (index range <>) of elem;
7620 --
7621 -- function Gnnn (X : a; Y: a) return boolean is
7622 -- J : index := Y'first;
7623 --
7624 -- begin
7625 -- if X'length = 0 then
7626 -- return false;
7627 --
7628 -- elsif Y'length = 0 then
7629 -- return true;
7630 --
7631 -- else
7632 -- for I in X'range loop
7633 -- if X (I) = Y (J) then
7634 -- if J = Y'last then
7635 -- exit;
7636 -- else
7637 -- J := index'succ (J);
7638 -- end if;
7639 --
7640 -- else
7641 -- return X (I) > Y (J);
7642 -- end if;
7643 -- end loop;
7644 --
7645 -- return X'length > Y'length;
7646 -- end if;
7647 -- end Gnnn;
7649 -- Note that since we are essentially doing this expansion by hand, we
7650 -- do not need to generate an actual or formal generic part, just the
7651 -- instantiated function itself.
7653 function Make_Array_Comparison_Op
7656 is
7677 begin
7678 -- if J = Y'last then
7679 -- exit;
7680 -- else
7681 -- J := index'succ (J);
7682 -- end if;
7684 Inner_If :=
7686 Condition =>
7689 Right_Opnd =>
7697 Else_Statements =>
7698 New_List (
7701 Expression =>
7707 -- if X (I) = Y (J) then
7708 -- if ... end if;
7709 -- else
7710 -- return X (I) > Y (J);
7711 -- end if;
7713 Loop_Body :=
7715 Condition =>
7717 Left_Opnd =>
7722 Right_Opnd =>
7731 Expression =>
7733 Left_Opnd =>
7738 Right_Opnd =>
7744 -- for I in X'range loop
7745 -- if ... end if;
7746 -- end loop;
7748 Loop_Statement :=
7752 Iteration_Scheme =>
7754 Loop_Parameter_Specification =>
7757 Discrete_Subtype_Definition =>
7764 -- if X'length = 0 then
7765 -- return false;
7766 -- elsif Y'length = 0 then
7767 -- return true;
7768 -- else
7769 -- for ... loop ... end loop;
7770 -- return X'length > Y'length;
7771 -- end if;
7773 Length1 :=
7778 Length2 :=
7783 Final_Expr :=
7788 If_Stat :=
7790 Condition =>
7792 Left_Opnd =>
7796 Right_Opnd =>
7799 Then_Statements =>
7800 New_List (
7806 Condition =>
7808 Left_Opnd =>
7812 Right_Opnd =>
7815 Then_Statements =>
7816 New_List (
7821 Loop_Statement,
7825 -- (X : a; Y: a)
7836 -- function Gnnn (...) return boolean is
7837 -- J : index := Y'first;
7838 -- begin
7839 -- if ... end if;
7840 -- end Gnnn;
7844 Func_Body :=
7846 Specification =>
7856 Expression =>
7861 Handled_Statement_Sequence =>
7868 ---------------------------
7869 -- Make_Boolean_Array_Op --
7870 ---------------------------
7872 -- For logical operations on boolean arrays, expand in line the
7873 -- following, replacing 'and' with 'or' or 'xor' where needed:
7875 -- function Annn (A : typ; B: typ) return typ is
7876 -- C : typ;
7877 -- begin
7878 -- for J in A'range loop
7879 -- C (J) := A (J) op B (J);
7880 -- end loop;
7881 -- return C;
7882 -- end Annn;
7884 -- Here typ is the boolean array type
7886 function Make_Boolean_Array_Op
7889 is
7907 begin
7908 A_J :=
7913 B_J :=
7918 C_J :=
7924 Op :=
7930 Op :=
7935 else
7936 Op :=
7942 Loop_Statement :=
7946 Iteration_Scheme =>
7948 Loop_Parameter_Specification =>
7951 Discrete_Subtype_Definition =>
7970 Func_Name :=
7974 Func_Body :=
7976 Specification =>
7987 Handled_Statement_Sequence =>
7990 Loop_Statement,
7997 ------------------------
7998 -- Rewrite_Comparison --
7999 ------------------------
8002 begin
8009 else
8010 declare
8016 -- Res indicates if compare outcome can be compile time determined
8021 begin
8032 and then Constant_Condition_Warnings
8035 and then not In_Instance
8038 then
8039 Error_Msg_N
8056 and then Constant_Condition_Warnings
8059 and then not In_Instance
8062 then
8063 Error_Msg_N
8090 ----------------------------
8091 -- Safe_In_Place_Array_Op --
8092 ----------------------------
8094 function Safe_In_Place_Array_Op
8098 is
8102 -- Operand is safe if it cannot overlap part of the target of the
8103 -- operation. If the operand and the target are identical, the operand
8104 -- is safe. The operand can be empty in the case of negation.
8107 -- Check that N is a stand-alone entity
8109 ------------------
8110 -- Is_Unaliased --
8111 ------------------
8114 begin
8115 return
8121 ---------------------
8122 -- Is_Safe_Operand --
8123 ---------------------
8126 begin
8135 then
8139 return
8146 else
8151 -- Start of processing for Is_Safe_In_Place_Array_Op
8153 begin
8154 -- We skip this processing if the component size is not the
8155 -- same as a system storage unit (since at least for NOT
8156 -- this would cause problems).
8161 -- Cannot do in place stuff on Java_VM since cannot pass addresses
8166 -- Cannot do in place stuff if non-standard Boolean representation
8173 else
8176 return
8182 -----------------------
8183 -- Tagged_Membership --
8184 -----------------------
8186 -- There are two different cases to consider depending on whether
8187 -- the right operand is a class-wide type or not. If not we just
8188 -- compare the actual tag of the left expr to the target type tag:
8189 --
8190 -- Left_Expr.Tag = Right_Type'Tag;
8191 --
8192 -- If it is a class-wide type we use the RT function CW_Membership which
8193 -- is usually implemented by looking in the ancestor tables contained in
8194 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
8205 begin
8213 Obj_Tag :=
8216 Selector_Name =>
8221 -- Ada 2005 (AI-251): Class-wide applied to interfaces
8225 -- Give support to: "Iface_CW_Typ in Typ'Class"
8228 then
8229 return
8236 New_Reference_To (
8237 Node (First_Elmt
8239 Loc)));
8241 -- Ada 95: Normal case
8243 else
8244 return
8248 Obj_Tag,
8249 New_Reference_To (
8250 Node (First_Elmt
8252 Loc)));
8255 else
8256 return
8259 Right_Opnd =>
8260 New_Reference_To
8265 ------------------------------
8266 -- Unary_Op_Validity_Checks --
8267 ------------------------------
8270 begin