| blob | fbdb701550a977683ce937e4d9624919c822ddf9 |
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 ------------------------------------------------------------------------------
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
74 -- Performs validity checks for a binary operator
76 procedure Build_Boolean_Array_Proc_Call
80 -- If an boolean array assignment can be done in place, build call to
81 -- corresponding library procedure.
84 -- Subsidiary to Expand_N_Allocator, for the case when the expression
85 -- is a qualified expression or an aggregate.
88 -- This routine handles expansion of the comparison operators (N_Op_Lt,
89 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
90 -- code for these operators is similar, differing only in the details of
91 -- the actual comparison call that is made. Special processing (call a
92 -- run-time routine)
94 function Expand_Array_Equality
100 -- Expand an array equality into a call to a function implementing this
101 -- equality, and a call to it. Loc is the location for the generated
102 -- nodes. Lhs and Rhs are the array expressions to be compared.
103 -- Bodies is a list on which to attach bodies of local functions that
104 -- are created in the process. It is the responsibility of the
105 -- caller to insert those bodies at the right place. Nod provides
106 -- the Sloc value for the generated code. Normally the types used
107 -- for the generated equality routine are taken from Lhs and Rhs.
108 -- However, in some situations of generated code, the Etype fields
109 -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the
110 -- type to be used for the formal parameters.
113 -- Common expansion processing for Boolean operators (And, Or, Xor)
114 -- for the case of array type arguments.
116 function Expand_Composite_Equality
122 -- Local recursive function used to expand equality for nested
123 -- composite types. Used by Expand_Record/Array_Equality, Bodies
124 -- is a list on which to attach bodies of local functions that are
125 -- created in the process. This is the responsability of the caller
126 -- to insert those bodies at the right place. Nod provides the Sloc
127 -- value for generated code. Lhs and Rhs are the left and right sides
128 -- for the comparison, and Typ is the type of the arrays to compare.
131 -- This routine handles expansion of concatenation operations, where
132 -- N is the N_Op_Concat node being expanded and Operands is the list
133 -- of operands (at least two are present). The caller has dealt with
134 -- converting any singleton operands into singleton aggregates.
137 -- Routine to expand concatenation of 2-5 operands (in the list Operands)
138 -- and replace node Cnode with the result of the contatenation. If there
139 -- are two operands, they can be string or character. If there are more
140 -- than two operands, then are always of type string (i.e. the caller has
141 -- already converted character operands to strings in this case).
144 -- N is either an N_Op_Divide or N_Op_Multiply node whose result is
145 -- universal fixed. We do not have such a type at runtime, so the
146 -- purpose of this routine is to find the real type by looking up
147 -- the tree. We also determine if the operation must be rounded.
149 function Get_Allocator_Final_List
153 -- If the designated type is controlled, build final_list expression
154 -- for created object. If context is an access parameter, create a
155 -- local access type to have a usable finalization list.
158 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
159 -- discriminants if it has a constrained nominal type, unless the object
160 -- is a component of an enclosing Unchecked_Union object that is subject
161 -- to a per-object constraint and the enclosing object lacks inferable
162 -- discriminants.
163 --
164 -- An expression of an Unchecked_Union type has inferable discriminants
165 -- if it is either a name of an object with inferable discriminants or a
166 -- qualified expression whose subtype mark denotes a constrained subtype.
169 -- N is an expression whose type is an access. When the type of the
170 -- associated storage pool is derived from Checked_Pool, generate a
171 -- call to the 'Dereference' primitive operation.
173 function Make_Array_Comparison_Op
176 -- Comparisons between arrays are expanded in line. This function
177 -- produces the body of the implementation of (a > b), where a and b
178 -- are one-dimensional arrays of some discrete type. The original
179 -- node is then expanded into the appropriate call to this function.
180 -- Nod provides the Sloc value for the generated code.
182 function Make_Boolean_Array_Op
185 -- Boolean operations on boolean arrays are expanded in line. This
186 -- function produce the body for the node N, which is (a and b),
187 -- (a or b), or (a xor b). It is used only the normal case and not
188 -- the packed case. The type involved, Typ, is the Boolean array type,
189 -- and the logical operations in the body are simple boolean operations.
190 -- Note that Typ is always a constrained type (the caller has ensured
191 -- this by using Convert_To_Actual_Subtype if necessary).
194 -- N is the node for a compile time comparison. If this outcome of this
195 -- comparison can be determined at compile time, then the node N can be
196 -- rewritten with True or False. If the outcome cannot be determined at
197 -- compile time, the call has no effect.
200 -- Construct the expression corresponding to the tagged membership test.
201 -- Deals with a second operand being (or not) a class-wide type.
203 function Safe_In_Place_Array_Op
207 -- In the context of an assignment, where the right-hand side is a
208 -- boolean operation on arrays, check whether operation can be performed
209 -- in place.
213 -- Performs validity checks for a unary operator
215 -------------------------------
216 -- Binary_Op_Validity_Checks --
217 -------------------------------
220 begin
227 ------------------------------------
228 -- Build_Boolean_Array_Proc_Call --
229 ------------------------------------
231 procedure Build_Boolean_Array_Proc_Call
235 is
248 begin
252 -- Use negated version of the binary operators
264 Call_Node :=
269 Target,
282 else
285 Call_Node :=
289 Target,
300 else
301 -- We use the following equivalences:
303 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
304 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
305 -- (not X) xor (not Y) = X xor Y
306 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
315 else
319 else
330 else
335 Call_Node :=
339 Target,
354 exception
359 ---------------------------------
360 -- Expand_Allocator_Expression --
361 ---------------------------------
378 begin
381 -- Actions inserted before:
382 -- Temp : constant ptr_T := new T'(Expression);
383 -- <no CW> Temp._tag := T'tag;
384 -- <CTRL> Adjust (Finalizable (Temp.all));
385 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
387 -- We analyze by hand the new internal allocator to avoid
388 -- any recursion and inappropriate call to Initialize
394 Temp :=
397 -- For a class wide allocation generate the following code:
399 -- type Equiv_Record is record ... end record;
400 -- implicit subtype CW is <Class_Wide_Subytpe>;
401 -- temp : PtrT := new CW'(CW!(expr));
413 Tmp_Node :=
417 Expression =>
421 Set_Comes_From_Source
429 then
430 -- Create local finalization list for access parameter
436 else
447 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
448 -- type, generate an accessibility check to verify that the level of
449 -- the type of the created object is not deeper than the level of the
450 -- access type. If the type of the qualified expression is class-
451 -- wide, then always generate the check. Otherwise, only generate the
452 -- check if the level of the qualified expression type is statically
453 -- deeper than the access type. Although the static accessibility
454 -- will generally have been performed as a legality check, it won't
455 -- have been done in cases where the allocator appears in generic
456 -- body, so a run-time check is needed in general.
461 and then
463 or else
465 then
468 Condition =>
470 Left_Opnd =>
472 Name =>
474 Parameter_Associations =>
476 Prefix =>
478 Attribute_Name =>
479 Name_Tag))),
480 Right_Opnd =>
485 -- Suppress the tag assignment when Java_VM because JVM tags
486 -- are represented implicitly in objects.
490 and then not Java_VM
491 then
492 Tag_Assign :=
494 Name =>
497 Selector_Name =>
500 Expression =>
502 New_Reference_To
504 Loc)));
506 -- The previous assignment has to be done in any case
513 and then not Java_VM
514 then
515 declare
522 begin
523 Tag_Assign :=
525 Name =>
528 Selector_Name =>
531 Expression =>
533 New_Reference_To (
535 Loc)));
544 then
545 declare
550 begin
551 -- If it is an allocation on the secondary stack
552 -- (i.e. a value returned from a function), the object
553 -- is attached on the caller side as soon as the call
554 -- is completed (see Expand_Ctrl_Function_Call)
557 declare
561 begin
572 -- Normal case, not a secondary stack allocation
574 else
577 then
578 -- Create local finalization list for access parameter
580 Flist :=
582 else
591 Make_Adjust_Call (
592 Ref =>
594 -- An unchecked conversion is needed in the
595 -- classwide case because the designated type
596 -- can be an ancestor of the subtype mark of
597 -- the allocator.
614 Temp :=
616 Tmp_Node :=
623 Set_Comes_From_Source
635 then
636 -- Apply constraint to designated subtype indication
644 -- Propagate constraint_error to enclosing allocator
648 else
649 -- First check against the type of the qualified expression
650 --
651 -- NOTE: The commented call should be correct, but for
652 -- some reason causes the compiler to bomb (sigsegv) on
653 -- ACVC test c34007g, so for now we just perform the old
654 -- (incorrect) test against the designated subtype with
655 -- no sliding in the else part of the if statement below.
656 -- ???
657 --
658 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
660 -- A check is also needed in cases where the designated
661 -- subtype is constrained and differs from the subtype
662 -- given in the qualified expression. Note that the check
663 -- on the qualified expression does not allow sliding,
664 -- but this check does (a relaxation from Ada 83).
667 and then not Subtypes_Statically_Match
669 then
670 Apply_Constraint_Check
673 -- The nonsliding check should really be performed
674 -- (unconditionally) against the subtype of the
675 -- qualified expression, but that causes a problem
676 -- with c34007g (see above), so for now we retain this.
678 else
679 Apply_Constraint_Check
684 exception
689 -----------------------------
690 -- Expand_Array_Comparison --
691 -----------------------------
693 -- Expansion is only required in the case of array types. For the
694 -- unpacked case, an appropriate runtime routine is called. For
695 -- packed cases, and also in some other cases where a runtime
696 -- routine cannot be called, the form of the expansion is:
698 -- [body for greater_nn; boolean_expression]
700 -- The body is built by Make_Array_Comparison_Op, and the form of the
701 -- Boolean expression depends on the operator involved.
717 -- True for byte addressable target
720 -- Returns True if the length of the given operand is known to be
721 -- less than 4. Returns False if this length is known to be four
722 -- or greater or is not known at compile time.
724 ------------------------
725 -- Length_Less_Than_4 --
726 ------------------------
731 begin
735 else
736 declare
743 begin
746 else
752 else
761 -- Start of processing for Expand_Array_Comparison
763 begin
764 -- Deal first with unpacked case, where we can call a runtime routine
765 -- except that we avoid this for targets for which are not addressable
766 -- by bytes, and for the JVM, since the JVM does not support direct
767 -- addressing of array components.
770 and then Byte_Addressable
771 and then not Java_VM
772 then
773 -- The call we generate is:
775 -- Compare_Array_xn[_Unaligned]
776 -- (left'address, right'address, left'length, right'length) <op> 0
778 -- x = U for unsigned, S for signed
779 -- n = 8,16,32,64 for component size
780 -- Add _Unaligned if length < 4 and component size is 8.
781 -- <op> is the standard comparison operator
785 or else
787 then
790 else
794 else
797 else
805 else
812 else
819 else
857 -- Cases where we cannot make runtime call
859 -- For (a <= b) we convert to not (a > b)
864 Right_Opnd =>
871 -- For < the Boolean expression is
872 -- greater__nn (op2, op1)
877 -- Switch operands
882 -- For (a >= b) we convert to not (a < b)
887 Right_Opnd =>
894 -- For > the Boolean expression is
895 -- greater__nn (op1, op2)
897 else
903 Expr :=
912 exception
917 ---------------------------
918 -- Expand_Array_Equality --
919 ---------------------------
921 -- Expand an equality function for multi-dimensional arrays. Here is
922 -- an example of such a function for Nb_Dimension = 2
924 -- function Enn (A : atyp; B : btyp) return boolean is
925 -- begin
926 -- if (A'length (1) = 0 or else A'length (2) = 0)
927 -- and then
928 -- (B'length (1) = 0 or else B'length (2) = 0)
929 -- then
930 -- return True; -- RM 4.5.2(22)
931 -- end if;
933 -- if A'length (1) /= B'length (1)
934 -- or else
935 -- A'length (2) /= B'length (2)
936 -- then
937 -- return False; -- RM 4.5.2(23)
938 -- end if;
940 -- declare
941 -- A1 : Index_T1 := A'first (1);
942 -- B1 : Index_T1 := B'first (1);
943 -- begin
944 -- loop
945 -- declare
946 -- A2 : Index_T2 := A'first (2);
947 -- B2 : Index_T2 := B'first (2);
948 -- begin
949 -- loop
950 -- if A (A1, A2) /= B (B1, B2) then
951 -- return False;
952 -- end if;
954 -- exit when A2 = A'last (2);
955 -- A2 := Index_T2'succ (A2);
956 -- B2 := Index_T2'succ (B2);
957 -- end loop;
958 -- end;
960 -- exit when A1 = A'last (1);
961 -- A1 := Index_T1'succ (A1);
962 -- B1 := Index_T1'succ (B1);
963 -- end loop;
964 -- end;
966 -- return true;
967 -- end Enn;
969 -- Note on the formal types used (atyp and btyp). If either of the
970 -- arrays is of a private type, we use the underlying type, and
971 -- do an unchecked conversion of the actual. If either of the arrays
972 -- has a bound depending on a discriminant, then we use the base type
973 -- since otherwise we have an escaped discriminant in the function.
975 -- If both arrays are constrained and have the same bounds, we can
976 -- generate a loop with an explicit iteration scheme using a 'Range
977 -- attribute over the first array.
979 function Expand_Array_Equality
985 is
1001 -- The parameter types to be used for the formals
1003 function Arr_Attr
1007 -- This builds the attribute reference Arr'Nam (Expr)
1010 -- Create one statement to compare corresponding components,
1011 -- designated by a full set of indices.
1014 -- Given one of the arguments, computes the appropriate type to
1015 -- be used for that argument in the corresponding function formal
1017 function Handle_One_Dimension
1020 -- This procedure returns the following code
1021 --
1022 -- declare
1023 -- Bn : Index_T := B'First (N);
1024 -- begin
1025 -- loop
1026 -- xxx
1027 -- exit when An = A'Last (N);
1028 -- An := Index_T'Succ (An)
1029 -- Bn := Index_T'Succ (Bn)
1030 -- end loop;
1031 -- end;
1032 --
1033 -- If both indices are constrained and identical, the procedure
1034 -- returns a simpler loop:
1035 --
1036 -- for An in A'Range (N) loop
1037 -- xxx
1038 -- end loop
1039 --
1040 -- N is the dimension for which we are generating a loop. Index is the
1041 -- N'th index node, whose Etype is Index_Type_n in the above code.
1042 -- The xxx statement is either the loop or declare for the next
1043 -- dimension or if this is the last dimension the comparison
1044 -- of corresponding components of the arrays.
1045 --
1046 -- The actual way the code works is to return the comparison
1047 -- of corresponding components for the N+1 call. That's neater!
1050 -- This function constructs the test for both arrays being empty
1051 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1052 -- and then
1053 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1056 -- This function constructs the test for arrays having different
1057 -- lengths in at least one index position, in which case resull
1059 -- A'length (1) /= B'length (1)
1060 -- or else
1061 -- A'length (2) /= B'length (2)
1062 -- or else
1063 -- ...
1065 --------------
1066 -- Arr_Attr --
1067 --------------
1069 function Arr_Attr
1073 is
1074 begin
1075 return
1082 ------------------------
1083 -- Component_Equality --
1084 ------------------------
1090 begin
1091 -- if a(i1...) /= b(j1...) then return false; end if;
1093 L :=
1098 R :=
1103 Test := Expand_Composite_Equality
1106 -- If some (sub)component is an unchecked_union, the whole operation
1107 -- will raise program error.
1111 -- This node is going to be inserted at a location where a
1112 -- statement is expected: clear its Etype so analysis will
1113 -- set it to the expected Standard_Void_Type.
1118 else
1119 return
1128 ------------------
1129 -- Get_Arg_Type --
1130 ------------------
1136 begin
1142 else
1148 or else
1150 then
1162 --------------------------
1163 -- Handle_One_Dimension --
1164 ---------------------------
1166 function Handle_One_Dimension
1169 is
1171 Ltyp /= Rtyp
1173 -- If the index types are identical, and we are working with
1174 -- constrained types, then we can use the same index for both of
1175 -- the arrays.
1185 begin
1190 -- Case where we generate a loop
1195 Bn :=
1198 else
1210 -- Generate guard for loop, followed by increments of indices
1214 Condition =>
1222 Expression =>
1231 Expression =>
1238 -- If separate indexes, we need a declare block for An and Bn, and a
1239 -- loop without an iteration scheme.
1242 Loop_Stm :=
1245 return
1258 Handled_Statement_Sequence =>
1262 -- If no separate indexes, return loop statement with explicit
1263 -- iteration scheme on its own
1265 else
1266 Loop_Stm :=
1269 Iteration_Scheme =>
1271 Loop_Parameter_Specification =>
1274 Discrete_Subtype_Definition =>
1280 -----------------------
1281 -- Test_Empty_Arrays --
1282 -----------------------
1291 begin
1295 Atest :=
1300 Btest :=
1309 else
1310 Alist :=
1315 Blist :=
1322 return
1328 -----------------------------
1329 -- Test_Lengths_Correspond --
1330 -----------------------------
1336 begin
1339 Rtest :=
1346 else
1347 Result :=
1357 -- Start of processing for Expand_Array_Equality
1359 begin
1363 -- For now, if the argument types are not the same, go to the
1364 -- base type, since the code assumes that the formals have the
1365 -- same type. This is fixable in future ???
1373 -- Build list of formals for function
1386 -- Build statement sequence for function
1388 Func_Body :=
1390 Specification =>
1398 Handled_Statement_Sequence =>
1406 Expression =>
1413 Expression =>
1424 -- If the array type is distinct from the type of the arguments,
1425 -- it is the full view of a private type. Apply an unchecked
1426 -- conversion to insure that analysis of the call succeeds.
1428 declare
1431 begin
1437 then
1443 then
1452 return
1458 -----------------------------
1459 -- Expand_Boolean_Operator --
1460 -----------------------------
1462 -- Note that we first get the actual subtypes of the operands,
1463 -- since we always want to deal with types that have bounds.
1468 begin
1469 -- Special case of bit packed array where both operands are known
1470 -- to be properly aligned. In this case we use an efficient run time
1471 -- routine to carry out the operation (see System.Bit_Ops).
1476 then
1481 -- For the normal non-packed case, the general expansion is to build
1482 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1483 -- and then inserting it into the tree. The original operator node is
1484 -- then rewritten as a call to this function. We also use this in the
1485 -- packed case if either operand is a possibly unaligned object.
1487 declare
1494 begin
1503 then
1508 and then
1510 then
1512 else
1518 -- Now rewrite the expression with a call
1523 Parameter_Associations =>
1524 New_List (
1525 L,
1526 Make_Type_Conversion
1534 -------------------------------
1535 -- Expand_Composite_Equality --
1536 -------------------------------
1538 -- This function is only called for comparing internal fields of composite
1539 -- types when these fields are themselves composites. This is a special
1540 -- case because it is not possible to respect normal Ada visibility rules.
1542 function Expand_Composite_Equality
1548 is
1554 begin
1557 else
1561 -- Defense against malformed private types with no completion
1562 -- the error will be diagnosed later by check_completion
1572 -- If the operand is an elementary type other than a floating-point
1573 -- type, then we can simply use the built-in block bitwise equality,
1574 -- since the predefined equality operators always apply and bitwise
1575 -- equality is fine for all these cases.
1579 then
1582 -- For composite component types, and floating-point types, use
1583 -- the expansion. This deals with tagged component types (where
1584 -- we use the applicable equality routine) and floating-point,
1585 -- (where we need to worry about negative zeroes), and also the
1586 -- case of any composite type recursively containing such fields.
1588 else
1594 -- Call the primitive operation "=" of this type
1600 -- If this is derived from an untagged private type completed
1601 -- with a tagged type, it does not have a full view, so we
1602 -- use the primitive operations of the private type.
1603 -- This check should no longer be necessary when these
1604 -- types receive their full views ???
1611 then
1613 else
1617 loop
1629 return
1632 Parameter_Associations =>
1633 New_List
1643 -- Inherited equality from parent type. Convert the actuals
1644 -- to match signature of operation.
1646 declare
1649 begin
1650 return
1653 Parameter_Associations =>
1658 else
1659 -- Comparison between Unchecked_Union components
1662 declare
1668 begin
1669 -- Lhs subtype
1675 -- Rhs subtype
1681 -- Lhs of the composite equality
1685 -- Since the enclosing record can never be an
1686 -- Unchecked_Union (this code is executed for records
1687 -- that do not have variants), we may reference its
1688 -- discriminant(s).
1693 then
1694 Lhs_Discr_Val :=
1697 Selector_Name =>
1698 New_Copy (
1699 Get_Discriminant_Value (
1701 Lhs_Type,
1704 else
1706 Get_Discriminant_Value (
1708 Lhs_Type,
1712 else
1713 -- It is not possible to infer the discriminant since
1714 -- the subtype is not constrained.
1716 return
1721 -- Rhs of the composite equality
1727 then
1728 Rhs_Discr_Val :=
1731 Selector_Name =>
1732 New_Copy (
1733 Get_Discriminant_Value (
1735 Rhs_Type,
1738 else
1740 Get_Discriminant_Value (
1742 Rhs_Type,
1746 else
1747 return
1752 -- Call the TSS equality function with the inferred
1753 -- discriminant values.
1755 return
1759 Lhs,
1760 Rhs,
1761 Lhs_Discr_Val,
1762 Rhs_Discr_Val));
1766 -- Shouldn't this be an else, we can't fall through
1767 -- the above IF, right???
1769 return
1775 else
1779 else
1780 -- It can be a simple record or the full view of a scalar private
1786 ------------------------------
1787 -- Expand_Concatenate_Other --
1788 ------------------------------
1790 -- Let n be the number of array operands to be concatenated, Base_Typ
1791 -- their base type, Ind_Typ their index type, and Arr_Typ the original
1792 -- array type to which the concatenantion operator applies, then the
1793 -- following subprogram is constructed:
1795 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1796 -- L : Ind_Typ;
1797 -- begin
1798 -- if S1'Length /= 0 then
1799 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
1800 -- XXX = Arr_Typ'First otherwise
1801 -- elsif S2'Length /= 0 then
1802 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
1803 -- YYY = Arr_Typ'First otherwise
1804 -- ...
1805 -- elsif Sn-1'Length /= 0 then
1806 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
1807 -- ZZZ = Arr_Typ'First otherwise
1808 -- else
1809 -- return Sn;
1810 -- end if;
1812 -- declare
1813 -- P : Ind_Typ;
1814 -- H : Ind_Typ :=
1815 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1816 -- + Ind_Typ'Pos (L));
1817 -- R : Base_Typ (L .. H);
1818 -- begin
1819 -- if S1'Length /= 0 then
1820 -- P := S1'First;
1821 -- loop
1822 -- R (L) := S1 (P);
1823 -- L := Ind_Typ'Succ (L);
1824 -- exit when P = S1'Last;
1825 -- P := Ind_Typ'Succ (P);
1826 -- end loop;
1827 -- end if;
1828 --
1829 -- if S2'Length /= 0 then
1830 -- L := Ind_Typ'Succ (L);
1831 -- loop
1832 -- R (L) := S2 (P);
1833 -- L := Ind_Typ'Succ (L);
1834 -- exit when P = S2'Last;
1835 -- P := Ind_Typ'Succ (P);
1836 -- end loop;
1837 -- end if;
1839 -- ...
1841 -- if Sn'Length /= 0 then
1842 -- P := Sn'First;
1843 -- loop
1844 -- R (L) := Sn (P);
1845 -- L := Ind_Typ'Succ (L);
1846 -- exit when P = Sn'Last;
1847 -- P := Ind_Typ'Succ (P);
1848 -- end loop;
1849 -- end if;
1851 -- return R;
1852 -- end;
1853 -- end Cnn;]
1891 -- Builds the sequence of statement:
1892 -- P := Si'First;
1893 -- loop
1894 -- R (L) := Si (P);
1895 -- L := Ind_Typ'Succ (L);
1896 -- exit when P = Si'Last;
1897 -- P := Ind_Typ'Succ (P);
1898 -- end loop;
1899 --
1900 -- where i is the input parameter I given.
1901 -- If the flag Last is true, the exit statement is emitted before
1902 -- incrementing the lower bound, to prevent the creation out of
1903 -- bound values.
1906 -- Builds the statement:
1907 -- L := Arr_Typ'First; If Arr_Typ is constrained
1908 -- L := Si'First; otherwise (where I is the input param given)
1911 -- Builds reference to identifier H
1914 -- Builds expression Ind_Typ'Val (E);
1917 -- Builds reference to identifier L
1920 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
1921 -- expression to avoid universal_integer computations whenever possible,
1922 -- in the expression for the upper bound H.
1925 -- Builds expression Ind_Typ'Succ (L)
1928 -- Builds integer literal one
1931 -- Builds reference to identifier P
1934 -- Builds expression Ind_Typ'Succ (P)
1937 -- Builds reference to identifier R
1940 -- Builds reference to identifier Si, where I is the value given
1943 -- Builds expression Si'First, where I is the value given
1946 -- Builds expression Si'Last, where I is the value given
1949 -- Builds expression Si'Length, where I is the value given
1952 -- Builds expression Si'Length /= 0, where I is the value given
1954 -------------------
1955 -- Copy_Into_R_S --
1956 -------------------
1967 begin
1968 -- First construct the initializations
1975 -- Then build the loop
1997 Loop_Stmt :=
2000 else
2001 Loop_Stmt :=
2011 -------
2012 -- H --
2013 -------
2016 begin
2020 -------------
2021 -- Ind_Val --
2022 -------------
2025 begin
2026 return
2033 ------------
2034 -- Init_L --
2035 ------------
2040 begin
2046 else
2053 -------
2054 -- L --
2055 -------
2058 begin
2062 -----------
2063 -- L_Pos --
2064 -----------
2069 begin
2070 -- If the index type is an enumeration type, the computation
2071 -- can be done in standard integer. Otherwise, choose a large
2072 -- enough integer type.
2078 then
2080 else
2084 return
2087 Expression =>
2094 ------------
2095 -- L_Succ --
2096 ------------
2099 begin
2100 return
2107 ---------
2108 -- One --
2109 ---------
2112 begin
2116 -------
2117 -- P --
2118 -------
2121 begin
2125 ------------
2126 -- P_Succ --
2127 ------------
2130 begin
2131 return
2138 -------
2139 -- R --
2140 -------
2143 begin
2147 -------
2148 -- S --
2149 -------
2152 begin
2156 -------------
2157 -- S_First --
2158 -------------
2161 begin
2167 ------------
2168 -- S_Last --
2169 ------------
2172 begin
2178 --------------
2179 -- S_Length --
2180 --------------
2183 begin
2189 -------------------
2190 -- S_Length_Test --
2191 -------------------
2194 begin
2195 return
2201 -- Start of processing for Expand_Concatenate_Other
2203 begin
2204 -- Construct the parameter specs and the overall function spec
2208 Append_To
2211 Defining_Identifier =>
2217 Func_Spec :=
2223 -- Construct L's object declaration
2225 L_Decl :=
2232 -- Construct the if-then-elsif statements
2241 If_Stmt :=
2249 -- Construct the declaration for H
2251 P_Decl :=
2262 H_Decl :=
2268 -- Construct the declaration for R
2271 R_Constr :=
2275 R_Decl :=
2278 Object_Definition =>
2283 -- Construct the declarations for the declare block
2287 -- Construct list of statements for the declare block
2299 -- Construct the declare block
2303 Handled_Statement_Sequence =>
2306 -- Construct the list of function statements
2310 -- Construct the function body
2312 Func_Body :=
2316 Handled_Statement_Sequence =>
2319 -- Insert the newly generated function in the code. This is analyzed
2320 -- with all checks off, since we have completed all the checks.
2322 -- Note that this does *not* fix the array concatenation bug when the
2323 -- low bound is Integer'first sibce that bug comes from the pointer
2324 -- dereferencing an unconstrained array. An there we need a constraint
2325 -- check to make sure the length of the concatenated array is ok. ???
2329 -- Construct list of arguments for the function call
2338 -- Insert the function call
2340 Rewrite
2348 -------------------------------
2349 -- Expand_Concatenate_String --
2350 -------------------------------
2360 -- RE_Id value for function to be called
2362 begin
2363 -- In all cases, we build a call to a routine giving the list of
2364 -- arguments as the parameter list to the routine.
2372 else
2381 else
2386 -- If we have anything other than Standard_Character or
2387 -- Standard_String, then we must have had a serious error
2388 -- earlier, so we just abandon the attempt at expansion.
2390 else
2409 -- Now generate the appropriate call
2418 exception
2423 ------------------------
2424 -- Expand_N_Allocator --
2425 ------------------------
2435 begin
2436 -- RM E.2.3(22). We enforce that the expected type of an allocator
2437 -- shall not be a remote access-to-class-wide-limited-private type
2439 -- Why is this being done at expansion time, seems clearly wrong ???
2443 -- Set the Storage Pool
2456 else
2462 -- Under certain circumstances we can replace an allocator by an
2463 -- access to statically allocated storage. The conditions, as noted
2464 -- in AARM 3.10 (10c) are as follows:
2466 -- Size and initial value is known at compile time
2467 -- Access type is access-to-constant
2469 -- The allocator is not part of a constraint on a record component,
2470 -- because in that case the inserted actions are delayed until the
2471 -- record declaration is fully analyzed, which is too late for the
2472 -- analysis of the rewritten allocator.
2480 then
2481 -- Here we can do the optimization. For the allocator
2483 -- new x'(y)
2485 -- We insert an object declaration
2487 -- Tnn : aliased x := y;
2489 -- and replace the allocator by Tnn'Unrestricted_Access.
2490 -- Tnn is marked as requiring static allocation.
2492 Temp :=
2497 -- If context is constrained, use constrained subtype directly,
2498 -- so that the constant is not labelled as having a nomimally
2499 -- unconstrained subtype.
2520 -- We set the variable as statically allocated, since we don't
2521 -- want it going on the stack of the current procedure!
2527 -- Handle case of qualified expression (other than optimization above)
2532 -- If the allocator is for a type which requires initialization, and
2533 -- there is no initial value (i.e. operand is a subtype indication
2534 -- rather than a qualifed expression), then we must generate a call
2535 -- to the initialization routine. This is done using an expression
2536 -- actions node:
2537 --
2538 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2539 --
2540 -- Here ptr_T is the pointer type for the allocator, and T is the
2541 -- subtype of the allocator. A special case arises if the designated
2542 -- type of the access type is a task or contains tasks. In this case
2543 -- the call to Init (Temp.all ...) is replaced by code that ensures
2544 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2545 -- for details). In addition, if the type T is a task T, then the
2546 -- first argument to Init must be converted to the task record type.
2548 else
2549 declare
2562 begin
2566 -- Case of no initialization procedure present
2570 -- Case of simple initialization required
2583 -- No initialization required
2585 else
2589 -- Case of initialization procedure present, must be called
2591 else
2594 Temp :=
2597 -- Construct argument list for the initialization routine call
2598 -- The CPP constructor needs the address directly
2604 else
2605 Arg1 :=
2611 -- The initialization procedure expects a specific type.
2612 -- if the context is access to class wide, indicate that
2613 -- the object being allocated has the right specific type.
2620 -- If designated type is a concurrent type or if it is a
2621 -- private type whose definition is a concurrent type,
2622 -- the first argument in the Init routine has to be
2623 -- unchecked conversion to the corresponding record type.
2624 -- If the designated type is a derived type, we also
2625 -- convert the argument to its root type.
2628 Arg1 :=
2634 then
2635 Arg1 :=
2636 Unchecked_Convert_To
2641 declare
2644 begin
2652 -- For the task case, pass the Master_Id of the access type
2653 -- as the value of the _Master parameter, and _Chain as the
2654 -- value of the _Chain parameter (_Chain will be defined as
2655 -- part of the generated code for the allocator).
2660 -- The designated type was an incomplete type, and
2661 -- the access type did not get expanded. Salvage
2662 -- it now.
2664 Expand_N_Full_Type_Declaration
2668 -- If the context of the allocator is a declaration or
2669 -- an assignment, we can generate a meaningful image for
2670 -- it, even though subsequent assignments might remove
2671 -- the connection between task and entity. We build this
2672 -- image when the left-hand side is a simple variable,
2673 -- a simple indexed assignment or a simple selected
2674 -- component.
2677 declare
2680 begin
2682 Decls :=
2683 Build_Task_Image_Decls (
2684 Loc,
2685 New_Occurrence_Of
2691 then
2692 Decls :=
2693 Build_Task_Image_Decls
2695 else
2701 Decls :=
2702 Build_Task_Image_Decls (
2705 else
2710 New_Reference_To
2718 -- Has_Task is false, Decls not used
2720 else
2724 -- Add discriminants if discriminated type
2737 then
2738 Discr :=
2747 -- We set the allocator as analyzed so that when we analyze the
2748 -- expression actions node, we do not get an unwanted recursive
2749 -- expansion of the allocator expression.
2754 -- Here is the transformation:
2755 -- input: new T
2756 -- output: Temp : constant ptr_T := new T;
2757 -- Init (Temp.all, ...);
2758 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
2759 -- <CTRL> Initialize (Finalizable (Temp.all));
2761 -- Here ptr_T is the pointer type for the allocator, and T
2762 -- is the subtype of the allocator.
2764 Temp_Decl :=
2779 -- If the designated type is task type or contains tasks,
2780 -- Create block to activate created tasks, and insert
2781 -- declaration for Task_Image variable ahead of call.
2784 declare
2788 begin
2796 else
2807 else
2811 Make_Init_Call (
2816 Attach_Level)));
2824 else
2833 exception
2838 -----------------------
2839 -- Expand_N_And_Then --
2840 -----------------------
2842 -- Expand into conditional expression if Actions present, and also
2843 -- deal with optimizing case of arguments being True or False.
2852 begin
2853 -- Deal with non-standard booleans
2861 -- Check for cases of left argument is True or False
2865 -- If left argument is True, change (True and then Right) to Right.
2866 -- Any actions associated with Right will be executed unconditionally
2867 -- and can thus be inserted into the tree unconditionally.
2878 -- If left argument is False, change (False and then Right) to
2879 -- False. In this case we can forget the actions associated with
2880 -- Right, since they will never be executed.
2891 -- If Actions are present, we expand
2893 -- left and then right
2895 -- into
2897 -- if left then right else false end
2899 -- with the actions becoming the Then_Actions of the conditional
2900 -- expression. This conditional expression is then further expanded
2901 -- (and will eventually disappear)
2908 Left,
2909 Right,
2918 -- No actions present, check for cases of right argument True/False
2922 -- Change (Left and then True) to Left. Note that we know there
2923 -- are no actions associated with the True operand, since we
2924 -- just checked for this case above.
2929 -- Change (Left and then False) to False, making sure to preserve
2930 -- any side effects associated with the Left operand.
2934 Rewrite
2942 -------------------------------------
2943 -- Expand_N_Conditional_Expression --
2944 -------------------------------------
2946 -- Expand into expression actions if then/else actions present
2957 begin
2958 -- If either then or else actions are present, then given:
2960 -- if cond then then-expr else else-expr end
2962 -- we insert the following sequence of actions (using Insert_Actions):
2964 -- Cnn : typ;
2965 -- if cond then
2966 -- <<then actions>>
2967 -- Cnn := then-expr;
2968 -- else
2969 -- <<else actions>>
2970 -- Cnn := else-expr
2971 -- end if;
2973 -- and replace the conditional expression by a reference to Cnn
2978 New_If :=
2996 Insert_List_Before
3001 Insert_List_Before
3017 -----------------------------------
3018 -- Expand_N_Explicit_Dereference --
3019 -----------------------------------
3022 begin
3023 -- The only processing required is an insertion of an explicit
3024 -- dereference call for the checked storage pool case.
3029 -----------------
3030 -- Expand_N_In --
3031 -----------------
3041 -- Replaces node N by Lop'Valid. This is done when we have an explicit
3042 -- test for the left operand being in range of its subtype.
3044 ----------------------------
3045 -- Substitute_Valid_Check --
3046 ----------------------------
3049 begin
3062 -- Start of processing for Expand_N_In
3064 begin
3065 -- Check case of explicit test for an expression in range of its
3066 -- subtype. This is suspicious usage and we replace it with a 'Valid
3067 -- test and give a warning.
3073 then
3074 Substitute_Valid_Check;
3078 -- Case of explicit range
3081 declare
3091 begin
3092 -- If test is explicit x'first .. x'last, replace by valid check
3104 then
3105 Substitute_Valid_Check;
3109 -- If we have an explicit range, do a bit of optimization based
3110 -- on range analysis (we may be able to kill one or both checks).
3112 -- If either check is known to fail, replace result by False since
3113 -- the other check does not matter. Preserve the static flag for
3114 -- legality checks, because we are constant-folding beyond RM 4.9.
3123 -- If both checks are known to succeed, replace result
3124 -- by True, since we know we are in range.
3133 -- If lower bound check succeeds and upper bound check is
3134 -- not known to succeed or fail, then replace the range check
3135 -- with a comparison against the upper bound.
3145 -- If upper bound check succeeds and lower bound check is
3146 -- not known to succeed or fail, then replace the range check
3147 -- with a comparison against the lower bound.
3159 -- For all other cases of an explicit range, nothing to be done
3163 -- Here right operand is a subtype mark
3165 else
3166 declare
3172 begin
3175 -- For tagged type, do tagged membership operation
3179 -- No expansion will be performed when Java_VM, as the
3180 -- JVM back end will handle the membership tests directly
3181 -- (tags are not explicitly represented in Java objects,
3182 -- so the normal tagged membership expansion is not what
3183 -- we want).
3192 -- If type is scalar type, rewrite as x in t'first .. t'last
3193 -- This reason we do this is that the bounds may have the wrong
3194 -- type if they come from the original type definition.
3199 Low_Bound =>
3204 High_Bound =>
3211 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
3212 -- a membership test if the subtype mark denotes a constrained
3213 -- Unchecked_Union subtype and the expression lacks inferable
3214 -- discriminants.
3219 then
3224 -- Prevent Gigi from generating incorrect code by rewriting
3225 -- the test as a standard False.
3233 -- Here we have a non-scalar type
3244 -- For the constrained array case, we have to check the
3245 -- subscripts for an exact match if the lengths are
3246 -- non-zero (the lengths must match in any case).
3251 function Construct_Attribute_Reference
3255 -- Build attribute reference E'Nam(Dim)
3257 -----------------------------------
3258 -- Construct_Attribute_Reference --
3259 -----------------------------------
3261 function Construct_Attribute_Reference
3265 is
3266 begin
3267 return
3275 -- Start processing for Check_Subscripts
3277 begin
3281 Left_Opnd =>
3282 Construct_Attribute_Reference
3285 Right_Opnd =>
3286 Construct_Attribute_Reference
3291 Left_Opnd =>
3292 Construct_Attribute_Reference
3295 Right_Opnd =>
3296 Construct_Attribute_Reference
3301 Cond :=
3303 Left_Opnd =>
3314 -- These are the cases where constraint checks may be
3315 -- required, e.g. records with possible discriminants
3317 else
3318 -- Expand the test into a series of discriminant comparisons.
3319 -- The expression that is built is the negation of the one
3320 -- that is used for checking discriminant constraints.
3330 Left_Opnd =>
3337 else
3348 --------------------------------
3349 -- Expand_N_Indexed_Component --
3350 --------------------------------
3358 begin
3359 -- A special optimization, if we have an indexed component that
3360 -- is selecting from a slice, then we can eliminate the slice,
3361 -- since, for example, x (i .. j)(k) is identical to x(k). The
3362 -- only difference is the range check required by the slice. The
3363 -- range check for the slice itself has already been generated.
3364 -- The range check for the subscripting operation is ensured
3365 -- by converting the subject to the subtype of the slice.
3367 -- This optimization not only generates better code, avoiding
3368 -- slice messing especially in the packed case, but more importantly
3369 -- bypasses some problems in handling this peculiar case, for
3370 -- example, the issue of dealing specially with object renamings.
3377 Convert_To
3384 -- If the prefix is an access type, then we unconditionally rewrite
3385 -- if as an explicit deference. This simplifies processing for several
3386 -- cases, including packed array cases and certain cases in which
3387 -- checks must be generated. We used to try to do this only when it
3388 -- was necessary, but it cleans up the code to do it all the time.
3395 -- Generate index and validity checks
3403 -- All done for the non-packed case
3409 -- For packed arrays that are not bit-packed (i.e. the case of an array
3410 -- with one or more index types with a non-coniguous enumeration type),
3411 -- we can always use the normal packed element get circuit.
3418 -- For a reference to a component of a bit packed array, we have to
3419 -- convert it to a reference to the corresponding Packed_Array_Type.
3420 -- We only want to do this for simple references, and not for:
3422 -- Left side of assignment, or prefix of left side of assignment,
3423 -- or prefix of the prefix, to handle packed arrays of packed arrays,
3424 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3426 -- Renaming objects in renaming associations
3427 -- This case is handled when a use of the renamed variable occurs
3429 -- Actual parameters for a procedure call
3430 -- This case is handled in Exp_Ch6.Expand_Actuals
3432 -- The second expression in a 'Read attribute reference
3434 -- The prefix of an address or size attribute reference
3436 -- The following circuit detects these exceptions
3438 declare
3442 begin
3443 loop
3450 and then
3452 then
3457 or else
3460 then
3465 then
3468 -- If the expression is an index of an indexed component,
3469 -- it must be expanded regardless of context.
3473 then
3479 then
3485 then
3491 then
3494 else
3499 -- Keep looking up tree for unchecked expression, or if we are
3500 -- the prefix of a possible assignment left side.
3509 ---------------------
3510 -- Expand_N_Not_In --
3511 ---------------------
3513 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
3514 -- can be done. This avoids needing to duplicate this expansion code.
3521 begin
3524 Right_Opnd =>
3529 -- We want this tp appear as coming from source if original does (see
3530 -- tranformations in Expand_N_In).
3535 -- Now analyze tranformed node
3540 -------------------
3541 -- Expand_N_Null --
3542 -------------------
3544 -- The only replacement required is for the case of a null of type
3545 -- that is an access to protected subprogram. We represent such
3546 -- access values as a record, and so we must replace the occurrence
3547 -- of null by the equivalent record (with a null address and a null
3548 -- pointer in it), so that the backend creates the proper value.
3555 begin
3557 Agg :=
3566 -- For subsequent semantic analysis, the node must retain its
3567 -- type. Gigi in any case replaces this type by the corresponding
3568 -- record type before processing the node.
3573 exception
3578 ---------------------
3579 -- Expand_N_Op_Abs --
3580 ---------------------
3586 begin
3589 -- Deal with software overflow checking
3591 if not Backend_Overflow_Checks_On_Target
3594 then
3595 -- The only case to worry about is when the argument is
3596 -- equal to the largest negative number, so what we do is
3597 -- to insert the check:
3599 -- [constraint_error when Expr = typ'Base'First]
3601 -- with the usual Duplicate_Subexpr use coding for expr
3605 Condition =>
3608 Right_Opnd =>
3610 Prefix =>
3616 -- Vax floating-point types case
3623 ---------------------
3624 -- Expand_N_Op_Add --
3625 ---------------------
3630 begin
3633 -- N + 0 = 0 + N = N for integer types
3638 then
3644 then
3650 -- Arithmetic overflow checks for signed integer/fixed point types
3654 then
3658 -- Vax floating-point types case
3665 ---------------------
3666 -- Expand_N_Op_And --
3667 ---------------------
3672 begin
3686 ------------------------
3687 -- Expand_N_Op_Concat --
3688 ------------------------
3691 -- This is initialized the first time this routine is called. It records
3692 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3693 -- available in the run-time:
3694 --
3695 -- 0 None available
3696 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
3697 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3698 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3699 -- 5 All routines including RE_Str_Concat_5 available
3702 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3703 -- all three are available, False if any one of these is unavailable.
3707 -- List of operands to be concatenated
3710 -- Single operand for concatenation
3713 -- Node which is to be replaced by the result of concatenating
3714 -- the nodes in the list Opnds.
3717 -- Array type of concatenation result type
3720 -- Component type of concatenation represented by Cnode
3722 begin
3723 -- Initialize global variables showing run-time status
3734 else
3738 Char_Concat_Available :=
3740 and then
3742 and then
3746 -- Ensure validity of both operands
3750 -- If we are the left operand of a concatenation higher up the
3751 -- tree, then do nothing for now, since we want to deal with a
3752 -- series of concatenations as a unit.
3756 then
3760 -- We get here with a concatenation whose left operand may be a
3761 -- concatenation itself with a consistent type. We need to process
3762 -- these concatenation operands from left to right, which means
3763 -- from the deepest node in the tree to the highest node.
3770 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
3771 -- nodes above, so now we process bottom up, doing the operations. We
3772 -- gather a string that is as long as possible up to five operands
3774 -- The outer loop runs more than once if there are more than five
3775 -- concatenations of type Standard.String, the most we handle for
3776 -- this case, or if more than one concatenation type is involved.
3782 -- The inner loop gathers concatenation operands. We gather any
3783 -- number of these in the non-string case, or if no concatenation
3784 -- routines are available for string (since in that case we will
3785 -- treat string like any other non-string case). Otherwise we only
3786 -- gather as many operands as can be handled by the available
3787 -- procedures in the run-time library (normally 5, but may be
3788 -- less for the configurable run-time case).
3792 or else
3794 or else
3796 Max_Available_String_Operands)
3799 loop
3804 -- Here we process the collected operands. First we convert
3805 -- singleton operands to singleton aggregates. This is skipped
3806 -- however for the case of two operands of type String, since
3807 -- we have special routines for these cases.
3813 or else not Char_Concat_Available
3814 then
3816 loop
3829 -- Now call appropriate continuation routine
3833 then
3835 else
3844 ------------------------
3845 -- Expand_N_Op_Divide --
3846 ------------------------
3854 begin
3857 -- Vax_Float is a special case
3864 -- N / 1 = N for integer types
3869 then
3874 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3875 -- Is_Power_Of_2_For_Shift is set means that we know that our left
3876 -- operand is an unsigned integer, as required for this to work.
3881 -- We cannot do this transformation in configurable run time mode if we
3882 -- have 64-bit -- integers and long shifts are not available.
3884 and then
3887 then
3891 Right_Opnd =>
3897 -- Do required fixup of universal fixed operation
3904 -- Divisions with fixed-point results
3908 -- No special processing if Treat_Fixed_As_Integer is set,
3909 -- since from a semantic point of view such operations are
3910 -- simply integer operations and will be treated that way.
3915 else
3920 -- Other cases of division of fixed-point operands. Again we
3921 -- exclude the case where Treat_Fixed_As_Integer is set.
3926 then
3929 else
3934 -- Mixed-mode operations can appear in a non-static universal
3935 -- context, in which case the integer argument must be converted
3936 -- explicitly.
3940 then
3948 then
3954 -- Non-fixed point cases, do zero divide and overflow checks
3959 -- Check for 64-bit division available
3962 and then not Support_64_Bit_Divides_On_Target
3963 then
3969 --------------------
3970 -- Expand_N_Op_Eq --
3971 --------------------
3986 -- If a constructed equality exists for the type or for its parent,
3987 -- build and analyze call, adding conversions if the operation is
3988 -- inherited.
3991 -- Determines whether a type has a subcompoment of an unconstrained
3992 -- Unchecked_Union subtype. Typ is a record type.
3994 -------------------------
3995 -- Build_Equality_Call --
3996 -------------------------
4003 begin
4006 then
4011 -- If we have an Unchecked_Union, we need to add the inferred
4012 -- discriminant values as actuals in the function call. At this
4013 -- point, the expansion has determined that both operands have
4014 -- inferable discriminants.
4017 declare
4023 begin
4024 -- Per-object constrained selected components require special
4025 -- attention. If the enclosing scope of the component is an
4026 -- Unchecked_Union, we can not reference its discriminants
4027 -- directly. This is why we use the two extra parameters of
4028 -- the equality function of the enclosing Unchecked_Union.
4030 -- type UU_Type (Discr : Integer := 0) is
4031 -- . . .
4032 -- end record;
4033 -- pragma Unchecked_Union (UU_Type);
4035 -- 1. Unchecked_Union enclosing record:
4037 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
4038 -- . . .
4039 -- Comp : UU_Type (Discr);
4040 -- . . .
4041 -- end Enclosing_UU_Type;
4042 -- pragma Unchecked_Union (Enclosing_UU_Type);
4044 -- Obj1 : Enclosing_UU_Type;
4045 -- Obj2 : Enclosing_UU_Type (1);
4047 -- [. . .] Obj1 = Obj2 [. . .]
4049 -- Generated code:
4051 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4053 -- A and B are the formal parameters of the equality function
4054 -- of Enclosing_UU_Type. The function always has two extra
4055 -- formals to capture the inferred discriminant values.
4057 -- 2. Non-Unchecked_Union enclosing record:
4059 -- type
4060 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
4061 -- is record
4062 -- . . .
4063 -- Comp : UU_Type (Discr);
4064 -- . . .
4065 -- end Enclosing_Non_UU_Type;
4067 -- Obj1 : Enclosing_Non_UU_Type;
4068 -- Obj2 : Enclosing_Non_UU_Type (1);
4070 -- ... Obj1 = Obj2 ...
4072 -- Generated code:
4074 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
4075 -- obj1.discr, obj2.discr)) then
4077 -- In this case we can directly reference the discriminants of
4078 -- the enclosing record.
4080 -- Lhs of equality
4083 and then Has_Per_Object_Constraint
4085 then
4086 -- Enclosing record is an Unchecked_Union, use formal A
4090 then
4091 Lhs_Discr_Val :=
4095 -- Enclosing record is of a non-Unchecked_Union type, it is
4096 -- possible to reference the discriminant.
4098 else
4099 Lhs_Discr_Val :=
4102 Selector_Name =>
4103 New_Copy
4104 (Get_Discriminant_Value
4106 Lhs_Type,
4110 -- Comment needed here ???
4112 else
4113 -- Infer the discriminant value
4115 Lhs_Discr_Val :=
4116 New_Copy
4117 (Get_Discriminant_Value
4119 Lhs_Type,
4123 -- Rhs of equality
4126 and then Has_Per_Object_Constraint
4128 then
4129 if Is_Unchecked_Union
4131 then
4132 Rhs_Discr_Val :=
4136 else
4137 Rhs_Discr_Val :=
4140 Selector_Name =>
4143 Rhs_Type,
4147 else
4148 Rhs_Discr_Val :=
4151 Rhs_Type,
4160 L_Exp,
4161 R_Exp,
4162 Lhs_Discr_Val,
4163 Rhs_Discr_Val)));
4166 -- Normal case, not an unchecked union
4168 else
4178 ------------------------------------
4179 -- Has_Unconstrained_UU_Component --
4180 ------------------------------------
4182 function Has_Unconstrained_UU_Component
4184 is
4190 function Component_Is_Unconstrained_UU
4192 -- Determines whether the subtype of the component is an
4193 -- unconstrained Unchecked_Union.
4195 function Variant_Is_Unconstrained_UU
4197 -- Determines whether a component of the variant has an unconstrained
4198 -- Unchecked_Union subtype.
4200 -----------------------------------
4201 -- Component_Is_Unconstrained_UU --
4202 -----------------------------------
4204 function Component_Is_Unconstrained_UU
4206 is
4207 begin
4212 declare
4216 begin
4217 -- Unconstrained nominal type. In the case of a constraint
4218 -- present, the node kind would have been N_Subtype_Indication.
4228 ---------------------------------
4229 -- Variant_Is_Unconstrained_UU --
4230 ---------------------------------
4232 function Variant_Is_Unconstrained_UU
4234 is
4237 begin
4242 declare
4245 begin
4248 -- One component is sufficent
4258 -- None of the components withing the variant were of
4259 -- unconstrained Unchecked_Union type.
4264 -- Start of processing for Has_Unconstrained_UU_Component
4266 begin
4274 -- Inspect available components
4277 declare
4280 begin
4283 -- One component is sufficent
4294 -- Inspect available components withing variants
4297 declare
4300 begin
4303 -- One component within a variant is sufficent
4314 -- Neither the available components, nor the components inside the
4315 -- variant parts were of an unconstrained Unchecked_Union subtype.
4320 -- Start of processing for Expand_N_Op_Eq
4322 begin
4332 -- It may happen in error situations that the underlying type is not
4333 -- set. The error will be detected later, here we just defend the
4334 -- expander code.
4342 -- Vax float types
4348 -- Boolean types (requiring handling of non-standard case)
4356 -- Array types
4360 -- If we are doing full validity checking, then expand out array
4361 -- comparisons to make sure that we check the array elements.
4364 declare
4366 Force_Validity_Checks;
4367 begin
4370 Expand_Array_Equality
4374 Bodies,
4375 Typl));
4381 -- Packed case where both operands are known aligned
4386 then
4389 -- Where the component type is elementary we can use a block bit
4390 -- comparison (if supported on the target) exception in the case
4391 -- of floating-point (negative zero issues require element by
4392 -- element comparison), and atomic types (where we must be sure
4393 -- to load elements independently) and possibly unaligned arrays.
4400 and then Support_Composite_Compare_On_Target
4401 then
4404 -- For composite and floating-point cases, expand equality loop
4405 -- to make sure of using proper comparisons for tagged types,
4406 -- and correctly handling the floating-point case.
4408 else
4410 Expand_Array_Equality
4414 Bodies,
4415 Typl));
4420 -- Record Types
4424 -- For tagged types, use the primitive "="
4428 -- If this is derived from an untagged private type completed
4429 -- with a tagged type, it does not have a full view, so we
4430 -- use the primitive operations of the private type.
4431 -- This check should no longer be necessary when these
4432 -- types receive their full views ???
4438 then
4439 -- Search for equality operation, checking that the
4440 -- operands have the same type. Note that we must find
4441 -- a matching entry, or something is very wrong!
4449 and then
4458 -- Find the type's predefined equality or an overriding
4459 -- user-defined equality. The reason for not simply calling
4460 -- Find_Prim_Op here is that there may be a user-defined
4461 -- overloaded equality op that precedes the equality that
4462 -- we want, so we have to explicitly search (e.g., there
4463 -- could be an equality with two different parameter types).
4465 else
4475 and then
4487 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
4488 -- predefined equality operator for a type which has a subcomponent
4489 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
4496 -- Prevent Gigi from generating incorrect code by rewriting the
4497 -- equality as a standard False.
4504 -- If we can infer the discriminants of the operands, we make a
4505 -- call to the TSS equality function.
4508 and then
4510 then
4511 Build_Equality_Call
4514 else
4515 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4516 -- the predefined equality operator for an Unchecked_Union type
4517 -- if either of the operands lack inferable discriminants.
4523 -- Prevent Gigi from generating incorrect code by rewriting
4524 -- the equality as a standard False.
4531 -- If a type support function is present (for complex cases), use it
4534 Build_Equality_Call
4537 -- Otherwise expand the component by component equality. Note that
4538 -- we never use block-bit coparisons for records, because of the
4539 -- problems with gaps. The backend will often be able to recombine
4540 -- the separate comparisons that we generate here.
4542 else
4553 -- If we still have an equality comparison (i.e. it was not rewritten
4554 -- in some way), then we can test if result is needed at compile time).
4561 -----------------------
4562 -- Expand_N_Op_Expon --
4563 -----------------------
4581 begin
4584 -- If either operand is of a private type, then we have the use of
4585 -- an intrinsic operator, and we get rid of the privateness, by using
4586 -- root types of underlying types for the actual operation. Otherwise
4587 -- the private types will cause trouble if we expand multiplications
4588 -- or shifts etc. We also do this transformation if the result type
4589 -- is different from the base type.
4592 or else
4594 or else
4596 or else
4598 then
4599 declare
4603 begin
4614 -- Test for case of known right argument
4619 -- We only fold small non-negative exponents. You might think we
4620 -- could fold small negative exponents for the real case, but we
4621 -- can't because we are required to raise Constraint_Error for
4622 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
4623 -- See ACVC test C4A012B.
4627 -- X ** 0 = 1 (or 1.0)
4632 else
4636 -- X ** 1 = X
4641 -- X ** 2 = X * X
4644 Xnode :=
4649 -- X ** 3 = X * X * X
4652 Xnode :=
4654 Left_Opnd =>
4660 -- X ** 4 ->
4661 -- En : constant base'type := base * base;
4662 -- ...
4663 -- En * En
4666 Temp :=
4674 Expression =>
4679 Xnode :=
4691 -- Case of (2 ** expression) appearing as an argument of an integer
4692 -- multiplication, or as the right argument of a division of a non-
4693 -- negative integer. In such cases we leave the node untouched, setting
4694 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
4695 -- of the higher level node converts it into a shift.
4702 and then not Ovflo
4704 then
4705 declare
4710 begin
4712 and then
4714 or else
4718 or else
4724 then
4731 -- Fall through if exponentiation must be done using a runtime routine
4733 -- First deal with modular case
4737 -- Non-binary case, we call the special exponentiation routine for
4738 -- the non-binary case, converting the argument to Long_Long_Integer
4739 -- and passing the modulus value. Then the result is converted back
4740 -- to the base type.
4750 Exp))));
4752 -- Binary case, in this case, we call one of two routines, either
4753 -- the unsigned integer case, or the unsigned long long integer
4754 -- case, with a final "and" operation to do the required mod.
4756 else
4759 else
4766 Left_Opnd =>
4771 Exp)),
4772 Right_Opnd =>
4777 -- Common exit point for modular type case
4782 -- Signed integer cases, done using either Integer or Long_Long_Integer.
4783 -- It is not worth having routines for Short_[Short_]Integer, since for
4784 -- most machines it would not help, and it would generate more code that
4785 -- might need certification in the HI-E case.
4787 -- In the integer cases, we have two routines, one for when overflow
4788 -- checks are required, and one when they are not required, since
4789 -- there is a real gain in ommitting checks on many machines.
4793 and then
4796 then
4801 else
4810 else
4814 -- Floating-point cases, always done using Long_Long_Float. We do not
4815 -- need separate routines for the overflow case here, since in the case
4816 -- of floating-point, we generate infinities anyway as a rule (either
4817 -- that or we automatically trap overflow), and if there is an infinity
4818 -- generated and a range check is required, the check will fail anyway.
4820 else
4826 -- Common processing for integer cases and floating-point cases.
4827 -- If we are in the right type, we can call runtime routine directly
4832 then
4838 -- Otherwise we have to introduce conversions (conversions are also
4839 -- required in the universal cases, since the runtime routine is
4840 -- typed using one of the standard types.
4842 else
4849 Exp))));
4855 exception
4860 --------------------
4861 -- Expand_N_Op_Ge --
4862 --------------------
4870 begin
4892 --------------------
4893 -- Expand_N_Op_Gt --
4894 --------------------
4902 begin
4924 --------------------
4925 -- Expand_N_Op_Le --
4926 --------------------
4934 begin
4956 --------------------
4957 -- Expand_N_Op_Lt --
4958 --------------------
4966 begin
4988 -----------------------
4989 -- Expand_N_Op_Minus --
4990 -----------------------
4996 begin
4999 if not Backend_Overflow_Checks_On_Target
5002 then
5003 -- Software overflow checking expands -expr into (0 - expr)
5012 -- Vax floating-point types case
5019 ---------------------
5020 -- Expand_N_Op_Mod --
5021 ---------------------
5039 begin
5045 -- Convert mod to rem if operands are known non-negative. We do this
5046 -- since it is quite likely that this will improve the quality of code,
5047 -- (the operation now corresponds to the hardware remainder), and it
5048 -- does not seem likely that it could be harmful.
5051 and then
5053 then
5059 -- Instead of reanalyzing the node we do the analysis manually.
5060 -- This avoids anomalies when the replacement is done in an
5061 -- instance and is epsilon more efficient.
5070 -- Otherwise, normal mod processing
5072 else
5077 -- Apply optimization x mod 1 = 0. We don't really need that with
5078 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5079 -- certainly harmless.
5084 then
5090 -- Deal with annoying case of largest negative number remainder
5091 -- minus one. Gigi does not handle this case correctly, because
5092 -- it generates a divide instruction which may trap in this case.
5094 -- In fact the check is quite easy, if the right operand is -1,
5095 -- then the mod value is always 0, and we can just ignore the
5096 -- left operand completely in this case.
5098 -- The operand type may be private (e.g. in the expansion of an
5099 -- an intrinsic operation) so we must use the underlying type to
5100 -- get the bounds, and convert the literals explicitly.
5102 LLB :=
5103 Expr_Value
5107 and then
5109 then
5115 Right_Opnd =>
5128 --------------------------
5129 -- Expand_N_Op_Multiply --
5130 --------------------------
5149 begin
5152 -- Special optimizations for integer types
5156 -- N * 0 = 0 * N = 0 for integer types
5160 or else
5163 then
5169 -- N * 1 = 1 * N = N for integer types
5171 -- This optimisation is not done if we are going to
5172 -- rewrite the product 1 * 2 ** N to a shift.
5176 and then not Lp2
5177 then
5183 and then not Rp2
5184 then
5190 -- Deal with VAX float case
5197 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5198 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5199 -- operand is an integer, as required for this to work.
5204 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
5209 Right_Opnd =>
5216 else
5220 Right_Opnd =>
5226 -- Same processing for the operands the other way round
5232 Right_Opnd =>
5238 -- Do required fixup of universal fixed operation
5245 -- Multiplications with fixed-point results
5249 -- No special processing if Treat_Fixed_As_Integer is set,
5250 -- since from a semantic point of view such operations are
5251 -- simply integer operations and will be treated that way.
5255 -- Case of fixed * integer => fixed
5260 -- Case of integer * fixed => fixed
5265 -- Case of fixed * fixed => fixed
5267 else
5272 -- Other cases of multiplication of fixed-point operands. Again
5273 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
5277 then
5280 else
5285 -- Mixed-mode operations can appear in a non-static universal
5286 -- context, in which case the integer argument must be converted
5287 -- explicitly.
5291 then
5298 then
5303 -- Non-fixed point cases, check software overflow checking required
5310 --------------------
5311 -- Expand_N_Op_Ne --
5312 --------------------
5314 -- Rewrite node as the negation of an equality operation, and reanalyze.
5315 -- The equality to be used is defined in the same scope and has the same
5316 -- signature. It must be set explicitly because in an instance it may not
5317 -- have the same visibility as in the generic unit.
5324 begin
5327 Neg :=
5329 Right_Opnd =>
5339 -- For navigation purposes, the inequality is treated as an implicit
5340 -- reference to the corresponding equality. Preserve the Comes_From_
5341 -- source flag so that the proper Xref entry is generated.
5349 ---------------------
5350 -- Expand_N_Op_Not --
5351 ---------------------
5353 -- If the argument is other than a Boolean array type, there is no
5354 -- special expansion required.
5356 -- For the packed case, we call the special routine in Exp_Pakd, except
5357 -- that if the component size is greater than one, we use the standard
5358 -- routine generating a gruesome loop (it is so peculiar to have packed
5359 -- arrays with non-standard Boolean representations anyway, so it does
5360 -- not matter that we do not handle this case efficiently).
5362 -- For the unpacked case (and for the special packed case where we have
5363 -- non standard Booleans, as discussed above), we generate and insert
5364 -- into the tree the following function definition:
5366 -- function Nnnn (A : arr) is
5367 -- B : arr;
5368 -- begin
5369 -- for J in a'range loop
5370 -- B (J) := not A (J);
5371 -- end loop;
5372 -- return B;
5373 -- end Nnnn;
5375 -- Here arr is the actual subtype of the parameter (and hence always
5376 -- constrained). Then we replace the not with a call to this function.
5392 begin
5395 -- For boolean operand, deal with non-standard booleans
5404 -- Only array types need any other processing
5410 -- Case of array operand. If bit packed with a component size of 1,
5411 -- handle it in Exp_Pakd if the operand is known to be aligned.
5416 then
5421 -- Case of array operand which is not bit-packed. If the context is
5422 -- a safe assignment, call in-place operation, If context is a larger
5423 -- boolean expression in the context of a safe assignment, expansion is
5424 -- done by enclosing operation.
5436 -- Special case the negation of a binary operation
5441 and then Safe_In_Place_Array_Op
5443 then
5450 then
5451 declare
5456 begin
5460 then
5461 -- (not A) op (not B) can be reduced to a single call
5467 then
5468 -- A xor (not B) can also be special-cased
5480 A_J :=
5485 B_J :=
5490 Loop_Statement :=
5494 Iteration_Scheme =>
5496 Loop_Parameter_Specification =>
5499 Discrete_Subtype_Definition =>
5514 Specification =>
5528 Handled_Statement_Sequence =>
5531 Loop_Statement,
5533 Expression =>
5544 --------------------
5545 -- Expand_N_Op_Or --
5546 --------------------
5551 begin
5565 ----------------------
5566 -- Expand_N_Op_Plus --
5567 ----------------------
5570 begin
5574 ---------------------
5575 -- Expand_N_Op_Rem --
5576 ---------------------
5593 begin
5600 -- Apply optimization x rem 1 = 0. We don't really need that with
5601 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5602 -- certainly harmless.
5607 then
5613 -- Deal with annoying case of largest negative number remainder
5614 -- minus one. Gigi does not handle this case correctly, because
5615 -- it generates a divide instruction which may trap in this case.
5617 -- In fact the check is quite easy, if the right operand is -1,
5618 -- then the remainder is always 0, and we can just ignore the
5619 -- left operand completely in this case.
5624 -- The operand type may be private (e.g. in the expansion of an
5625 -- an intrinsic operation) so we must use the underlying type to
5626 -- get the bounds, and convert the literals explicitly.
5628 LLB :=
5629 Expr_Value
5632 -- Now perform the test, generating code only if needed
5635 and then
5637 then
5643 Right_Opnd =>
5657 -----------------------------
5658 -- Expand_N_Op_Rotate_Left --
5659 -----------------------------
5662 begin
5666 ------------------------------
5667 -- Expand_N_Op_Rotate_Right --
5668 ------------------------------
5671 begin
5675 ----------------------------
5676 -- Expand_N_Op_Shift_Left --
5677 ----------------------------
5680 begin
5684 -----------------------------
5685 -- Expand_N_Op_Shift_Right --
5686 -----------------------------
5689 begin
5693 ----------------------------------------
5694 -- Expand_N_Op_Shift_Right_Arithmetic --
5695 ----------------------------------------
5698 begin
5702 --------------------------
5703 -- Expand_N_Op_Subtract --
5704 --------------------------
5709 begin
5712 -- N - 0 = N for integer types
5717 then
5722 -- Arithemtic overflow checks for signed integer/fixed point types
5726 then
5729 -- Vax floating-point types case
5736 ---------------------
5737 -- Expand_N_Op_Xor --
5738 ---------------------
5743 begin
5757 ----------------------
5758 -- Expand_N_Or_Else --
5759 ----------------------
5761 -- Expand into conditional expression if Actions present, and also
5762 -- deal with optimizing case of arguments being True or False.
5771 begin
5772 -- Deal with non-standard booleans
5780 -- Check for cases of left argument is True or False
5784 -- If left argument is False, change (False or else Right) to Right.
5785 -- Any actions associated with Right will be executed unconditionally
5786 -- and can thus be inserted into the tree unconditionally.
5797 -- If left argument is True, change (True and then Right) to
5798 -- True. In this case we can forget the actions associated with
5799 -- Right, since they will never be executed.
5810 -- If Actions are present, we expand
5812 -- left or else right
5814 -- into
5816 -- if left then True else right end
5818 -- with the actions becoming the Else_Actions of the conditional
5819 -- expression. This conditional expression is then further expanded
5820 -- (and will eventually disappear)
5827 Left,
5829 Right)));
5837 -- No actions present, check for cases of right argument True/False
5841 -- Change (Left or else False) to Left. Note that we know there
5842 -- are no actions associated with the True operand, since we
5843 -- just checked for this case above.
5848 -- Change (Left or else True) to True, making sure to preserve
5849 -- any side effects associated with the Left operand.
5853 Rewrite
5861 -----------------------------------
5862 -- Expand_N_Qualified_Expression --
5863 -----------------------------------
5869 begin
5873 ---------------------------------
5874 -- Expand_N_Selected_Component --
5875 ---------------------------------
5877 -- If the selector is a discriminant of a concurrent object, rewrite the
5878 -- prefix to denote the corresponding record type.
5890 -- Gigi needs a temporary for prefixes that depend on a discriminant,
5891 -- unless the context of an assignment can provide size information.
5892 -- Don't we have a general routine that does this???
5894 -----------------------
5895 -- In_Left_Hand_Side --
5896 -----------------------
5899 begin
5907 -- Start of processing for Expand_N_Selected_Component
5909 begin
5910 -- Insert explicit dereference if required
5918 then
5925 -- Deal with discriminant check required
5929 -- Present the discrminant checking function to the backend,
5930 -- so that it can inline the call to the function.
5932 Add_Inlined_Body
5933 (Discriminant_Checking_Func
5936 -- Now reset the flag and generate the call
5942 -- Gigi cannot handle unchecked conversions that are the prefix of a
5943 -- selected component with discriminants. This must be checked during
5944 -- expansion, because during analysis the type of the selector is not
5945 -- known at the point the prefix is analyzed. If the conversion is the
5946 -- target of an assignment, then we cannot force the evaluation.
5951 then
5955 -- Remaining processing applies only if selector is a discriminant
5959 -- If the selector is a discriminant of a constrained record type,
5960 -- we may be able to rewrite the expression with the actual value
5961 -- of the discriminant, a useful optimization in some cases.
5966 then
5967 -- Do this optimization for discrete types only, and not for
5968 -- access types (access discriminants get us into trouble!)
5973 -- Don't do this on the left hand of an assignment statement.
5974 -- Normally one would think that references like this would
5975 -- not occur, but they do in generated code, and mean that
5976 -- we really do want to assign the discriminant!
5980 then
5983 -- Don't do this optimization for the prefix of an attribute
5984 -- or the operand of an object renaming declaration since these
5985 -- are contexts where we do not want the value anyway.
5990 then
5993 -- Don't do this optimization if we are within the code for a
5994 -- discriminant check, since the whole point of such a check may
5995 -- be to verify the condition on which the code below depends!
6000 -- Green light to see if we can do the optimization. There is
6001 -- still one condition that inhibits the optimization below
6002 -- but now is the time to check the particular discriminant.
6004 else
6005 -- Loop through discriminants to find the matching
6006 -- discriminant constraint to see if we can copy it.
6012 -- Check if this is the matching discriminant
6016 -- Here we have the matching discriminant. Check for
6017 -- the case of a discriminant of a component that is
6018 -- constrained by an outer discriminant, which cannot
6019 -- be optimized away.
6021 if
6022 Denotes_Discriminant
6024 then
6027 -- In the context of a case statement, the expression
6028 -- may have the base type of the discriminant, and we
6029 -- need to preserve the constraint to avoid spurious
6030 -- errors on missing cases.
6034 then
6037 Subtype_Mark =>
6039 Expression =>
6043 -- In case that comes out as a static expression,
6044 -- reset it (a selected component is never static).
6049 -- Otherwise we can just copy the constraint, but the
6050 -- result is certainly not static! In some cases the
6051 -- discriminant constraint has been analyzed in the
6052 -- context of the original subtype indication, but for
6053 -- itypes the constraint might not have been analyzed
6054 -- yet, and this must be done now.
6056 else
6068 -- Note: the above loop should always find a matching
6069 -- discriminant, but if it does not, we just missed an
6070 -- optimization due to some glitch (perhaps a previous
6071 -- error), so ignore.
6076 -- The only remaining processing is in the case of a discriminant of
6077 -- a concurrent object, where we rewrite the prefix to denote the
6078 -- corresponding record type. If the type is derived and has renamed
6079 -- discriminants, use corresponding discriminant, which is the one
6080 -- that appears in the corresponding record.
6090 then
6094 New_N :=
6096 Prefix =>
6106 --------------------
6107 -- Expand_N_Slice --
6108 --------------------
6117 -- Check whether the argument is an actual for a procedure call,
6118 -- in which case the expansion of a bit-packed slice is deferred
6119 -- until the call itself is expanded. The reason this is required
6120 -- is that we might have an IN OUT or OUT parameter, and the copy out
6121 -- is essential, and that copy out would be missed if we created a
6122 -- temporary here in Expand_N_Slice. Note that we don't bother
6123 -- to test specifically for an IN OUT or OUT mode parameter, since it
6124 -- is a bit tricky to do, and it is harmless to defer expansion
6125 -- in the IN case, since the call processing will still generate the
6126 -- appropriate copy in operation, which will take care of the slice.
6129 -- Create a named variable for the value of the slice, in
6130 -- cases where the back-end cannot handle it properly, e.g.
6131 -- when packed types or unaligned slices are involved.
6133 -------------------------
6134 -- Is_Procedure_Actual --
6135 -------------------------
6140 begin
6141 loop
6142 -- If our parent is a procedure call we can return
6147 -- If our parent is a type conversion, keep climbing the
6148 -- tree, since a type conversion can be a procedure actual.
6149 -- Also keep climbing if parameter association or a qualified
6150 -- expression, since these are additional cases that do can
6151 -- appear on procedure actuals.
6156 then
6159 -- Any other case is not what we are looking for
6161 else
6167 --------------------
6168 -- Make_Temporary --
6169 --------------------
6175 begin
6176 Decl :=
6184 Decl,
6193 -- Start of processing for Expand_N_Slice
6195 begin
6196 -- Special handling for access types
6209 -- Range checks are potentially also needed for cases involving
6210 -- a slice indexed by a subtype indication, but Do_Range_Check
6211 -- can currently only be set for expressions ???
6217 then
6221 -- The remaining case to be handled is packed slices. We can leave
6222 -- packed slices as they are in the following situations:
6224 -- 1. Right or left side of an assignment (we can handle this
6225 -- situation correctly in the assignment statement expansion).
6227 -- 2. Prefix of indexed component (the slide is optimized away
6228 -- in this case, see the start of Expand_N_Slice.
6230 -- 3. Object renaming declaration, since we want the name of
6231 -- the slice, not the value.
6233 -- 4. Argument to procedure call, since copy-in/copy-out handling
6234 -- may be required, and this is handled in the expansion of
6235 -- call itself.
6237 -- 5. Prefix of an address attribute (this is an error which
6238 -- is caught elsewhere, and the expansion would intefere
6239 -- with generating the error message).
6243 -- Apply transformation for actuals of a function call,
6244 -- where Expand_Actuals is not used.
6248 then
6249 Make_Temporary;
6255 then
6261 then
6266 then
6269 else
6270 Make_Temporary;
6274 ------------------------------
6275 -- Expand_N_Type_Conversion --
6276 ------------------------------
6285 -- This is called in the case of record and array type conversions
6286 -- to see if there is a change of representation to be handled.
6287 -- Change of representation is actually handled at the assignment
6288 -- statement level, and what this procedure does is rewrite node N
6289 -- conversion as an assignment to temporary. If there is no change
6290 -- of representation, then the conversion node is unchanged.
6293 -- Handles generation of range check for real target value
6295 -----------------------------------
6296 -- Handle_Changed_Representation --
6297 -----------------------------------
6307 begin
6308 -- Nothing to do if no change of representation
6313 -- The real change of representation work is done by the assignment
6314 -- statement processing. So if this type conversion is appearing as
6315 -- the expression of an assignment statement, nothing needs to be
6316 -- done to the conversion.
6321 -- Otherwise we need to generate a temporary variable, and do the
6322 -- change of representation assignment into that temporary variable.
6323 -- The conversion is then replaced by a reference to this variable.
6325 else
6328 -- If type is unconstrained we have to add a constraint,
6329 -- copied from the actual value of the left hand side.
6344 Selector_Name =>
6355 -- We convert the bounds explicitly. We use an unchecked
6356 -- conversion because bounds checks are done elsewhere.
6360 Low_Bound =>
6363 Prefix =>
6364 Duplicate_Subexpr_No_Checks
6370 High_Bound =>
6373 Prefix =>
6374 Duplicate_Subexpr_No_Checks
6388 Odef :=
6391 Constraint =>
6397 Decl :=
6404 -- Insert required actions. It is essential to suppress checks
6405 -- since we have suppressed default initialization, which means
6406 -- that the variable we create may have no discriminants.
6409 New_List (
6410 Decl,
6421 ----------------------
6422 -- Real_Range_Check --
6423 ----------------------
6425 -- Case of conversions to floating-point or fixed-point. If range
6426 -- checks are enabled and the target type has a range constraint,
6427 -- we convert:
6429 -- typ (x)
6431 -- to
6433 -- Tnn : typ'Base := typ'Base (x);
6434 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
6435 -- Tnn
6437 -- This is necessary when there is a conversion of integer to float
6438 -- or to fixed-point to ensure that the correct checks are made. It
6439 -- is not necessary for float to float where it is enough to simply
6440 -- set the Do_Range_Check flag.
6450 begin
6451 -- Nothing to do if conversion was rewritten
6457 -- Nothing to do if range checks suppressed, or target has the
6458 -- same range as the base type (or is the base type).
6462 and then
6464 then
6468 -- Nothing to do if expression is an entity on which checks
6469 -- have been suppressed.
6473 then
6477 -- Nothing to do if bounds are all static and we can tell that
6478 -- the expression is within the bounds of the target. Note that
6479 -- if the operand is of an unconstrained floating-point type,
6480 -- then we do not trust it to be in range (might be infinite)
6482 declare
6486 begin
6493 then
6494 declare
6500 begin
6504 else
6512 then
6520 -- For float to float conversions, we are done
6523 and then
6525 then
6529 -- Otherwise rewrite the conversion as described above
6532 Rewrite
6536 -- Enable overflow except in the case of integer to float
6537 -- conversions, where it is never required, since we can
6538 -- never have overflow in this case.
6544 Tnn :=
6555 Condition =>
6557 Left_Opnd =>
6560 Right_Opnd =>
6563 Prefix =>
6566 Right_Opnd =>
6569 Right_Opnd =>
6572 Prefix =>
6580 -- Start of processing for Expand_N_Type_Conversion
6582 begin
6583 -- Nothing at all to do if conversion is to the identical type
6584 -- so remove the conversion completely, it is useless.
6591 -- Deal with Vax floating-point cases
6598 -- Nothing to do if this is the second argument of read. This
6599 -- is a "backwards" conversion that will be handled by the
6600 -- specialized code in attribute processing.
6605 then
6609 -- Here if we may need to expand conversion
6611 -- Special case of converting from non-standard boolean type
6615 then
6621 -- Case of converting to an access type
6625 -- Apply an accessibility check if the operand is an
6626 -- access parameter. Note that other checks may still
6627 -- need to be applied below (such as tagged type checks).
6632 then
6635 -- If the level of the operand type is statically deeper
6636 -- then the level of the target type, then force Program_Error.
6637 -- Note that this can only occur for cases where the attribute
6638 -- is within the body of an instantiation (otherwise the
6639 -- conversion will already have been rejected as illegal).
6640 -- Note: warnings are issued by the analyzer for the instance
6641 -- cases.
6643 elsif In_Instance_Body
6646 then
6652 -- When the operand is a selected access discriminant
6653 -- the check needs to be made against the level of the
6654 -- object denoted by the prefix of the selected name.
6655 -- Force Program_Error for this case as well (this
6656 -- accessibility violation can only happen if within
6657 -- the body of an instantiation).
6659 elsif In_Instance_Body
6664 then
6672 -- Case of conversions of tagged types and access to tagged types
6674 -- When needed, that is to say when the expression is class-wide,
6675 -- Add runtime a tag check for (strict) downward conversion by using
6676 -- the membership test, generating:
6678 -- [constraint_error when Operand not in Target_Type'Class]
6680 -- or in the access type case
6682 -- [constraint_error
6683 -- when Operand /= null
6684 -- and then Operand.all not in
6685 -- Designated_Type (Target_Type)'Class]
6690 then
6691 -- Do not do any expansion in the access type case if the
6692 -- parent is a renaming, since this is an error situation
6693 -- which will be caught by Sem_Ch8, and the expansion can
6694 -- intefere with this error check.
6698 then
6702 -- Oherwise, proceed with processing tagged conversion
6704 declare
6710 begin
6715 else
6722 and then Is_Ancestor
6724 Actual_Target_Type)
6726 then
6727 -- The conversion is valid for any descendant of the
6728 -- target type
6733 Cond :=
6735 Left_Opnd =>
6740 Right_Opnd =>
6742 Left_Opnd =>
6744 Prefix =>
6746 Right_Opnd =>
6749 else
6750 Cond :=
6753 Right_Opnd =>
6762 declare
6764 begin
6765 Conv :=
6775 -- Case of other access type conversions
6780 -- Case of conversions from a fixed-point type
6782 -- These conversions require special expansion and processing, found
6783 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
6784 -- set, since from a semantic point of view, these are simple integer
6785 -- conversions, which do not need further processing.
6789 then
6790 -- We should never see universal fixed at this case, since the
6791 -- expansion of the constituent divide or multiply should have
6792 -- eliminated the explicit mention of universal fixed.
6796 -- Check for special case of the conversion to universal real
6797 -- that occurs as a result of the use of a round attribute.
6798 -- In this case, the real type for the conversion is taken
6799 -- from the target type of the Round attribute and the
6800 -- result must be marked as rounded.
6805 then
6810 -- Otherwise do correct fixed-conversion, but skip these if the
6811 -- Conversion_OK flag is set, because from a semantic point of
6812 -- view these are simple integer conversions needing no further
6813 -- processing (the backend will simply treat them as integers)
6818 Real_Range_Check;
6823 else
6826 Real_Range_Check;
6830 -- Case of conversions to a fixed-point type
6832 -- These conversions require special expansion and processing, found
6833 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6834 -- is set, since from a semantic point of view, these are simple
6835 -- integer conversions, which do not need further processing.
6839 then
6842 Real_Range_Check;
6843 else
6846 Real_Range_Check;
6849 -- Case of float-to-integer conversions
6851 -- We also handle float-to-fixed conversions with Conversion_OK set
6852 -- since semantically the fixed-point target is treated as though it
6853 -- were an integer in such cases.
6856 and then
6858 or else
6860 then
6861 -- Special processing required if the conversion is the expression
6862 -- of a Truncation attribute reference. In this case we replace:
6864 -- ityp (ftyp'Truncation (x))
6866 -- by
6868 -- ityp (x)
6870 -- with the Float_Truncate flag set. This is clearly more efficient
6874 then
6880 -- One more check here, gcc is still not able to do conversions of
6881 -- this type with proper overflow checking, and so gigi is doing an
6882 -- approximation of what is required by doing floating-point compares
6883 -- with the end-point. But that can lose precision in some cases, and
6884 -- give a wrong result. Converting the operand to Long_Long_Float is
6885 -- helpful, but still does not catch all cases with 64-bit integers
6886 -- on targets with only 64-bit floats ???
6891 Subtype_Mark =>
6893 Expression =>
6901 -- Case of array conversions
6903 -- Expansion of array conversions, add required length/range checks
6904 -- but only do this if there is no change of representation. For
6905 -- handling of this case, see Handle_Changed_Representation.
6911 else
6915 Handle_Changed_Representation;
6917 -- Case of conversions of discriminated types
6919 -- Add required discriminant checks if target is constrained. Again
6920 -- this change is skipped if we have a change of representation.
6924 then
6926 Handle_Changed_Representation;
6928 -- Case of all other record conversions. The only processing required
6929 -- is to check for a change of representation requiring the special
6930 -- assignment processing.
6934 -- Ada 2005 (AI-216): Program_Error is raised when converting from
6935 -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
6936 -- Union type if the operand lacks inferable discriminants.
6943 then
6944 -- To prevent Gigi from generating illegal code, we make a
6945 -- Program_Error node, but we give it the target type of the
6946 -- conversion.
6948 declare
6952 begin
6957 else
6958 Handle_Changed_Representation;
6961 -- Case of conversions of enumeration types
6965 -- Special processing is required if there is a change of
6966 -- representation (from enumeration representation clauses)
6970 -- Convert: x(y) to x'val (ytyp'val (y))
6985 -- Case of conversions to floating-point
6988 Real_Range_Check;
6990 -- The remaining cases require no front end processing
6992 else
6996 -- At this stage, either the conversion node has been transformed
6997 -- into some other equivalent expression, or left as a conversion
6998 -- that can be handled by Gigi. The conversions that Gigi can handle
6999 -- are the following:
7001 -- Conversions with no change of representation or type
7003 -- Numeric conversions involving integer values, floating-point
7004 -- values, and fixed-point values. Fixed-point values are allowed
7005 -- only if Conversion_OK is set, i.e. if the fixed-point values
7006 -- are to be treated as integers.
7008 -- No other conversions should be passed to Gigi
7010 -- Check: are these rules stated in sinfo??? if so, why restate here???
7012 -- The only remaining step is to generate a range check if we still
7013 -- have a type conversion at this stage and Do_Range_Check is set.
7014 -- For now we do this only for conversions of discrete types.
7018 then
7019 declare
7024 begin
7027 then
7030 -- Before we do a range check, we have to deal with treating
7031 -- a fixed-point operand as an integer. The way we do this
7032 -- is simply to do an unchecked conversion to an appropriate
7033 -- integer type large enough to hold the result.
7035 -- This code is not active yet, because we are only dealing
7036 -- with discrete types so far ???
7040 then
7045 else
7052 -- Reset overflow flag, since the range check will include
7053 -- dealing with possible overflow, and generate the check
7054 -- If Address is either source or target type, suppress
7055 -- range check to avoid typing anomalies when it is a visible
7056 -- integer type.
7061 then
7062 Generate_Range_Check
7070 -----------------------------------
7071 -- Expand_N_Unchecked_Expression --
7072 -----------------------------------
7074 -- Remove the unchecked expression node from the tree. It's job was simply
7075 -- to make sure that its constituent expression was handled with checks
7076 -- off, and now that that is done, we can remove it from the tree, and
7077 -- indeed must, since gigi does not expect to see these nodes.
7082 begin
7087 ----------------------------------------
7088 -- Expand_N_Unchecked_Type_Conversion --
7089 ----------------------------------------
7091 -- If this cannot be handled by Gigi and we haven't already made
7092 -- a temporary for it, do it now.
7099 begin
7100 -- If we have a conversion of a compile time known value to a target
7101 -- type and the value is in range of the target type, then we can simply
7102 -- replace the construct by an integer literal of the correct type. We
7103 -- only apply this to integer types being converted. Possibly it may
7104 -- apply in other cases, but it is too much trouble to worry about.
7106 -- Note that we do not do this transformation if the Kill_Range_Check
7107 -- flag is set, since then the value may be outside the expected range.
7108 -- This happens in the Normalize_Scalars case.
7114 then
7115 declare
7118 begin
7120 and then
7122 and then
7124 and then
7126 then
7129 -- If Address is the target type, just set the type
7130 -- to avoid a spurious type error on the literal when
7131 -- Address is a visible integer type.
7135 else
7144 -- Nothing to do if conversion is safe
7150 -- Otherwise force evaluation unless Assignment_OK flag is set (this
7151 -- flag indicates ??? -- more comments needed here)
7155 else
7160 ----------------------------
7161 -- Expand_Record_Equality --
7162 ----------------------------
7164 -- For non-variant records, Equality is expanded when needed into:
7166 -- and then Lhs.Discr1 = Rhs.Discr1
7167 -- and then ...
7168 -- and then Lhs.Discrn = Rhs.Discrn
7169 -- and then Lhs.Cmp1 = Rhs.Cmp1
7170 -- and then ...
7171 -- and then Lhs.Cmpn = Rhs.Cmpn
7173 -- The expression is folded by the back-end for adjacent fields. This
7174 -- function is called for tagged record in only one occasion: for imple-
7175 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
7176 -- otherwise the primitive "=" is used directly.
7178 function Expand_Record_Equality
7184 is
7193 -- Return the first field to compare beginning with C, skipping the
7194 -- inherited components.
7196 ----------------------
7197 -- Suitable_Element --
7198 ----------------------
7201 begin
7207 then
7212 then
7217 then
7220 else
7225 -- Start of processing for Expand_Record_Equality
7227 begin
7228 -- Generates the following code: (assuming that Typ has one Discr and
7229 -- component C2 is also a record)
7231 -- True
7232 -- and then Lhs.Discr1 = Rhs.Discr1
7233 -- and then Lhs.C1 = Rhs.C1
7234 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
7235 -- and then ...
7236 -- and then Lhs.Cmpn = Rhs.Cmpn
7242 declare
7247 begin
7252 else
7257 Check :=
7259 Lhs =>
7263 Rhs =>
7269 -- If some (sub)component is an unchecked_union, the whole
7270 -- operation will raise program error.
7276 else
7277 Result :=
7290 -------------------------------------
7291 -- Fixup_Universal_Fixed_Operation --
7292 -------------------------------------
7297 begin
7298 -- We must have a type conversion immediately above us
7302 -- Normally the type conversion gives our target type. The exception
7303 -- occurs in the case of the Round attribute, where the conversion
7304 -- will be to universal real, and our real type comes from the Round
7305 -- attribute (as well as an indication that we must round the result)
7309 then
7313 -- Normal case where type comes from conversion above us
7315 else
7320 ------------------------------
7321 -- Get_Allocator_Final_List --
7322 ------------------------------
7324 function Get_Allocator_Final_List
7328 is
7332 -- The entity whose finalisation list must be used to attach the
7333 -- allocated object.
7335 begin
7338 in N_Subprogram_Specification
7339 then
7340 -- If the context is an access parameter, we need to create
7341 -- a non-anonymous access type in order to have a usable
7342 -- final list, because there is otherwise no pool to which
7343 -- the allocated object can belong. We create both the type
7344 -- and the finalization chain here, because freezing an
7345 -- internal type does not create such a chain. The Final_Chain
7346 -- that is thus created is shared by the access parameter.
7352 Type_Definition =>
7354 Subtype_Indication =>
7360 else
7361 -- Case of an access discriminant, or (Ada 2005) of
7362 -- an anonymous access component: find the final list
7363 -- associated with the scope of the type.
7372 ---------------------------------
7373 -- Has_Inferable_Discriminants --
7374 ---------------------------------
7379 -- Determines whether the left-most prefix of a selected component is a
7380 -- formal parameter in a subprogram. Assumes N is a selected component.
7382 --------------------------------
7383 -- Prefix_Is_Formal_Parameter --
7384 --------------------------------
7389 begin
7390 -- Move to the left-most prefix by climbing up the tree
7394 loop
7401 -- Start of processing for Has_Inferable_Discriminants
7403 begin
7404 -- For identifiers and indexed components, it is sufficent to have a
7405 -- constrained Unchecked_Union nominal subtype.
7408 or else
7410 then
7412 and then
7415 -- For selected components, the subtype of the selector must be a
7416 -- constrained Unchecked_Union. If the component is subject to a
7417 -- per-object constraint, then the enclosing object must have inferable
7418 -- discriminants.
7423 -- A small hack. If we have a per-object constrained selected
7424 -- component of a formal parameter, return True since we do not
7425 -- know the actual parameter association yet.
7431 -- Otherwise, check the enclosing object and the selector
7434 and then
7438 -- The call to Has_Inferable_Discriminants will determine whether
7439 -- the selector has a constrained Unchecked_Union nominal type.
7443 -- A qualified expression has inferable discriminants if its subtype
7444 -- mark is a constrained Unchecked_Union subtype.
7448 and then
7456 -------------------------------
7457 -- Insert_Dereference_Action --
7458 -------------------------------
7467 -- Return true if type of P is derived from Checked_Pool;
7469 -----------------------------
7470 -- Is_Checked_Storage_Pool --
7471 -----------------------------
7476 begin
7485 else
7493 -- Start of processing for Insert_Dereference_Action
7495 begin
7500 then
7511 -- Pool
7515 -- Storage_Address. We use the attribute Pool_Address,
7516 -- which uses the pointer itself to find the address of
7517 -- the object, and which handles unconstrained arrays
7518 -- properly by computing the address of the template.
7519 -- i.e. the correct address of the corresponding allocation.
7525 -- Size_In_Storage_Elements
7528 Left_Opnd =>
7530 Prefix =>
7534 Right_Opnd =>
7537 -- Alignment
7540 Prefix =>
7545 exception
7550 ------------------------------
7551 -- Make_Array_Comparison_Op --
7552 ------------------------------
7554 -- This is a hand-coded expansion of the following generic function:
7556 -- generic
7557 -- type elem is (<>);
7558 -- type index is (<>);
7559 -- type a is array (index range <>) of elem;
7560 --
7561 -- function Gnnn (X : a; Y: a) return boolean is
7562 -- J : index := Y'first;
7563 --
7564 -- begin
7565 -- if X'length = 0 then
7566 -- return false;
7567 --
7568 -- elsif Y'length = 0 then
7569 -- return true;
7570 --
7571 -- else
7572 -- for I in X'range loop
7573 -- if X (I) = Y (J) then
7574 -- if J = Y'last then
7575 -- exit;
7576 -- else
7577 -- J := index'succ (J);
7578 -- end if;
7579 --
7580 -- else
7581 -- return X (I) > Y (J);
7582 -- end if;
7583 -- end loop;
7584 --
7585 -- return X'length > Y'length;
7586 -- end if;
7587 -- end Gnnn;
7589 -- Note that since we are essentially doing this expansion by hand, we
7590 -- do not need to generate an actual or formal generic part, just the
7591 -- instantiated function itself.
7593 function Make_Array_Comparison_Op
7596 is
7617 begin
7618 -- if J = Y'last then
7619 -- exit;
7620 -- else
7621 -- J := index'succ (J);
7622 -- end if;
7624 Inner_If :=
7626 Condition =>
7629 Right_Opnd =>
7637 Else_Statements =>
7638 New_List (
7641 Expression =>
7647 -- if X (I) = Y (J) then
7648 -- if ... end if;
7649 -- else
7650 -- return X (I) > Y (J);
7651 -- end if;
7653 Loop_Body :=
7655 Condition =>
7657 Left_Opnd =>
7662 Right_Opnd =>
7671 Expression =>
7673 Left_Opnd =>
7678 Right_Opnd =>
7684 -- for I in X'range loop
7685 -- if ... end if;
7686 -- end loop;
7688 Loop_Statement :=
7692 Iteration_Scheme =>
7694 Loop_Parameter_Specification =>
7697 Discrete_Subtype_Definition =>
7704 -- if X'length = 0 then
7705 -- return false;
7706 -- elsif Y'length = 0 then
7707 -- return true;
7708 -- else
7709 -- for ... loop ... end loop;
7710 -- return X'length > Y'length;
7711 -- end if;
7713 Length1 :=
7718 Length2 :=
7723 Final_Expr :=
7728 If_Stat :=
7730 Condition =>
7732 Left_Opnd =>
7736 Right_Opnd =>
7739 Then_Statements =>
7740 New_List (
7746 Condition =>
7748 Left_Opnd =>
7752 Right_Opnd =>
7755 Then_Statements =>
7756 New_List (
7761 Loop_Statement,
7765 -- (X : a; Y: a)
7776 -- function Gnnn (...) return boolean is
7777 -- J : index := Y'first;
7778 -- begin
7779 -- if ... end if;
7780 -- end Gnnn;
7784 Func_Body :=
7786 Specification =>
7796 Expression =>
7801 Handled_Statement_Sequence =>
7809 ---------------------------
7810 -- Make_Boolean_Array_Op --
7811 ---------------------------
7813 -- For logical operations on boolean arrays, expand in line the
7814 -- following, replacing 'and' with 'or' or 'xor' where needed:
7816 -- function Annn (A : typ; B: typ) return typ is
7817 -- C : typ;
7818 -- begin
7819 -- for J in A'range loop
7820 -- C (J) := A (J) op B (J);
7821 -- end loop;
7822 -- return C;
7823 -- end Annn;
7825 -- Here typ is the boolean array type
7827 function Make_Boolean_Array_Op
7830 is
7848 begin
7849 A_J :=
7854 B_J :=
7859 C_J :=
7865 Op :=
7871 Op :=
7876 else
7877 Op :=
7883 Loop_Statement :=
7887 Iteration_Scheme =>
7889 Loop_Parameter_Specification =>
7892 Discrete_Subtype_Definition =>
7911 Func_Name :=
7915 Func_Body :=
7917 Specification =>
7928 Handled_Statement_Sequence =>
7931 Loop_Statement,
7938 ------------------------
7939 -- Rewrite_Comparison --
7940 ------------------------
7948 -- Res indicates if compare outcome can be determined at compile time
7953 begin
7994 ----------------------------
7995 -- Safe_In_Place_Array_Op --
7996 ----------------------------
7998 function Safe_In_Place_Array_Op
8002 is
8006 -- Operand is safe if it cannot overlap part of the target of the
8007 -- operation. If the operand and the target are identical, the operand
8008 -- is safe. The operand can be empty in the case of negation.
8011 -- Check that N is a stand-alone entity
8013 ------------------
8014 -- Is_Unaliased --
8015 ------------------
8018 begin
8019 return
8025 ---------------------
8026 -- Is_Safe_Operand --
8027 ---------------------
8030 begin
8039 then
8043 return
8050 else
8055 -- Start of processing for Is_Safe_In_Place_Array_Op
8057 begin
8058 -- We skip this processing if the component size is not the
8059 -- same as a system storage unit (since at least for NOT
8060 -- this would cause problems).
8065 -- Cannot do in place stuff on Java_VM since cannot pass addresses
8070 -- Cannot do in place stuff if non-standard Boolean representation
8077 else
8080 return
8086 -----------------------
8087 -- Tagged_Membership --
8088 -----------------------
8090 -- There are two different cases to consider depending on whether
8091 -- the right operand is a class-wide type or not. If not we just
8092 -- compare the actual tag of the left expr to the target type tag:
8093 --
8094 -- Left_Expr.Tag = Right_Type'Tag;
8095 --
8096 -- If it is a class-wide type we use the RT function CW_Membership which
8097 -- is usually implemented by looking in the ancestor tables contained in
8098 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
8109 begin
8117 Obj_Tag :=
8120 Selector_Name =>
8125 -- Ada 2005 (AI-251): Class-wide applied to interfaces
8129 -- Give support to: "Iface_CW_Typ in Typ'Class"
8132 then
8133 return
8140 New_Reference_To (
8141 Node (First_Elmt
8143 Loc)));
8145 -- Ada 95: Normal case
8147 else
8148 return
8152 Obj_Tag,
8153 New_Reference_To (
8154 Node (First_Elmt
8156 Loc)));
8159 else
8160 return
8163 Right_Opnd =>
8164 New_Reference_To
8169 ------------------------------
8170 -- Unary_Op_Validity_Checks --
8171 ------------------------------
8174 begin