| blob | 9eaeda66c7c2f6b77e1f18984c89b183b05e1bc7 |
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-2006, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
69 -----------------------
70 -- Local Subprograms --
71 -----------------------
75 -- Performs validity checks for a binary operator
77 procedure Build_Boolean_Array_Proc_Call
81 -- If an boolean array assignment can be done in place, build call to
82 -- corresponding library procedure.
85 -- Subsidiary to Expand_N_Allocator, for the case when the expression
86 -- is a qualified expression or an aggregate.
89 -- This routine handles expansion of the comparison operators (N_Op_Lt,
90 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
91 -- code for these operators is similar, differing only in the details of
92 -- the actual comparison call that is made. Special processing (call a
93 -- run-time routine)
95 function Expand_Array_Equality
101 -- Expand an array equality into a call to a function implementing this
102 -- equality, and a call to it. Loc is the location for the generated
103 -- nodes. Lhs and Rhs are the array expressions to be compared.
104 -- Bodies is a list on which to attach bodies of local functions that
105 -- are created in the process. It is the responsibility of the
106 -- caller to insert those bodies at the right place. Nod provides
107 -- the Sloc value for the generated code. Normally the types used
108 -- for the generated equality routine are taken from Lhs and Rhs.
109 -- However, in some situations of generated code, the Etype fields
110 -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the
111 -- type to be used for the formal parameters.
114 -- Common expansion processing for Boolean operators (And, Or, Xor)
115 -- for the case of array type arguments.
117 function Expand_Composite_Equality
123 -- Local recursive function used to expand equality for nested
124 -- composite types. Used by Expand_Record/Array_Equality, Bodies
125 -- is a list on which to attach bodies of local functions that are
126 -- created in the process. This is the responsability of the caller
127 -- to insert those bodies at the right place. Nod provides the Sloc
128 -- value for generated code. Lhs and Rhs are the left and right sides
129 -- for the comparison, and Typ is the type of the arrays to compare.
132 -- This routine handles expansion of concatenation operations, where
133 -- N is the N_Op_Concat node being expanded and Operands is the list
134 -- of operands (at least two are present). The caller has dealt with
135 -- converting any singleton operands into singleton aggregates.
138 -- Routine to expand concatenation of 2-5 operands (in the list Operands)
139 -- and replace node Cnode with the result of the contatenation. If there
140 -- are two operands, they can be string or character. If there are more
141 -- than two operands, then are always of type string (i.e. the caller has
142 -- already converted character operands to strings in this case).
145 -- N is either an N_Op_Divide or N_Op_Multiply node whose result is
146 -- universal fixed. We do not have such a type at runtime, so the
147 -- purpose of this routine is to find the real type by looking up
148 -- the tree. We also determine if the operation must be rounded.
150 function Get_Allocator_Final_List
154 -- If the designated type is controlled, build final_list expression
155 -- for created object. If context is an access parameter, create a
156 -- local access type to have a usable finalization list.
159 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
160 -- discriminants if it has a constrained nominal type, unless the object
161 -- is a component of an enclosing Unchecked_Union object that is subject
162 -- to a per-object constraint and the enclosing object lacks inferable
163 -- discriminants.
164 --
165 -- An expression of an Unchecked_Union type has inferable discriminants
166 -- if it is either a name of an object with inferable discriminants or a
167 -- qualified expression whose subtype mark denotes a constrained subtype.
170 -- N is an expression whose type is an access. When the type of the
171 -- associated storage pool is derived from Checked_Pool, generate a
172 -- call to the 'Dereference' primitive operation.
174 function Make_Array_Comparison_Op
177 -- Comparisons between arrays are expanded in line. This function
178 -- produces the body of the implementation of (a > b), where a and b
179 -- are one-dimensional arrays of some discrete type. The original
180 -- node is then expanded into the appropriate call to this function.
181 -- Nod provides the Sloc value for the generated code.
183 function Make_Boolean_Array_Op
186 -- Boolean operations on boolean arrays are expanded in line. This
187 -- function produce the body for the node N, which is (a and b),
188 -- (a or b), or (a xor b). It is used only the normal case and not
189 -- the packed case. The type involved, Typ, is the Boolean array type,
190 -- and the logical operations in the body are simple boolean operations.
191 -- Note that Typ is always a constrained type (the caller has ensured
192 -- this by using Convert_To_Actual_Subtype if necessary).
195 -- if N is the node for a comparison whose outcome can be determined at
196 -- compile time, then the node N can be rewritten with True or False. If
197 -- the outcome cannot be determined at compile time, the call has no
198 -- effect. If N is a type conversion, then this processing is applied to
199 -- its expression. If N is neither comparison nor a type conversion, the
200 -- call has no effect.
203 -- Construct the expression corresponding to the tagged membership test.
204 -- Deals with a second operand being (or not) a class-wide type.
206 function Safe_In_Place_Array_Op
210 -- In the context of an assignment, where the right-hand side is a
211 -- boolean operation on arrays, check whether operation can be performed
212 -- in place.
216 -- Performs validity checks for a unary operator
218 -------------------------------
219 -- Binary_Op_Validity_Checks --
220 -------------------------------
223 begin
230 ------------------------------------
231 -- Build_Boolean_Array_Proc_Call --
232 ------------------------------------
234 procedure Build_Boolean_Array_Proc_Call
238 is
251 begin
255 -- Use negated version of the binary operators
267 Call_Node :=
272 Target,
285 else
288 Call_Node :=
292 Target,
303 else
304 -- We use the following equivalences:
306 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
307 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
308 -- (not X) xor (not Y) = X xor Y
309 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
318 else
322 else
333 else
338 Call_Node :=
342 Target,
357 exception
362 ---------------------------------
363 -- Expand_Allocator_Expression --
364 ---------------------------------
378 -- Type used as source for tag assignment
381 -- Target reference for tag assignment
388 begin
391 -- Actions inserted before:
392 -- Temp : constant ptr_T := new T'(Expression);
393 -- <no CW> Temp._tag := T'tag;
394 -- <CTRL> Adjust (Finalizable (Temp.all));
395 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
397 -- We analyze by hand the new internal allocator to avoid
398 -- any recursion and inappropriate call to Initialize
404 Temp :=
407 -- For a class wide allocation generate the following code:
409 -- type Equiv_Record is record ... end record;
410 -- implicit subtype CW is <Class_Wide_Subytpe>;
411 -- temp : PtrT := new CW'(CW!(expr));
423 Tmp_Node :=
427 Expression =>
431 Set_Comes_From_Source
439 then
440 -- Create local finalization list for access parameter
446 else
457 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
458 -- type, generate an accessibility check to verify that the level of
459 -- the type of the created object is not deeper than the level of the
460 -- access type. If the type of the qualified expression is class-
461 -- wide, then always generate the check. Otherwise, only generate the
462 -- check if the level of the qualified expression type is statically
463 -- deeper than the access type. Although the static accessibility
464 -- will generally have been performed as a legality check, it won't
465 -- have been done in cases where the allocator appears in generic
466 -- body, so a run-time check is needed in general.
471 and then
473 or else
475 then
478 Condition =>
480 Left_Opnd =>
482 Name =>
484 Parameter_Associations =>
486 Prefix =>
488 Attribute_Name =>
489 Name_Tag))),
490 Right_Opnd =>
497 -- Suppress the tag assignment when Java_VM because JVM tags are
498 -- represented implicitly in objects.
508 then
510 TagR :=
517 Tag_Assign :=
519 Name =>
522 Selector_Name =>
525 Expression =>
527 New_Reference_To
529 Loc)));
531 -- The previous assignment has to be done in any case
539 then
540 declare
545 begin
546 -- If it is an allocation on the secondary stack
547 -- (i.e. a value returned from a function), the object
548 -- is attached on the caller side as soon as the call
549 -- is completed (see Expand_Ctrl_Function_Call)
552 declare
556 begin
567 -- Normal case, not a secondary stack allocation
569 else
572 then
573 -- Create local finalization list for access parameter
575 Flist :=
577 else
586 Make_Adjust_Call (
587 Ref =>
589 -- An unchecked conversion is needed in the
590 -- classwide case because the designated type
591 -- can be an ancestor of the subtype mark of
592 -- the allocator.
610 Temp :=
612 Tmp_Node :=
619 Set_Comes_From_Source
631 then
632 -- Apply constraint to designated subtype indication
640 -- Propagate constraint_error to enclosing allocator
644 else
645 -- First check against the type of the qualified expression
646 --
647 -- NOTE: The commented call should be correct, but for
648 -- some reason causes the compiler to bomb (sigsegv) on
649 -- ACVC test c34007g, so for now we just perform the old
650 -- (incorrect) test against the designated subtype with
651 -- no sliding in the else part of the if statement below.
652 -- ???
653 --
654 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
656 -- A check is also needed in cases where the designated
657 -- subtype is constrained and differs from the subtype
658 -- given in the qualified expression. Note that the check
659 -- on the qualified expression does not allow sliding,
660 -- but this check does (a relaxation from Ada 83).
663 and then not Subtypes_Statically_Match
665 then
666 Apply_Constraint_Check
669 -- The nonsliding check should really be performed
670 -- (unconditionally) against the subtype of the
671 -- qualified expression, but that causes a problem
672 -- with c34007g (see above), so for now we retain this.
674 else
675 Apply_Constraint_Check
679 -- For an access to unconstrained packed array, GIGI needs
680 -- to see an expression with a constrained subtype in order
681 -- to compute the proper size for the allocator.
686 then
687 declare
692 begin
696 Subtype_Indication =>
705 exception
710 -----------------------------
711 -- Expand_Array_Comparison --
712 -----------------------------
714 -- Expansion is only required in the case of array types. For the
715 -- unpacked case, an appropriate runtime routine is called. For
716 -- packed cases, and also in some other cases where a runtime
717 -- routine cannot be called, the form of the expansion is:
719 -- [body for greater_nn; boolean_expression]
721 -- The body is built by Make_Array_Comparison_Op, and the form of the
722 -- Boolean expression depends on the operator involved.
738 -- True for byte addressable target
741 -- Returns True if the length of the given operand is known to be
742 -- less than 4. Returns False if this length is known to be four
743 -- or greater or is not known at compile time.
745 ------------------------
746 -- Length_Less_Than_4 --
747 ------------------------
752 begin
756 else
757 declare
764 begin
767 else
773 else
782 -- Start of processing for Expand_Array_Comparison
784 begin
785 -- Deal first with unpacked case, where we can call a runtime routine
786 -- except that we avoid this for targets for which are not addressable
787 -- by bytes, and for the JVM, since the JVM does not support direct
788 -- addressing of array components.
791 and then Byte_Addressable
792 and then not Java_VM
793 then
794 -- The call we generate is:
796 -- Compare_Array_xn[_Unaligned]
797 -- (left'address, right'address, left'length, right'length) <op> 0
799 -- x = U for unsigned, S for signed
800 -- n = 8,16,32,64 for component size
801 -- Add _Unaligned if length < 4 and component size is 8.
802 -- <op> is the standard comparison operator
806 or else
808 then
811 else
815 else
818 else
826 else
833 else
840 else
878 -- Cases where we cannot make runtime call
880 -- For (a <= b) we convert to not (a > b)
885 Right_Opnd =>
892 -- For < the Boolean expression is
893 -- greater__nn (op2, op1)
898 -- Switch operands
903 -- For (a >= b) we convert to not (a < b)
908 Right_Opnd =>
915 -- For > the Boolean expression is
916 -- greater__nn (op1, op2)
918 else
924 Expr :=
933 exception
938 ---------------------------
939 -- Expand_Array_Equality --
940 ---------------------------
942 -- Expand an equality function for multi-dimensional arrays. Here is
943 -- an example of such a function for Nb_Dimension = 2
945 -- function Enn (A : atyp; B : btyp) return boolean is
946 -- begin
947 -- if (A'length (1) = 0 or else A'length (2) = 0)
948 -- and then
949 -- (B'length (1) = 0 or else B'length (2) = 0)
950 -- then
951 -- return True; -- RM 4.5.2(22)
952 -- end if;
954 -- if A'length (1) /= B'length (1)
955 -- or else
956 -- A'length (2) /= B'length (2)
957 -- then
958 -- return False; -- RM 4.5.2(23)
959 -- end if;
961 -- declare
962 -- A1 : Index_T1 := A'first (1);
963 -- B1 : Index_T1 := B'first (1);
964 -- begin
965 -- loop
966 -- declare
967 -- A2 : Index_T2 := A'first (2);
968 -- B2 : Index_T2 := B'first (2);
969 -- begin
970 -- loop
971 -- if A (A1, A2) /= B (B1, B2) then
972 -- return False;
973 -- end if;
975 -- exit when A2 = A'last (2);
976 -- A2 := Index_T2'succ (A2);
977 -- B2 := Index_T2'succ (B2);
978 -- end loop;
979 -- end;
981 -- exit when A1 = A'last (1);
982 -- A1 := Index_T1'succ (A1);
983 -- B1 := Index_T1'succ (B1);
984 -- end loop;
985 -- end;
987 -- return true;
988 -- end Enn;
990 -- Note on the formal types used (atyp and btyp). If either of the
991 -- arrays is of a private type, we use the underlying type, and
992 -- do an unchecked conversion of the actual. If either of the arrays
993 -- has a bound depending on a discriminant, then we use the base type
994 -- since otherwise we have an escaped discriminant in the function.
996 -- If both arrays are constrained and have the same bounds, we can
997 -- generate a loop with an explicit iteration scheme using a 'Range
998 -- attribute over the first array.
1000 function Expand_Array_Equality
1006 is
1022 -- The parameter types to be used for the formals
1024 function Arr_Attr
1028 -- This builds the attribute reference Arr'Nam (Expr)
1031 -- Create one statement to compare corresponding components,
1032 -- designated by a full set of indices.
1035 -- Given one of the arguments, computes the appropriate type to
1036 -- be used for that argument in the corresponding function formal
1038 function Handle_One_Dimension
1041 -- This procedure returns the following code
1042 --
1043 -- declare
1044 -- Bn : Index_T := B'First (N);
1045 -- begin
1046 -- loop
1047 -- xxx
1048 -- exit when An = A'Last (N);
1049 -- An := Index_T'Succ (An)
1050 -- Bn := Index_T'Succ (Bn)
1051 -- end loop;
1052 -- end;
1053 --
1054 -- If both indices are constrained and identical, the procedure
1055 -- returns a simpler loop:
1056 --
1057 -- for An in A'Range (N) loop
1058 -- xxx
1059 -- end loop
1060 --
1061 -- N is the dimension for which we are generating a loop. Index is the
1062 -- N'th index node, whose Etype is Index_Type_n in the above code.
1063 -- The xxx statement is either the loop or declare for the next
1064 -- dimension or if this is the last dimension the comparison
1065 -- of corresponding components of the arrays.
1066 --
1067 -- The actual way the code works is to return the comparison
1068 -- of corresponding components for the N+1 call. That's neater!
1071 -- This function constructs the test for both arrays being empty
1072 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1073 -- and then
1074 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1077 -- This function constructs the test for arrays having different
1078 -- lengths in at least one index position, in which case resull
1080 -- A'length (1) /= B'length (1)
1081 -- or else
1082 -- A'length (2) /= B'length (2)
1083 -- or else
1084 -- ...
1086 --------------
1087 -- Arr_Attr --
1088 --------------
1090 function Arr_Attr
1094 is
1095 begin
1096 return
1103 ------------------------
1104 -- Component_Equality --
1105 ------------------------
1111 begin
1112 -- if a(i1...) /= b(j1...) then return false; end if;
1114 L :=
1119 R :=
1124 Test := Expand_Composite_Equality
1127 -- If some (sub)component is an unchecked_union, the whole operation
1128 -- will raise program error.
1132 -- This node is going to be inserted at a location where a
1133 -- statement is expected: clear its Etype so analysis will
1134 -- set it to the expected Standard_Void_Type.
1139 else
1140 return
1149 ------------------
1150 -- Get_Arg_Type --
1151 ------------------
1157 begin
1163 else
1169 or else
1171 then
1183 --------------------------
1184 -- Handle_One_Dimension --
1185 ---------------------------
1187 function Handle_One_Dimension
1190 is
1192 Ltyp /= Rtyp
1194 -- If the index types are identical, and we are working with
1195 -- constrained types, then we can use the same index for both of
1196 -- the arrays.
1206 begin
1211 -- Case where we generate a loop
1216 Bn :=
1219 else
1231 -- Generate guard for loop, followed by increments of indices
1235 Condition =>
1243 Expression =>
1252 Expression =>
1259 -- If separate indexes, we need a declare block for An and Bn, and a
1260 -- loop without an iteration scheme.
1263 Loop_Stm :=
1266 return
1279 Handled_Statement_Sequence =>
1283 -- If no separate indexes, return loop statement with explicit
1284 -- iteration scheme on its own
1286 else
1287 Loop_Stm :=
1290 Iteration_Scheme =>
1292 Loop_Parameter_Specification =>
1295 Discrete_Subtype_Definition =>
1301 -----------------------
1302 -- Test_Empty_Arrays --
1303 -----------------------
1312 begin
1316 Atest :=
1321 Btest :=
1330 else
1331 Alist :=
1336 Blist :=
1343 return
1349 -----------------------------
1350 -- Test_Lengths_Correspond --
1351 -----------------------------
1357 begin
1360 Rtest :=
1367 else
1368 Result :=
1378 -- Start of processing for Expand_Array_Equality
1380 begin
1384 -- For now, if the argument types are not the same, go to the
1385 -- base type, since the code assumes that the formals have the
1386 -- same type. This is fixable in future ???
1394 -- Build list of formals for function
1407 -- Build statement sequence for function
1409 Func_Body :=
1411 Specification =>
1419 Handled_Statement_Sequence =>
1427 Expression =>
1434 Expression =>
1445 -- If the array type is distinct from the type of the arguments,
1446 -- it is the full view of a private type. Apply an unchecked
1447 -- conversion to insure that analysis of the call succeeds.
1449 declare
1452 begin
1458 then
1464 then
1473 return
1479 -----------------------------
1480 -- Expand_Boolean_Operator --
1481 -----------------------------
1483 -- Note that we first get the actual subtypes of the operands,
1484 -- since we always want to deal with types that have bounds.
1489 begin
1490 -- Special case of bit packed array where both operands are known
1491 -- to be properly aligned. In this case we use an efficient run time
1492 -- routine to carry out the operation (see System.Bit_Ops).
1497 then
1502 -- For the normal non-packed case, the general expansion is to build
1503 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1504 -- and then inserting it into the tree. The original operator node is
1505 -- then rewritten as a call to this function. We also use this in the
1506 -- packed case if either operand is a possibly unaligned object.
1508 declare
1515 begin
1524 then
1529 and then
1531 then
1533 else
1539 -- Now rewrite the expression with a call
1544 Parameter_Associations =>
1545 New_List (
1546 L,
1547 Make_Type_Conversion
1555 -------------------------------
1556 -- Expand_Composite_Equality --
1557 -------------------------------
1559 -- This function is only called for comparing internal fields of composite
1560 -- types when these fields are themselves composites. This is a special
1561 -- case because it is not possible to respect normal Ada visibility rules.
1563 function Expand_Composite_Equality
1569 is
1575 begin
1578 else
1582 -- Defense against malformed private types with no completion
1583 -- the error will be diagnosed later by check_completion
1593 -- If the operand is an elementary type other than a floating-point
1594 -- type, then we can simply use the built-in block bitwise equality,
1595 -- since the predefined equality operators always apply and bitwise
1596 -- equality is fine for all these cases.
1600 then
1603 -- For composite component types, and floating-point types, use
1604 -- the expansion. This deals with tagged component types (where
1605 -- we use the applicable equality routine) and floating-point,
1606 -- (where we need to worry about negative zeroes), and also the
1607 -- case of any composite type recursively containing such fields.
1609 else
1615 -- Call the primitive operation "=" of this type
1621 -- If this is derived from an untagged private type completed
1622 -- with a tagged type, it does not have a full view, so we
1623 -- use the primitive operations of the private type.
1624 -- This check should no longer be necessary when these
1625 -- types receive their full views ???
1632 then
1634 else
1638 loop
1650 return
1653 Parameter_Associations =>
1654 New_List
1664 -- Inherited equality from parent type. Convert the actuals
1665 -- to match signature of operation.
1667 declare
1670 begin
1671 return
1674 Parameter_Associations =>
1679 else
1680 -- Comparison between Unchecked_Union components
1683 declare
1689 begin
1690 -- Lhs subtype
1696 -- Rhs subtype
1702 -- Lhs of the composite equality
1706 -- Since the enclosing record can never be an
1707 -- Unchecked_Union (this code is executed for records
1708 -- that do not have variants), we may reference its
1709 -- discriminant(s).
1714 then
1715 Lhs_Discr_Val :=
1718 Selector_Name =>
1719 New_Copy (
1720 Get_Discriminant_Value (
1722 Lhs_Type,
1725 else
1727 Get_Discriminant_Value (
1729 Lhs_Type,
1733 else
1734 -- It is not possible to infer the discriminant since
1735 -- the subtype is not constrained.
1737 return
1742 -- Rhs of the composite equality
1748 then
1749 Rhs_Discr_Val :=
1752 Selector_Name =>
1753 New_Copy (
1754 Get_Discriminant_Value (
1756 Rhs_Type,
1759 else
1761 Get_Discriminant_Value (
1763 Rhs_Type,
1767 else
1768 return
1773 -- Call the TSS equality function with the inferred
1774 -- discriminant values.
1776 return
1780 Lhs,
1781 Rhs,
1782 Lhs_Discr_Val,
1783 Rhs_Discr_Val));
1787 -- Shouldn't this be an else, we can't fall through
1788 -- the above IF, right???
1790 return
1796 else
1800 else
1801 -- It can be a simple record or the full view of a scalar private
1807 ------------------------------
1808 -- Expand_Concatenate_Other --
1809 ------------------------------
1811 -- Let n be the number of array operands to be concatenated, Base_Typ
1812 -- their base type, Ind_Typ their index type, and Arr_Typ the original
1813 -- array type to which the concatenantion operator applies, then the
1814 -- following subprogram is constructed:
1816 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1817 -- L : Ind_Typ;
1818 -- begin
1819 -- if S1'Length /= 0 then
1820 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
1821 -- XXX = Arr_Typ'First otherwise
1822 -- elsif S2'Length /= 0 then
1823 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
1824 -- YYY = Arr_Typ'First otherwise
1825 -- ...
1826 -- elsif Sn-1'Length /= 0 then
1827 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
1828 -- ZZZ = Arr_Typ'First otherwise
1829 -- else
1830 -- return Sn;
1831 -- end if;
1833 -- declare
1834 -- P : Ind_Typ;
1835 -- H : Ind_Typ :=
1836 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1837 -- + Ind_Typ'Pos (L));
1838 -- R : Base_Typ (L .. H);
1839 -- begin
1840 -- if S1'Length /= 0 then
1841 -- P := S1'First;
1842 -- loop
1843 -- R (L) := S1 (P);
1844 -- L := Ind_Typ'Succ (L);
1845 -- exit when P = S1'Last;
1846 -- P := Ind_Typ'Succ (P);
1847 -- end loop;
1848 -- end if;
1849 --
1850 -- if S2'Length /= 0 then
1851 -- L := Ind_Typ'Succ (L);
1852 -- loop
1853 -- R (L) := S2 (P);
1854 -- L := Ind_Typ'Succ (L);
1855 -- exit when P = S2'Last;
1856 -- P := Ind_Typ'Succ (P);
1857 -- end loop;
1858 -- end if;
1860 -- ...
1862 -- if Sn'Length /= 0 then
1863 -- P := Sn'First;
1864 -- loop
1865 -- R (L) := Sn (P);
1866 -- L := Ind_Typ'Succ (L);
1867 -- exit when P = Sn'Last;
1868 -- P := Ind_Typ'Succ (P);
1869 -- end loop;
1870 -- end if;
1872 -- return R;
1873 -- end;
1874 -- end Cnn;]
1912 -- Builds the sequence of statement:
1913 -- P := Si'First;
1914 -- loop
1915 -- R (L) := Si (P);
1916 -- L := Ind_Typ'Succ (L);
1917 -- exit when P = Si'Last;
1918 -- P := Ind_Typ'Succ (P);
1919 -- end loop;
1920 --
1921 -- where i is the input parameter I given.
1922 -- If the flag Last is true, the exit statement is emitted before
1923 -- incrementing the lower bound, to prevent the creation out of
1924 -- bound values.
1927 -- Builds the statement:
1928 -- L := Arr_Typ'First; If Arr_Typ is constrained
1929 -- L := Si'First; otherwise (where I is the input param given)
1932 -- Builds reference to identifier H
1935 -- Builds expression Ind_Typ'Val (E);
1938 -- Builds reference to identifier L
1941 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
1942 -- expression to avoid universal_integer computations whenever possible,
1943 -- in the expression for the upper bound H.
1946 -- Builds expression Ind_Typ'Succ (L)
1949 -- Builds integer literal one
1952 -- Builds reference to identifier P
1955 -- Builds expression Ind_Typ'Succ (P)
1958 -- Builds reference to identifier R
1961 -- Builds reference to identifier Si, where I is the value given
1964 -- Builds expression Si'First, where I is the value given
1967 -- Builds expression Si'Last, where I is the value given
1970 -- Builds expression Si'Length, where I is the value given
1973 -- Builds expression Si'Length /= 0, where I is the value given
1975 -------------------
1976 -- Copy_Into_R_S --
1977 -------------------
1988 begin
1989 -- First construct the initializations
1996 -- Then build the loop
2018 Loop_Stmt :=
2021 else
2022 Loop_Stmt :=
2032 -------
2033 -- H --
2034 -------
2037 begin
2041 -------------
2042 -- Ind_Val --
2043 -------------
2046 begin
2047 return
2054 ------------
2055 -- Init_L --
2056 ------------
2061 begin
2067 else
2074 -------
2075 -- L --
2076 -------
2079 begin
2083 -----------
2084 -- L_Pos --
2085 -----------
2090 begin
2091 -- If the index type is an enumeration type, the computation
2092 -- can be done in standard integer. Otherwise, choose a large
2093 -- enough integer type.
2099 then
2101 else
2105 return
2108 Expression =>
2115 ------------
2116 -- L_Succ --
2117 ------------
2120 begin
2121 return
2128 ---------
2129 -- One --
2130 ---------
2133 begin
2137 -------
2138 -- P --
2139 -------
2142 begin
2146 ------------
2147 -- P_Succ --
2148 ------------
2151 begin
2152 return
2159 -------
2160 -- R --
2161 -------
2164 begin
2168 -------
2169 -- S --
2170 -------
2173 begin
2177 -------------
2178 -- S_First --
2179 -------------
2182 begin
2188 ------------
2189 -- S_Last --
2190 ------------
2193 begin
2199 --------------
2200 -- S_Length --
2201 --------------
2204 begin
2210 -------------------
2211 -- S_Length_Test --
2212 -------------------
2215 begin
2216 return
2222 -- Start of processing for Expand_Concatenate_Other
2224 begin
2225 -- Construct the parameter specs and the overall function spec
2229 Append_To
2232 Defining_Identifier =>
2238 Func_Spec :=
2244 -- Construct L's object declaration
2246 L_Decl :=
2253 -- Construct the if-then-elsif statements
2262 If_Stmt :=
2270 -- Construct the declaration for H
2272 P_Decl :=
2283 H_Decl :=
2289 -- Construct the declaration for R
2292 R_Constr :=
2296 R_Decl :=
2299 Object_Definition =>
2304 -- Construct the declarations for the declare block
2308 -- Construct list of statements for the declare block
2320 -- Construct the declare block
2324 Handled_Statement_Sequence =>
2327 -- Construct the list of function statements
2331 -- Construct the function body
2333 Func_Body :=
2337 Handled_Statement_Sequence =>
2340 -- Insert the newly generated function in the code. This is analyzed
2341 -- with all checks off, since we have completed all the checks.
2343 -- Note that this does *not* fix the array concatenation bug when the
2344 -- low bound is Integer'first sibce that bug comes from the pointer
2345 -- dereferencing an unconstrained array. An there we need a constraint
2346 -- check to make sure the length of the concatenated array is ok. ???
2350 -- Construct list of arguments for the function call
2359 -- Insert the function call
2361 Rewrite
2369 -------------------------------
2370 -- Expand_Concatenate_String --
2371 -------------------------------
2381 -- RE_Id value for function to be called
2383 begin
2384 -- In all cases, we build a call to a routine giving the list of
2385 -- arguments as the parameter list to the routine.
2393 else
2402 else
2407 -- If we have anything other than Standard_Character or
2408 -- Standard_String, then we must have had a serious error
2409 -- earlier, so we just abandon the attempt at expansion.
2411 else
2430 -- Now generate the appropriate call
2439 exception
2444 ------------------------
2445 -- Expand_N_Allocator --
2446 ------------------------
2457 begin
2458 -- RM E.2.3(22). We enforce that the expected type of an allocator
2459 -- shall not be a remote access-to-class-wide-limited-private type
2461 -- Why is this being done at expansion time, seems clearly wrong ???
2465 -- Set the Storage Pool
2478 else
2484 -- Under certain circumstances we can replace an allocator by an
2485 -- access to statically allocated storage. The conditions, as noted
2486 -- in AARM 3.10 (10c) are as follows:
2488 -- Size and initial value is known at compile time
2489 -- Access type is access-to-constant
2491 -- The allocator is not part of a constraint on a record component,
2492 -- because in that case the inserted actions are delayed until the
2493 -- record declaration is fully analyzed, which is too late for the
2494 -- analysis of the rewritten allocator.
2502 then
2503 -- Here we can do the optimization. For the allocator
2505 -- new x'(y)
2507 -- We insert an object declaration
2509 -- Tnn : aliased x := y;
2511 -- and replace the allocator by Tnn'Unrestricted_Access.
2512 -- Tnn is marked as requiring static allocation.
2514 Temp :=
2519 -- If context is constrained, use constrained subtype directly,
2520 -- so that the constant is not labelled as having a nomimally
2521 -- unconstrained subtype.
2542 -- We set the variable as statically allocated, since we don't
2543 -- want it going on the stack of the current procedure!
2549 -- Handle case of qualified expression (other than optimization above)
2554 -- If the allocator is for a type which requires initialization, and
2555 -- there is no initial value (i.e. operand is a subtype indication
2556 -- rather than a qualifed expression), then we must generate a call
2557 -- to the initialization routine. This is done using an expression
2558 -- actions node:
2559 --
2560 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2561 --
2562 -- Here ptr_T is the pointer type for the allocator, and T is the
2563 -- subtype of the allocator. A special case arises if the designated
2564 -- type of the access type is a task or contains tasks. In this case
2565 -- the call to Init (Temp.all ...) is replaced by code that ensures
2566 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2567 -- for details). In addition, if the type T is a task T, then the
2568 -- first argument to Init must be converted to the task record type.
2570 else
2571 declare
2584 begin
2588 -- Case of no initialization procedure present
2592 -- Case of simple initialization required
2605 -- No initialization required
2607 else
2611 -- Case of initialization procedure present, must be called
2613 else
2616 Temp :=
2619 -- Construct argument list for the initialization routine call
2620 -- The CPP constructor needs the address directly
2626 else
2627 Arg1 :=
2633 -- The initialization procedure expects a specific type.
2634 -- if the context is access to class wide, indicate that
2635 -- the object being allocated has the right specific type.
2642 -- If designated type is a concurrent type or if it is a
2643 -- private type whose definition is a concurrent type,
2644 -- the first argument in the Init routine has to be
2645 -- unchecked conversion to the corresponding record type.
2646 -- If the designated type is a derived type, we also
2647 -- convert the argument to its root type.
2650 Arg1 :=
2656 then
2657 Arg1 :=
2658 Unchecked_Convert_To
2663 declare
2666 begin
2674 -- For the task case, pass the Master_Id of the access type
2675 -- as the value of the _Master parameter, and _Chain as the
2676 -- value of the _Chain parameter (_Chain will be defined as
2677 -- part of the generated code for the allocator).
2682 -- The designated type was an incomplete type, and
2683 -- the access type did not get expanded. Salvage
2684 -- it now.
2686 Expand_N_Full_Type_Declaration
2690 -- If the context of the allocator is a declaration or
2691 -- an assignment, we can generate a meaningful image for
2692 -- it, even though subsequent assignments might remove
2693 -- the connection between task and entity. We build this
2694 -- image when the left-hand side is a simple variable,
2695 -- a simple indexed assignment or a simple selected
2696 -- component.
2699 declare
2702 begin
2704 Decls :=
2705 Build_Task_Image_Decls (
2706 Loc,
2707 New_Occurrence_Of
2713 then
2714 Decls :=
2715 Build_Task_Image_Decls
2717 else
2723 Decls :=
2724 Build_Task_Image_Decls (
2727 else
2732 New_Reference_To
2740 -- Has_Task is false, Decls not used
2742 else
2746 -- Add discriminants if discriminated type
2759 then
2760 Discr :=
2769 -- We set the allocator as analyzed so that when we analyze the
2770 -- expression actions node, we do not get an unwanted recursive
2771 -- expansion of the allocator expression.
2776 -- Here is the transformation:
2777 -- input: new T
2778 -- output: Temp : constant ptr_T := new T;
2779 -- Init (Temp.all, ...);
2780 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
2781 -- <CTRL> Initialize (Finalizable (Temp.all));
2783 -- Here ptr_T is the pointer type for the allocator, and T
2784 -- is the subtype of the allocator.
2786 Temp_Decl :=
2801 -- If the designated type is task type or contains tasks,
2802 -- Create block to activate created tasks, and insert
2803 -- declaration for Task_Image variable ahead of call.
2806 declare
2810 begin
2818 else
2829 else
2833 Make_Init_Call (
2838 Attach_Level)));
2846 else
2855 -- Ada 2005 (AI-251): If the allocated object is accessed through an
2856 -- access to class-wide interface we force the displacement of the
2857 -- pointer to the allocated object to reference the corresponding
2858 -- secondary dispatch table.
2862 then
2863 declare
2866 begin
2867 -- 1) Get access to the allocated object
2875 -- 2) Add the conversion to displace the pointer to reference
2876 -- the secondary dispatch table.
2881 -- 3) The 'access to the secondary dispatch table will be used as
2882 -- the value returned by the allocator.
2893 exception
2898 -----------------------
2899 -- Expand_N_And_Then --
2900 -----------------------
2902 -- Expand into conditional expression if Actions present, and also
2903 -- deal with optimizing case of arguments being True or False.
2912 begin
2913 -- Deal with non-standard booleans
2921 -- Check for cases of left argument is True or False
2925 -- If left argument is True, change (True and then Right) to Right.
2926 -- Any actions associated with Right will be executed unconditionally
2927 -- and can thus be inserted into the tree unconditionally.
2938 -- If left argument is False, change (False and then Right) to
2939 -- False. In this case we can forget the actions associated with
2940 -- Right, since they will never be executed.
2951 -- If Actions are present, we expand
2953 -- left and then right
2955 -- into
2957 -- if left then right else false end
2959 -- with the actions becoming the Then_Actions of the conditional
2960 -- expression. This conditional expression is then further expanded
2961 -- (and will eventually disappear)
2968 Left,
2969 Right,
2978 -- No actions present, check for cases of right argument True/False
2982 -- Change (Left and then True) to Left. Note that we know there
2983 -- are no actions associated with the True operand, since we
2984 -- just checked for this case above.
2989 -- Change (Left and then False) to False, making sure to preserve
2990 -- any side effects associated with the Left operand.
2994 Rewrite
3002 -------------------------------------
3003 -- Expand_N_Conditional_Expression --
3004 -------------------------------------
3006 -- Expand into expression actions if then/else actions present
3017 begin
3018 -- If either then or else actions are present, then given:
3020 -- if cond then then-expr else else-expr end
3022 -- we insert the following sequence of actions (using Insert_Actions):
3024 -- Cnn : typ;
3025 -- if cond then
3026 -- <<then actions>>
3027 -- Cnn := then-expr;
3028 -- else
3029 -- <<else actions>>
3030 -- Cnn := else-expr
3031 -- end if;
3033 -- and replace the conditional expression by a reference to Cnn
3038 New_If :=
3056 Insert_List_Before
3061 Insert_List_Before
3077 -----------------------------------
3078 -- Expand_N_Explicit_Dereference --
3079 -----------------------------------
3082 begin
3083 -- Insert explicit dereference call for the checked storage pool case
3088 -----------------
3089 -- Expand_N_In --
3090 -----------------
3100 -- Replaces node N by Lop'Valid. This is done when we have an explicit
3101 -- test for the left operand being in range of its subtype.
3103 ----------------------------
3104 -- Substitute_Valid_Check --
3105 ----------------------------
3108 begin
3121 -- Start of processing for Expand_N_In
3123 begin
3124 -- Check case of explicit test for an expression in range of its
3125 -- subtype. This is suspicious usage and we replace it with a 'Valid
3126 -- test and give a warning.
3132 then
3133 Substitute_Valid_Check;
3137 -- Case of explicit range
3140 declare
3150 begin
3151 -- If test is explicit x'first .. x'last, replace by valid check
3163 then
3164 Substitute_Valid_Check;
3168 -- If we have an explicit range, do a bit of optimization based
3169 -- on range analysis (we may be able to kill one or both checks).
3171 -- If either check is known to fail, replace result by False since
3172 -- the other check does not matter. Preserve the static flag for
3173 -- legality checks, because we are constant-folding beyond RM 4.9.
3182 -- If both checks are known to succeed, replace result
3183 -- by True, since we know we are in range.
3192 -- If lower bound check succeeds and upper bound check is
3193 -- not known to succeed or fail, then replace the range check
3194 -- with a comparison against the upper bound.
3204 -- If upper bound check succeeds and lower bound check is
3205 -- not known to succeed or fail, then replace the range check
3206 -- with a comparison against the lower bound.
3218 -- For all other cases of an explicit range, nothing to be done
3222 -- Here right operand is a subtype mark
3224 else
3225 declare
3231 begin
3234 -- For tagged type, do tagged membership operation
3238 -- No expansion will be performed when Java_VM, as the
3239 -- JVM back end will handle the membership tests directly
3240 -- (tags are not explicitly represented in Java objects,
3241 -- so the normal tagged membership expansion is not what
3242 -- we want).
3251 -- If type is scalar type, rewrite as x in t'first .. t'last
3252 -- This reason we do this is that the bounds may have the wrong
3253 -- type if they come from the original type definition.
3258 Low_Bound =>
3263 High_Bound =>
3270 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
3271 -- a membership test if the subtype mark denotes a constrained
3272 -- Unchecked_Union subtype and the expression lacks inferable
3273 -- discriminants.
3278 then
3283 -- Prevent Gigi from generating incorrect code by rewriting
3284 -- the test as a standard False.
3292 -- Here we have a non-scalar type
3303 -- For the constrained array case, we have to check the
3304 -- subscripts for an exact match if the lengths are
3305 -- non-zero (the lengths must match in any case).
3310 function Construct_Attribute_Reference
3314 -- Build attribute reference E'Nam(Dim)
3316 -----------------------------------
3317 -- Construct_Attribute_Reference --
3318 -----------------------------------
3320 function Construct_Attribute_Reference
3324 is
3325 begin
3326 return
3334 -- Start processing for Check_Subscripts
3336 begin
3340 Left_Opnd =>
3341 Construct_Attribute_Reference
3344 Right_Opnd =>
3345 Construct_Attribute_Reference
3350 Left_Opnd =>
3351 Construct_Attribute_Reference
3354 Right_Opnd =>
3355 Construct_Attribute_Reference
3360 Cond :=
3362 Left_Opnd =>
3373 -- These are the cases where constraint checks may be
3374 -- required, e.g. records with possible discriminants
3376 else
3377 -- Expand the test into a series of discriminant comparisons.
3378 -- The expression that is built is the negation of the one
3379 -- that is used for checking discriminant constraints.
3389 Left_Opnd =>
3396 else
3407 --------------------------------
3408 -- Expand_N_Indexed_Component --
3409 --------------------------------
3417 begin
3418 -- A special optimization, if we have an indexed component that
3419 -- is selecting from a slice, then we can eliminate the slice,
3420 -- since, for example, x (i .. j)(k) is identical to x(k). The
3421 -- only difference is the range check required by the slice. The
3422 -- range check for the slice itself has already been generated.
3423 -- The range check for the subscripting operation is ensured
3424 -- by converting the subject to the subtype of the slice.
3426 -- This optimization not only generates better code, avoiding
3427 -- slice messing especially in the packed case, but more importantly
3428 -- bypasses some problems in handling this peculiar case, for
3429 -- example, the issue of dealing specially with object renamings.
3436 Convert_To
3443 -- If the prefix is an access type, then we unconditionally rewrite
3444 -- if as an explicit deference. This simplifies processing for several
3445 -- cases, including packed array cases and certain cases in which
3446 -- checks must be generated. We used to try to do this only when it
3447 -- was necessary, but it cleans up the code to do it all the time.
3454 -- Generate index and validity checks
3462 -- All done for the non-packed case
3468 -- For packed arrays that are not bit-packed (i.e. the case of an array
3469 -- with one or more index types with a non-coniguous enumeration type),
3470 -- we can always use the normal packed element get circuit.
3477 -- For a reference to a component of a bit packed array, we have to
3478 -- convert it to a reference to the corresponding Packed_Array_Type.
3479 -- We only want to do this for simple references, and not for:
3481 -- Left side of assignment, or prefix of left side of assignment,
3482 -- or prefix of the prefix, to handle packed arrays of packed arrays,
3483 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3485 -- Renaming objects in renaming associations
3486 -- This case is handled when a use of the renamed variable occurs
3488 -- Actual parameters for a procedure call
3489 -- This case is handled in Exp_Ch6.Expand_Actuals
3491 -- The second expression in a 'Read attribute reference
3493 -- The prefix of an address or size attribute reference
3495 -- The following circuit detects these exceptions
3497 declare
3501 begin
3502 loop
3509 and then
3511 then
3516 or else
3519 then
3524 then
3527 -- If the expression is an index of an indexed component,
3528 -- it must be expanded regardless of context.
3532 then
3538 then
3544 then
3550 then
3553 else
3558 -- Keep looking up tree for unchecked expression, or if we are
3559 -- the prefix of a possible assignment left side.
3567 ---------------------
3568 -- Expand_N_Not_In --
3569 ---------------------
3571 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
3572 -- can be done. This avoids needing to duplicate this expansion code.
3579 begin
3582 Right_Opnd =>
3587 -- We want this tp appear as coming from source if original does (see
3588 -- tranformations in Expand_N_In).
3593 -- Now analyze tranformed node
3598 -------------------
3599 -- Expand_N_Null --
3600 -------------------
3602 -- The only replacement required is for the case of a null of type
3603 -- that is an access to protected subprogram. We represent such
3604 -- access values as a record, and so we must replace the occurrence
3605 -- of null by the equivalent record (with a null address and a null
3606 -- pointer in it), so that the backend creates the proper value.
3613 begin
3615 Agg :=
3624 -- For subsequent semantic analysis, the node must retain its
3625 -- type. Gigi in any case replaces this type by the corresponding
3626 -- record type before processing the node.
3631 exception
3636 ---------------------
3637 -- Expand_N_Op_Abs --
3638 ---------------------
3644 begin
3647 -- Deal with software overflow checking
3649 if not Backend_Overflow_Checks_On_Target
3652 then
3653 -- The only case to worry about is when the argument is
3654 -- equal to the largest negative number, so what we do is
3655 -- to insert the check:
3657 -- [constraint_error when Expr = typ'Base'First]
3659 -- with the usual Duplicate_Subexpr use coding for expr
3663 Condition =>
3666 Right_Opnd =>
3668 Prefix =>
3674 -- Vax floating-point types case
3681 ---------------------
3682 -- Expand_N_Op_Add --
3683 ---------------------
3688 begin
3691 -- N + 0 = 0 + N = N for integer types
3696 then
3702 then
3708 -- Arithmetic overflow checks for signed integer/fixed point types
3712 then
3716 -- Vax floating-point types case
3723 ---------------------
3724 -- Expand_N_Op_And --
3725 ---------------------
3730 begin
3744 ------------------------
3745 -- Expand_N_Op_Concat --
3746 ------------------------
3749 -- This is initialized the first time this routine is called. It records
3750 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3751 -- available in the run-time:
3752 --
3753 -- 0 None available
3754 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
3755 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3756 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3757 -- 5 All routines including RE_Str_Concat_5 available
3760 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3761 -- all three are available, False if any one of these is unavailable.
3765 -- List of operands to be concatenated
3768 -- Single operand for concatenation
3771 -- Node which is to be replaced by the result of concatenating
3772 -- the nodes in the list Opnds.
3775 -- Array type of concatenation result type
3778 -- Component type of concatenation represented by Cnode
3780 begin
3781 -- Initialize global variables showing run-time status
3792 else
3796 Char_Concat_Available :=
3798 and then
3800 and then
3804 -- Ensure validity of both operands
3808 -- If we are the left operand of a concatenation higher up the
3809 -- tree, then do nothing for now, since we want to deal with a
3810 -- series of concatenations as a unit.
3814 then
3818 -- We get here with a concatenation whose left operand may be a
3819 -- concatenation itself with a consistent type. We need to process
3820 -- these concatenation operands from left to right, which means
3821 -- from the deepest node in the tree to the highest node.
3828 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
3829 -- nodes above, so now we process bottom up, doing the operations. We
3830 -- gather a string that is as long as possible up to five operands
3832 -- The outer loop runs more than once if there are more than five
3833 -- concatenations of type Standard.String, the most we handle for
3834 -- this case, or if more than one concatenation type is involved.
3840 -- The inner loop gathers concatenation operands. We gather any
3841 -- number of these in the non-string case, or if no concatenation
3842 -- routines are available for string (since in that case we will
3843 -- treat string like any other non-string case). Otherwise we only
3844 -- gather as many operands as can be handled by the available
3845 -- procedures in the run-time library (normally 5, but may be
3846 -- less for the configurable run-time case).
3850 or else
3852 or else
3854 Max_Available_String_Operands)
3857 loop
3862 -- Here we process the collected operands. First we convert
3863 -- singleton operands to singleton aggregates. This is skipped
3864 -- however for the case of two operands of type String, since
3865 -- we have special routines for these cases.
3871 or else not Char_Concat_Available
3872 then
3874 loop
3887 -- Now call appropriate continuation routine
3891 then
3893 else
3902 ------------------------
3903 -- Expand_N_Op_Divide --
3904 ------------------------
3914 and then
3918 begin
3925 -- N / 1 = N for integer types
3932 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3933 -- Is_Power_Of_2_For_Shift is set means that we know that our left
3934 -- operand is an unsigned integer, as required for this to work.
3939 -- We cannot do this transformation in configurable run time mode if we
3940 -- have 64-bit -- integers and long shifts are not available.
3942 and then
3945 then
3949 Right_Opnd =>
3955 -- Do required fixup of universal fixed operation
3962 -- Divisions with fixed-point results
3966 -- No special processing if Treat_Fixed_As_Integer is set,
3967 -- since from a semantic point of view such operations are
3968 -- simply integer operations and will be treated that way.
3973 else
3978 -- Other cases of division of fixed-point operands. Again we
3979 -- exclude the case where Treat_Fixed_As_Integer is set.
3984 then
3987 else
3992 -- Mixed-mode operations can appear in a non-static universal
3993 -- context, in which case the integer argument must be converted
3994 -- explicitly.
3998 then
4006 then
4012 -- Non-fixed point cases, do integer zero divide and overflow checks
4017 -- Check for 64-bit division available, or long shifts if the divisor
4018 -- is a small power of 2 (since such divides will be converted into
4019 -- long shifts.
4022 and then not Support_64_Bit_Divides_On_Target
4023 and then
4025 or else not Support_Long_Shifts_On_Target
4032 then
4036 -- Deal with Vax_Float
4044 --------------------
4045 -- Expand_N_Op_Eq --
4046 --------------------
4061 -- If a constructed equality exists for the type or for its parent,
4062 -- build and analyze call, adding conversions if the operation is
4063 -- inherited.
4066 -- Determines whether a type has a subcompoment of an unconstrained
4067 -- Unchecked_Union subtype. Typ is a record type.
4069 -------------------------
4070 -- Build_Equality_Call --
4071 -------------------------
4078 begin
4081 then
4086 -- If we have an Unchecked_Union, we need to add the inferred
4087 -- discriminant values as actuals in the function call. At this
4088 -- point, the expansion has determined that both operands have
4089 -- inferable discriminants.
4092 declare
4098 begin
4099 -- Per-object constrained selected components require special
4100 -- attention. If the enclosing scope of the component is an
4101 -- Unchecked_Union, we cannot reference its discriminants
4102 -- directly. This is why we use the two extra parameters of
4103 -- the equality function of the enclosing Unchecked_Union.
4105 -- type UU_Type (Discr : Integer := 0) is
4106 -- . . .
4107 -- end record;
4108 -- pragma Unchecked_Union (UU_Type);
4110 -- 1. Unchecked_Union enclosing record:
4112 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
4113 -- . . .
4114 -- Comp : UU_Type (Discr);
4115 -- . . .
4116 -- end Enclosing_UU_Type;
4117 -- pragma Unchecked_Union (Enclosing_UU_Type);
4119 -- Obj1 : Enclosing_UU_Type;
4120 -- Obj2 : Enclosing_UU_Type (1);
4122 -- [. . .] Obj1 = Obj2 [. . .]
4124 -- Generated code:
4126 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4128 -- A and B are the formal parameters of the equality function
4129 -- of Enclosing_UU_Type. The function always has two extra
4130 -- formals to capture the inferred discriminant values.
4132 -- 2. Non-Unchecked_Union enclosing record:
4134 -- type
4135 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
4136 -- is record
4137 -- . . .
4138 -- Comp : UU_Type (Discr);
4139 -- . . .
4140 -- end Enclosing_Non_UU_Type;
4142 -- Obj1 : Enclosing_Non_UU_Type;
4143 -- Obj2 : Enclosing_Non_UU_Type (1);
4145 -- ... Obj1 = Obj2 ...
4147 -- Generated code:
4149 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
4150 -- obj1.discr, obj2.discr)) then
4152 -- In this case we can directly reference the discriminants of
4153 -- the enclosing record.
4155 -- Lhs of equality
4158 and then Has_Per_Object_Constraint
4160 then
4161 -- Enclosing record is an Unchecked_Union, use formal A
4165 then
4166 Lhs_Discr_Val :=
4170 -- Enclosing record is of a non-Unchecked_Union type, it is
4171 -- possible to reference the discriminant.
4173 else
4174 Lhs_Discr_Val :=
4177 Selector_Name =>
4178 New_Copy
4179 (Get_Discriminant_Value
4181 Lhs_Type,
4185 -- Comment needed here ???
4187 else
4188 -- Infer the discriminant value
4190 Lhs_Discr_Val :=
4191 New_Copy
4192 (Get_Discriminant_Value
4194 Lhs_Type,
4198 -- Rhs of equality
4201 and then Has_Per_Object_Constraint
4203 then
4204 if Is_Unchecked_Union
4206 then
4207 Rhs_Discr_Val :=
4211 else
4212 Rhs_Discr_Val :=
4215 Selector_Name =>
4218 Rhs_Type,
4222 else
4223 Rhs_Discr_Val :=
4226 Rhs_Type,
4235 L_Exp,
4236 R_Exp,
4237 Lhs_Discr_Val,
4238 Rhs_Discr_Val)));
4241 -- Normal case, not an unchecked union
4243 else
4253 ------------------------------------
4254 -- Has_Unconstrained_UU_Component --
4255 ------------------------------------
4257 function Has_Unconstrained_UU_Component
4259 is
4265 function Component_Is_Unconstrained_UU
4267 -- Determines whether the subtype of the component is an
4268 -- unconstrained Unchecked_Union.
4270 function Variant_Is_Unconstrained_UU
4272 -- Determines whether a component of the variant has an unconstrained
4273 -- Unchecked_Union subtype.
4275 -----------------------------------
4276 -- Component_Is_Unconstrained_UU --
4277 -----------------------------------
4279 function Component_Is_Unconstrained_UU
4281 is
4282 begin
4287 declare
4291 begin
4292 -- Unconstrained nominal type. In the case of a constraint
4293 -- present, the node kind would have been N_Subtype_Indication.
4303 ---------------------------------
4304 -- Variant_Is_Unconstrained_UU --
4305 ---------------------------------
4307 function Variant_Is_Unconstrained_UU
4309 is
4312 begin
4317 -- We only need to test one component
4319 declare
4322 begin
4332 -- None of the components withing the variant were of
4333 -- unconstrained Unchecked_Union type.
4338 -- Start of processing for Has_Unconstrained_UU_Component
4340 begin
4348 -- Inspect available components
4351 declare
4354 begin
4357 -- One component is sufficent
4368 -- Inspect available components withing variants
4371 declare
4374 begin
4377 -- One component within a variant is sufficent
4388 -- Neither the available components, nor the components inside the
4389 -- variant parts were of an unconstrained Unchecked_Union subtype.
4394 -- Start of processing for Expand_N_Op_Eq
4396 begin
4403 else
4407 -- It may happen in error situations that the underlying type is not
4408 -- set. The error will be detected later, here we just defend the
4409 -- expander code.
4417 -- Boolean types (requiring handling of non-standard case)
4425 -- Array types
4429 -- If we are doing full validity checking, then expand out array
4430 -- comparisons to make sure that we check the array elements.
4433 declare
4435 Force_Validity_Checks;
4436 begin
4439 Expand_Array_Equality
4443 Bodies,
4444 Typl));
4450 -- Packed case where both operands are known aligned
4455 then
4458 -- Where the component type is elementary we can use a block bit
4459 -- comparison (if supported on the target) exception in the case
4460 -- of floating-point (negative zero issues require element by
4461 -- element comparison), and atomic types (where we must be sure
4462 -- to load elements independently) and possibly unaligned arrays.
4469 and then Support_Composite_Compare_On_Target
4470 then
4473 -- For composite and floating-point cases, expand equality loop
4474 -- to make sure of using proper comparisons for tagged types,
4475 -- and correctly handling the floating-point case.
4477 else
4479 Expand_Array_Equality
4483 Bodies,
4484 Typl));
4489 -- Record Types
4493 -- For tagged types, use the primitive "="
4497 -- If this is derived from an untagged private type completed
4498 -- with a tagged type, it does not have a full view, so we
4499 -- use the primitive operations of the private type.
4500 -- This check should no longer be necessary when these
4501 -- types receive their full views ???
4507 then
4508 -- Search for equality operation, checking that the
4509 -- operands have the same type. Note that we must find
4510 -- a matching entry, or something is very wrong!
4518 and then
4527 -- Find the type's predefined equality or an overriding
4528 -- user-defined equality. The reason for not simply calling
4529 -- Find_Prim_Op here is that there may be a user-defined
4530 -- overloaded equality op that precedes the equality that
4531 -- we want, so we have to explicitly search (e.g., there
4532 -- could be an equality with two different parameter types).
4534 else
4544 and then
4556 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
4557 -- predefined equality operator for a type which has a subcomponent
4558 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
4565 -- Prevent Gigi from generating incorrect code by rewriting the
4566 -- equality as a standard False.
4573 -- If we can infer the discriminants of the operands, we make a
4574 -- call to the TSS equality function.
4577 and then
4579 then
4580 Build_Equality_Call
4583 else
4584 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4585 -- the predefined equality operator for an Unchecked_Union type
4586 -- if either of the operands lack inferable discriminants.
4592 -- Prevent Gigi from generating incorrect code by rewriting
4593 -- the equality as a standard False.
4600 -- If a type support function is present (for complex cases), use it
4603 Build_Equality_Call
4606 -- Otherwise expand the component by component equality. Note that
4607 -- we never use block-bit coparisons for records, because of the
4608 -- problems with gaps. The backend will often be able to recombine
4609 -- the separate comparisons that we generate here.
4611 else
4622 -- Test if result is known at compile time
4626 -- If we still have comparison for Vax_Float, process it
4634 -----------------------
4635 -- Expand_N_Op_Expon --
4636 -----------------------
4654 begin
4657 -- If either operand is of a private type, then we have the use of
4658 -- an intrinsic operator, and we get rid of the privateness, by using
4659 -- root types of underlying types for the actual operation. Otherwise
4660 -- the private types will cause trouble if we expand multiplications
4661 -- or shifts etc. We also do this transformation if the result type
4662 -- is different from the base type.
4665 or else
4667 or else
4669 or else
4671 then
4672 declare
4676 begin
4687 -- Test for case of known right argument
4692 -- We only fold small non-negative exponents. You might think we
4693 -- could fold small negative exponents for the real case, but we
4694 -- can't because we are required to raise Constraint_Error for
4695 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
4696 -- See ACVC test C4A012B.
4700 -- X ** 0 = 1 (or 1.0)
4705 else
4709 -- X ** 1 = X
4714 -- X ** 2 = X * X
4717 Xnode :=
4722 -- X ** 3 = X * X * X
4725 Xnode :=
4727 Left_Opnd =>
4733 -- X ** 4 ->
4734 -- En : constant base'type := base * base;
4735 -- ...
4736 -- En * En
4739 Temp :=
4747 Expression =>
4752 Xnode :=
4764 -- Case of (2 ** expression) appearing as an argument of an integer
4765 -- multiplication, or as the right argument of a division of a non-
4766 -- negative integer. In such cases we leave the node untouched, setting
4767 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
4768 -- of the higher level node converts it into a shift.
4775 and then not Ovflo
4777 then
4778 declare
4783 begin
4785 and then
4787 or else
4791 or else
4797 then
4804 -- Fall through if exponentiation must be done using a runtime routine
4806 -- First deal with modular case
4810 -- Non-binary case, we call the special exponentiation routine for
4811 -- the non-binary case, converting the argument to Long_Long_Integer
4812 -- and passing the modulus value. Then the result is converted back
4813 -- to the base type.
4823 Exp))));
4825 -- Binary case, in this case, we call one of two routines, either
4826 -- the unsigned integer case, or the unsigned long long integer
4827 -- case, with a final "and" operation to do the required mod.
4829 else
4832 else
4839 Left_Opnd =>
4844 Exp)),
4845 Right_Opnd =>
4850 -- Common exit point for modular type case
4855 -- Signed integer cases, done using either Integer or Long_Long_Integer.
4856 -- It is not worth having routines for Short_[Short_]Integer, since for
4857 -- most machines it would not help, and it would generate more code that
4858 -- might need certification when a certified run time is required.
4860 -- In the integer cases, we have two routines, one for when overflow
4861 -- checks are required, and one when they are not required, since there
4862 -- is a real gain in omitting checks on many machines.
4866 and then
4869 then
4874 else
4883 else
4887 -- Floating-point cases, always done using Long_Long_Float. We do not
4888 -- need separate routines for the overflow case here, since in the case
4889 -- of floating-point, we generate infinities anyway as a rule (either
4890 -- that or we automatically trap overflow), and if there is an infinity
4891 -- generated and a range check is required, the check will fail anyway.
4893 else
4899 -- Common processing for integer cases and floating-point cases.
4900 -- If we are in the right type, we can call runtime routine directly
4905 then
4911 -- Otherwise we have to introduce conversions (conversions are also
4912 -- required in the universal cases, since the runtime routine is
4913 -- typed using one of the standard types.
4915 else
4922 Exp))));
4928 exception
4933 --------------------
4934 -- Expand_N_Op_Ge --
4935 --------------------
4943 begin
4960 -- If we still have comparison, and Vax_Float type, process it
4968 --------------------
4969 -- Expand_N_Op_Gt --
4970 --------------------
4978 begin
4995 -- If we still have comparison, and Vax_Float type, process it
5003 --------------------
5004 -- Expand_N_Op_Le --
5005 --------------------
5013 begin
5030 -- If we still have comparison, and Vax_Float type, process it
5038 --------------------
5039 -- Expand_N_Op_Lt --
5040 --------------------
5048 begin
5065 -- If we still have comparison, and Vax_Float type, process it
5073 -----------------------
5074 -- Expand_N_Op_Minus --
5075 -----------------------
5081 begin
5084 if not Backend_Overflow_Checks_On_Target
5087 then
5088 -- Software overflow checking expands -expr into (0 - expr)
5097 -- Vax floating-point types case
5104 ---------------------
5105 -- Expand_N_Op_Mod --
5106 ---------------------
5124 begin
5130 -- Convert mod to rem if operands are known non-negative. We do this
5131 -- since it is quite likely that this will improve the quality of code,
5132 -- (the operation now corresponds to the hardware remainder), and it
5133 -- does not seem likely that it could be harmful.
5136 and then
5138 then
5144 -- Instead of reanalyzing the node we do the analysis manually.
5145 -- This avoids anomalies when the replacement is done in an
5146 -- instance and is epsilon more efficient.
5155 -- Otherwise, normal mod processing
5157 else
5162 -- Apply optimization x mod 1 = 0. We don't really need that with
5163 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5164 -- certainly harmless.
5169 then
5175 -- Deal with annoying case of largest negative number remainder
5176 -- minus one. Gigi does not handle this case correctly, because
5177 -- it generates a divide instruction which may trap in this case.
5179 -- In fact the check is quite easy, if the right operand is -1,
5180 -- then the mod value is always 0, and we can just ignore the
5181 -- left operand completely in this case.
5183 -- The operand type may be private (e.g. in the expansion of an
5184 -- an intrinsic operation) so we must use the underlying type to
5185 -- get the bounds, and convert the literals explicitly.
5187 LLB :=
5188 Expr_Value
5192 and then
5194 then
5200 Right_Opnd =>
5213 --------------------------
5214 -- Expand_N_Op_Multiply --
5215 --------------------------
5234 begin
5237 -- Special optimizations for integer types
5241 -- N * 0 = 0 * N = 0 for integer types
5245 or else
5248 then
5254 -- N * 1 = 1 * N = N for integer types
5256 -- This optimisation is not done if we are going to
5257 -- rewrite the product 1 * 2 ** N to a shift.
5261 and then not Lp2
5262 then
5268 and then not Rp2
5269 then
5275 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5276 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5277 -- operand is an integer, as required for this to work.
5282 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
5287 Right_Opnd =>
5294 else
5298 Right_Opnd =>
5304 -- Same processing for the operands the other way round
5310 Right_Opnd =>
5316 -- Do required fixup of universal fixed operation
5323 -- Multiplications with fixed-point results
5327 -- No special processing if Treat_Fixed_As_Integer is set,
5328 -- since from a semantic point of view such operations are
5329 -- simply integer operations and will be treated that way.
5333 -- Case of fixed * integer => fixed
5338 -- Case of integer * fixed => fixed
5343 -- Case of fixed * fixed => fixed
5345 else
5350 -- Other cases of multiplication of fixed-point operands. Again
5351 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
5355 then
5358 else
5363 -- Mixed-mode operations can appear in a non-static universal
5364 -- context, in which case the integer argument must be converted
5365 -- explicitly.
5369 then
5376 then
5381 -- Non-fixed point cases, check software overflow checking required
5386 -- Deal with VAX float case
5394 --------------------
5395 -- Expand_N_Op_Ne --
5396 --------------------
5401 begin
5402 -- Case of elementary type with standard operator
5406 then
5409 -- Boolean types (requiring handling of non-standard case)
5420 -- If we still have comparison for Vax_Float, process it
5427 -- For all cases other than elementary types, we rewrite node as the
5428 -- negation of an equality operation, and reanalyze. The equality to be
5429 -- used is defined in the same scope and has the same signature. This
5430 -- signature must be set explicitly since in an instance it may not have
5431 -- the same visibility as in the generic unit. This avoids duplicating
5432 -- or factoring the complex code for record/array equality tests etc.
5434 else
5435 declare
5440 begin
5443 Neg :=
5445 Right_Opnd =>
5455 -- For navigation purposes, the inequality is treated as an
5456 -- implicit reference to the corresponding equality. Preserve the
5457 -- Comes_From_ source flag so that the proper Xref entry is
5458 -- generated.
5468 ---------------------
5469 -- Expand_N_Op_Not --
5470 ---------------------
5472 -- If the argument is other than a Boolean array type, there is no
5473 -- special expansion required.
5475 -- For the packed case, we call the special routine in Exp_Pakd, except
5476 -- that if the component size is greater than one, we use the standard
5477 -- routine generating a gruesome loop (it is so peculiar to have packed
5478 -- arrays with non-standard Boolean representations anyway, so it does
5479 -- not matter that we do not handle this case efficiently).
5481 -- For the unpacked case (and for the special packed case where we have
5482 -- non standard Booleans, as discussed above), we generate and insert
5483 -- into the tree the following function definition:
5485 -- function Nnnn (A : arr) is
5486 -- B : arr;
5487 -- begin
5488 -- for J in a'range loop
5489 -- B (J) := not A (J);
5490 -- end loop;
5491 -- return B;
5492 -- end Nnnn;
5494 -- Here arr is the actual subtype of the parameter (and hence always
5495 -- constrained). Then we replace the not with a call to this function.
5511 begin
5514 -- For boolean operand, deal with non-standard booleans
5523 -- Only array types need any other processing
5529 -- Case of array operand. If bit packed with a component size of 1,
5530 -- handle it in Exp_Pakd if the operand is known to be aligned.
5535 then
5540 -- Case of array operand which is not bit-packed. If the context is
5541 -- a safe assignment, call in-place operation, If context is a larger
5542 -- boolean expression in the context of a safe assignment, expansion is
5543 -- done by enclosing operation.
5555 -- Special case the negation of a binary operation
5560 and then Safe_In_Place_Array_Op
5562 then
5569 then
5570 declare
5575 begin
5579 then
5580 -- (not A) op (not B) can be reduced to a single call
5586 then
5587 -- A xor (not B) can also be special-cased
5599 A_J :=
5604 B_J :=
5609 Loop_Statement :=
5613 Iteration_Scheme =>
5615 Loop_Parameter_Specification =>
5618 Discrete_Subtype_Definition =>
5633 Specification =>
5647 Handled_Statement_Sequence =>
5650 Loop_Statement,
5652 Expression =>
5663 --------------------
5664 -- Expand_N_Op_Or --
5665 --------------------
5670 begin
5684 ----------------------
5685 -- Expand_N_Op_Plus --
5686 ----------------------
5689 begin
5693 ---------------------
5694 -- Expand_N_Op_Rem --
5695 ---------------------
5712 begin
5719 -- Apply optimization x rem 1 = 0. We don't really need that with
5720 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5721 -- certainly harmless.
5726 then
5732 -- Deal with annoying case of largest negative number remainder
5733 -- minus one. Gigi does not handle this case correctly, because
5734 -- it generates a divide instruction which may trap in this case.
5736 -- In fact the check is quite easy, if the right operand is -1,
5737 -- then the remainder is always 0, and we can just ignore the
5738 -- left operand completely in this case.
5743 -- The operand type may be private (e.g. in the expansion of an
5744 -- an intrinsic operation) so we must use the underlying type to
5745 -- get the bounds, and convert the literals explicitly.
5747 LLB :=
5748 Expr_Value
5751 -- Now perform the test, generating code only if needed
5754 and then
5756 then
5762 Right_Opnd =>
5776 -----------------------------
5777 -- Expand_N_Op_Rotate_Left --
5778 -----------------------------
5781 begin
5785 ------------------------------
5786 -- Expand_N_Op_Rotate_Right --
5787 ------------------------------
5790 begin
5794 ----------------------------
5795 -- Expand_N_Op_Shift_Left --
5796 ----------------------------
5799 begin
5803 -----------------------------
5804 -- Expand_N_Op_Shift_Right --
5805 -----------------------------
5808 begin
5812 ----------------------------------------
5813 -- Expand_N_Op_Shift_Right_Arithmetic --
5814 ----------------------------------------
5817 begin
5821 --------------------------
5822 -- Expand_N_Op_Subtract --
5823 --------------------------
5828 begin
5831 -- N - 0 = N for integer types
5836 then
5841 -- Arithemtic overflow checks for signed integer/fixed point types
5845 then
5848 -- Vax floating-point types case
5855 ---------------------
5856 -- Expand_N_Op_Xor --
5857 ---------------------
5862 begin
5876 ----------------------
5877 -- Expand_N_Or_Else --
5878 ----------------------
5880 -- Expand into conditional expression if Actions present, and also
5881 -- deal with optimizing case of arguments being True or False.
5890 begin
5891 -- Deal with non-standard booleans
5899 -- Check for cases of left argument is True or False
5903 -- If left argument is False, change (False or else Right) to Right.
5904 -- Any actions associated with Right will be executed unconditionally
5905 -- and can thus be inserted into the tree unconditionally.
5916 -- If left argument is True, change (True and then Right) to
5917 -- True. In this case we can forget the actions associated with
5918 -- Right, since they will never be executed.
5929 -- If Actions are present, we expand
5931 -- left or else right
5933 -- into
5935 -- if left then True else right end
5937 -- with the actions becoming the Else_Actions of the conditional
5938 -- expression. This conditional expression is then further expanded
5939 -- (and will eventually disappear)
5946 Left,
5948 Right)));
5956 -- No actions present, check for cases of right argument True/False
5960 -- Change (Left or else False) to Left. Note that we know there
5961 -- are no actions associated with the True operand, since we
5962 -- just checked for this case above.
5967 -- Change (Left or else True) to True, making sure to preserve
5968 -- any side effects associated with the Left operand.
5972 Rewrite
5980 -----------------------------------
5981 -- Expand_N_Qualified_Expression --
5982 -----------------------------------
5988 begin
5989 -- Do validity check if validity checking operands
5991 if Validity_Checks_On
5992 and then Validity_Check_Operands
5993 then
5997 -- Apply possible constraint check
6002 ---------------------------------
6003 -- Expand_N_Selected_Component --
6004 ---------------------------------
6006 -- If the selector is a discriminant of a concurrent object, rewrite the
6007 -- prefix to denote the corresponding record type.
6019 -- Gigi needs a temporary for prefixes that depend on a discriminant,
6020 -- unless the context of an assignment can provide size information.
6021 -- Don't we have a general routine that does this???
6023 -----------------------
6024 -- In_Left_Hand_Side --
6025 -----------------------
6028 begin
6036 -- Start of processing for Expand_N_Selected_Component
6038 begin
6039 -- Insert explicit dereference if required
6047 then
6054 -- Deal with discriminant check required
6058 -- Present the discrminant checking function to the backend,
6059 -- so that it can inline the call to the function.
6061 Add_Inlined_Body
6062 (Discriminant_Checking_Func
6065 -- Now reset the flag and generate the call
6071 -- Gigi cannot handle unchecked conversions that are the prefix of a
6072 -- selected component with discriminants. This must be checked during
6073 -- expansion, because during analysis the type of the selector is not
6074 -- known at the point the prefix is analyzed. If the conversion is the
6075 -- target of an assignment, then we cannot force the evaluation.
6080 then
6084 -- Remaining processing applies only if selector is a discriminant
6088 -- If the selector is a discriminant of a constrained record type,
6089 -- we may be able to rewrite the expression with the actual value
6090 -- of the discriminant, a useful optimization in some cases.
6095 then
6096 -- Do this optimization for discrete types only, and not for
6097 -- access types (access discriminants get us into trouble!)
6102 -- Don't do this on the left hand of an assignment statement.
6103 -- Normally one would think that references like this would
6104 -- not occur, but they do in generated code, and mean that
6105 -- we really do want to assign the discriminant!
6109 then
6112 -- Don't do this optimization for the prefix of an attribute
6113 -- or the operand of an object renaming declaration since these
6114 -- are contexts where we do not want the value anyway.
6119 then
6122 -- Don't do this optimization if we are within the code for a
6123 -- discriminant check, since the whole point of such a check may
6124 -- be to verify the condition on which the code below depends!
6129 -- Green light to see if we can do the optimization. There is
6130 -- still one condition that inhibits the optimization below
6131 -- but now is the time to check the particular discriminant.
6133 else
6134 -- Loop through discriminants to find the matching
6135 -- discriminant constraint to see if we can copy it.
6141 -- Check if this is the matching discriminant
6145 -- Here we have the matching discriminant. Check for
6146 -- the case of a discriminant of a component that is
6147 -- constrained by an outer discriminant, which cannot
6148 -- be optimized away.
6150 if
6151 Denotes_Discriminant
6153 then
6156 -- In the context of a case statement, the expression
6157 -- may have the base type of the discriminant, and we
6158 -- need to preserve the constraint to avoid spurious
6159 -- errors on missing cases.
6163 then
6166 Subtype_Mark =>
6168 Expression =>
6172 -- In case that comes out as a static expression,
6173 -- reset it (a selected component is never static).
6178 -- Otherwise we can just copy the constraint, but the
6179 -- result is certainly not static! In some cases the
6180 -- discriminant constraint has been analyzed in the
6181 -- context of the original subtype indication, but for
6182 -- itypes the constraint might not have been analyzed
6183 -- yet, and this must be done now.
6185 else
6197 -- Note: the above loop should always find a matching
6198 -- discriminant, but if it does not, we just missed an
6199 -- optimization due to some glitch (perhaps a previous
6200 -- error), so ignore.
6205 -- The only remaining processing is in the case of a discriminant of
6206 -- a concurrent object, where we rewrite the prefix to denote the
6207 -- corresponding record type. If the type is derived and has renamed
6208 -- discriminants, use corresponding discriminant, which is the one
6209 -- that appears in the corresponding record.
6219 then
6223 New_N :=
6225 Prefix =>
6235 --------------------
6236 -- Expand_N_Slice --
6237 --------------------
6246 -- Check whether the argument is an actual for a procedure call,
6247 -- in which case the expansion of a bit-packed slice is deferred
6248 -- until the call itself is expanded. The reason this is required
6249 -- is that we might have an IN OUT or OUT parameter, and the copy out
6250 -- is essential, and that copy out would be missed if we created a
6251 -- temporary here in Expand_N_Slice. Note that we don't bother
6252 -- to test specifically for an IN OUT or OUT mode parameter, since it
6253 -- is a bit tricky to do, and it is harmless to defer expansion
6254 -- in the IN case, since the call processing will still generate the
6255 -- appropriate copy in operation, which will take care of the slice.
6258 -- Create a named variable for the value of the slice, in
6259 -- cases where the back-end cannot handle it properly, e.g.
6260 -- when packed types or unaligned slices are involved.
6262 -------------------------
6263 -- Is_Procedure_Actual --
6264 -------------------------
6269 begin
6270 loop
6271 -- If our parent is a procedure call we can return
6276 -- If our parent is a type conversion, keep climbing the
6277 -- tree, since a type conversion can be a procedure actual.
6278 -- Also keep climbing if parameter association or a qualified
6279 -- expression, since these are additional cases that do can
6280 -- appear on procedure actuals.
6285 then
6288 -- Any other case is not what we are looking for
6290 else
6296 --------------------
6297 -- Make_Temporary --
6298 --------------------
6304 begin
6305 Decl :=
6313 Decl,
6322 -- Start of processing for Expand_N_Slice
6324 begin
6325 -- Special handling for access types
6338 -- Range checks are potentially also needed for cases involving
6339 -- a slice indexed by a subtype indication, but Do_Range_Check
6340 -- can currently only be set for expressions ???
6346 then
6350 -- The remaining case to be handled is packed slices. We can leave
6351 -- packed slices as they are in the following situations:
6353 -- 1. Right or left side of an assignment (we can handle this
6354 -- situation correctly in the assignment statement expansion).
6356 -- 2. Prefix of indexed component (the slide is optimized away
6357 -- in this case, see the start of Expand_N_Slice.
6359 -- 3. Object renaming declaration, since we want the name of
6360 -- the slice, not the value.
6362 -- 4. Argument to procedure call, since copy-in/copy-out handling
6363 -- may be required, and this is handled in the expansion of
6364 -- call itself.
6366 -- 5. Prefix of an address attribute (this is an error which
6367 -- is caught elsewhere, and the expansion would intefere
6368 -- with generating the error message).
6372 -- Apply transformation for actuals of a function call,
6373 -- where Expand_Actuals is not used.
6377 then
6378 Make_Temporary;
6384 then
6390 then
6395 then
6398 else
6399 Make_Temporary;
6403 ------------------------------
6404 -- Expand_N_Type_Conversion --
6405 ------------------------------
6414 -- This is called in the case of record and array type conversions
6415 -- to see if there is a change of representation to be handled.
6416 -- Change of representation is actually handled at the assignment
6417 -- statement level, and what this procedure does is rewrite node N
6418 -- conversion as an assignment to temporary. If there is no change
6419 -- of representation, then the conversion node is unchanged.
6422 -- Handles generation of range check for real target value
6424 -----------------------------------
6425 -- Handle_Changed_Representation --
6426 -----------------------------------
6436 begin
6437 -- Nothing else to do if no change of representation
6442 -- The real change of representation work is done by the assignment
6443 -- statement processing. So if this type conversion is appearing as
6444 -- the expression of an assignment statement, nothing needs to be
6445 -- done to the conversion.
6450 -- Otherwise we need to generate a temporary variable, and do the
6451 -- change of representation assignment into that temporary variable.
6452 -- The conversion is then replaced by a reference to this variable.
6454 else
6457 -- If type is unconstrained we have to add a constraint,
6458 -- copied from the actual value of the left hand side.
6473 Selector_Name =>
6484 -- We convert the bounds explicitly. We use an unchecked
6485 -- conversion because bounds checks are done elsewhere.
6489 Low_Bound =>
6492 Prefix =>
6493 Duplicate_Subexpr_No_Checks
6499 High_Bound =>
6502 Prefix =>
6503 Duplicate_Subexpr_No_Checks
6517 Odef :=
6520 Constraint =>
6526 Decl :=
6533 -- Insert required actions. It is essential to suppress checks
6534 -- since we have suppressed default initialization, which means
6535 -- that the variable we create may have no discriminants.
6538 New_List (
6539 Decl,
6550 ----------------------
6551 -- Real_Range_Check --
6552 ----------------------
6554 -- Case of conversions to floating-point or fixed-point. If range
6555 -- checks are enabled and the target type has a range constraint,
6556 -- we convert:
6558 -- typ (x)
6560 -- to
6562 -- Tnn : typ'Base := typ'Base (x);
6563 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
6564 -- Tnn
6566 -- This is necessary when there is a conversion of integer to float
6567 -- or to fixed-point to ensure that the correct checks are made. It
6568 -- is not necessary for float to float where it is enough to simply
6569 -- set the Do_Range_Check flag.
6579 begin
6580 -- Nothing to do if conversion was rewritten
6586 -- Nothing to do if range checks suppressed, or target has the
6587 -- same range as the base type (or is the base type).
6591 and then
6593 then
6597 -- Nothing to do if expression is an entity on which checks
6598 -- have been suppressed.
6602 then
6606 -- Nothing to do if bounds are all static and we can tell that
6607 -- the expression is within the bounds of the target. Note that
6608 -- if the operand is of an unconstrained floating-point type,
6609 -- then we do not trust it to be in range (might be infinite)
6611 declare
6615 begin
6622 then
6623 declare
6629 begin
6633 else
6641 then
6649 -- For float to float conversions, we are done
6652 and then
6654 then
6658 -- Otherwise rewrite the conversion as described above
6661 Rewrite
6665 -- Enable overflow except for case of integer to float conversions,
6666 -- where it is never required, since we can never have overflow in
6667 -- this case.
6673 Tnn :=
6684 Condition =>
6686 Left_Opnd =>
6689 Right_Opnd =>
6692 Prefix =>
6695 Right_Opnd =>
6698 Right_Opnd =>
6701 Prefix =>
6709 -- Start of processing for Expand_N_Type_Conversion
6711 begin
6712 -- Nothing at all to do if conversion is to the identical type
6713 -- so remove the conversion completely, it is useless.
6720 -- Nothing to do if this is the second argument of read. This
6721 -- is a "backwards" conversion that will be handled by the
6722 -- specialized code in attribute processing.
6727 then
6731 -- Here if we may need to expand conversion
6733 -- Do validity check if validity checking operands
6735 if Validity_Checks_On
6736 and then Validity_Check_Operands
6737 then
6741 -- Special case of converting from non-standard boolean type
6745 then
6751 -- Case of converting to an access type
6755 -- Apply an accessibility check if the operand is an
6756 -- access parameter. Note that other checks may still
6757 -- need to be applied below (such as tagged type checks).
6762 then
6765 -- If the level of the operand type is statically deeper
6766 -- then the level of the target type, then force Program_Error.
6767 -- Note that this can only occur for cases where the attribute
6768 -- is within the body of an instantiation (otherwise the
6769 -- conversion will already have been rejected as illegal).
6770 -- Note: warnings are issued by the analyzer for the instance
6771 -- cases.
6773 elsif In_Instance_Body
6776 then
6782 -- When the operand is a selected access discriminant
6783 -- the check needs to be made against the level of the
6784 -- object denoted by the prefix of the selected name.
6785 -- Force Program_Error for this case as well (this
6786 -- accessibility violation can only happen if within
6787 -- the body of an instantiation).
6789 elsif In_Instance_Body
6794 then
6802 -- Case of conversions of tagged types and access to tagged types
6804 -- When needed, that is to say when the expression is class-wide,
6805 -- Add runtime a tag check for (strict) downward conversion by using
6806 -- the membership test, generating:
6808 -- [constraint_error when Operand not in Target_Type'Class]
6810 -- or in the access type case
6812 -- [constraint_error
6813 -- when Operand /= null
6814 -- and then Operand.all not in
6815 -- Designated_Type (Target_Type)'Class]
6820 then
6821 -- Do not do any expansion in the access type case if the
6822 -- parent is a renaming, since this is an error situation
6823 -- which will be caught by Sem_Ch8, and the expansion can
6824 -- intefere with this error check.
6828 then
6832 -- Oherwise, proceed with processing tagged conversion
6834 declare
6840 begin
6845 else
6852 and then Is_Ancestor
6854 Actual_Target_Type)
6856 then
6857 -- The conversion is valid for any descendant of the
6858 -- target type
6863 Cond :=
6865 Left_Opnd =>
6870 Right_Opnd =>
6872 Left_Opnd =>
6874 Prefix =>
6876 Right_Opnd =>
6879 else
6880 Cond :=
6883 Right_Opnd =>
6892 declare
6894 begin
6895 Conv :=
6905 -- Case of other access type conversions
6910 -- Case of conversions from a fixed-point type
6912 -- These conversions require special expansion and processing, found
6913 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
6914 -- set, since from a semantic point of view, these are simple integer
6915 -- conversions, which do not need further processing.
6919 then
6920 -- We should never see universal fixed at this case, since the
6921 -- expansion of the constituent divide or multiply should have
6922 -- eliminated the explicit mention of universal fixed.
6926 -- Check for special case of the conversion to universal real
6927 -- that occurs as a result of the use of a round attribute.
6928 -- In this case, the real type for the conversion is taken
6929 -- from the target type of the Round attribute and the
6930 -- result must be marked as rounded.
6935 then
6940 -- Otherwise do correct fixed-conversion, but skip these if the
6941 -- Conversion_OK flag is set, because from a semantic point of
6942 -- view these are simple integer conversions needing no further
6943 -- processing (the backend will simply treat them as integers)
6948 Real_Range_Check;
6953 else
6956 Real_Range_Check;
6960 -- Case of conversions to a fixed-point type
6962 -- These conversions require special expansion and processing, found
6963 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6964 -- is set, since from a semantic point of view, these are simple
6965 -- integer conversions, which do not need further processing.
6969 then
6972 Real_Range_Check;
6973 else
6976 Real_Range_Check;
6979 -- Case of float-to-integer conversions
6981 -- We also handle float-to-fixed conversions with Conversion_OK set
6982 -- since semantically the fixed-point target is treated as though it
6983 -- were an integer in such cases.
6986 and then
6988 or else
6990 then
6991 -- Special processing required if the conversion is the expression
6992 -- of a Truncation attribute reference. In this case we replace:
6994 -- ityp (ftyp'Truncation (x))
6996 -- by
6998 -- ityp (x)
7000 -- with the Float_Truncate flag set. This is clearly more efficient
7004 then
7010 -- One more check here, gcc is still not able to do conversions of
7011 -- this type with proper overflow checking, and so gigi is doing an
7012 -- approximation of what is required by doing floating-point compares
7013 -- with the end-point. But that can lose precision in some cases, and
7014 -- give a wrong result. Converting the operand to Universal_Real is
7015 -- helpful, but still does not catch all cases with 64-bit integers
7016 -- on targets with only 64-bit floats ???
7021 Subtype_Mark =>
7023 Expression =>
7031 -- Case of array conversions
7033 -- Expansion of array conversions, add required length/range checks
7034 -- but only do this if there is no change of representation. For
7035 -- handling of this case, see Handle_Changed_Representation.
7041 else
7045 Handle_Changed_Representation;
7047 -- Case of conversions of discriminated types
7049 -- Add required discriminant checks if target is constrained. Again
7050 -- this change is skipped if we have a change of representation.
7054 then
7056 Handle_Changed_Representation;
7058 -- Case of all other record conversions. The only processing required
7059 -- is to check for a change of representation requiring the special
7060 -- assignment processing.
7064 -- Ada 2005 (AI-216): Program_Error is raised when converting from
7065 -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
7066 -- Union type if the operand lacks inferable discriminants.
7073 then
7074 -- To prevent Gigi from generating illegal code, we make a
7075 -- Program_Error node, but we give it the target type of the
7076 -- conversion.
7078 declare
7082 begin
7087 else
7088 Handle_Changed_Representation;
7091 -- Case of conversions of enumeration types
7095 -- Special processing is required if there is a change of
7096 -- representation (from enumeration representation clauses)
7100 -- Convert: x(y) to x'val (ytyp'val (y))
7115 -- Case of conversions to floating-point
7118 Real_Range_Check;
7121 -- At this stage, either the conversion node has been transformed
7122 -- into some other equivalent expression, or left as a conversion
7123 -- that can be handled by Gigi. The conversions that Gigi can handle
7124 -- are the following:
7126 -- Conversions with no change of representation or type
7128 -- Numeric conversions involving integer values, floating-point
7129 -- values, and fixed-point values. Fixed-point values are allowed
7130 -- only if Conversion_OK is set, i.e. if the fixed-point values
7131 -- are to be treated as integers.
7133 -- No other conversions should be passed to Gigi
7135 -- Check: are these rules stated in sinfo??? if so, why restate here???
7137 -- The only remaining step is to generate a range check if we still
7138 -- have a type conversion at this stage and Do_Range_Check is set.
7139 -- For now we do this only for conversions of discrete types.
7143 then
7144 declare
7149 begin
7152 then
7155 -- Before we do a range check, we have to deal with treating
7156 -- a fixed-point operand as an integer. The way we do this
7157 -- is simply to do an unchecked conversion to an appropriate
7158 -- integer type large enough to hold the result.
7160 -- This code is not active yet, because we are only dealing
7161 -- with discrete types so far ???
7165 then
7170 else
7177 -- Reset overflow flag, since the range check will include
7178 -- dealing with possible overflow, and generate the check
7179 -- If Address is either source or target type, suppress
7180 -- range check to avoid typing anomalies when it is a visible
7181 -- integer type.
7186 then
7187 Generate_Range_Check
7194 -- Final step, if the result is a type conversion involving Vax_Float
7195 -- types, then it is subject for further special processing.
7199 then
7205 -----------------------------------
7206 -- Expand_N_Unchecked_Expression --
7207 -----------------------------------
7209 -- Remove the unchecked expression node from the tree. It's job was simply
7210 -- to make sure that its constituent expression was handled with checks
7211 -- off, and now that that is done, we can remove it from the tree, and
7212 -- indeed must, since gigi does not expect to see these nodes.
7217 begin
7222 ----------------------------------------
7223 -- Expand_N_Unchecked_Type_Conversion --
7224 ----------------------------------------
7226 -- If this cannot be handled by Gigi and we haven't already made
7227 -- a temporary for it, do it now.
7234 begin
7235 -- If we have a conversion of a compile time known value to a target
7236 -- type and the value is in range of the target type, then we can simply
7237 -- replace the construct by an integer literal of the correct type. We
7238 -- only apply this to integer types being converted. Possibly it may
7239 -- apply in other cases, but it is too much trouble to worry about.
7241 -- Note that we do not do this transformation if the Kill_Range_Check
7242 -- flag is set, since then the value may be outside the expected range.
7243 -- This happens in the Normalize_Scalars case.
7249 then
7250 declare
7253 begin
7255 and then
7257 and then
7259 and then
7261 then
7264 -- If Address is the target type, just set the type
7265 -- to avoid a spurious type error on the literal when
7266 -- Address is a visible integer type.
7270 else
7279 -- Nothing to do if conversion is safe
7285 -- Otherwise force evaluation unless Assignment_OK flag is set (this
7286 -- flag indicates ??? -- more comments needed here)
7290 else
7295 ----------------------------
7296 -- Expand_Record_Equality --
7297 ----------------------------
7299 -- For non-variant records, Equality is expanded when needed into:
7301 -- and then Lhs.Discr1 = Rhs.Discr1
7302 -- and then ...
7303 -- and then Lhs.Discrn = Rhs.Discrn
7304 -- and then Lhs.Cmp1 = Rhs.Cmp1
7305 -- and then ...
7306 -- and then Lhs.Cmpn = Rhs.Cmpn
7308 -- The expression is folded by the back-end for adjacent fields. This
7309 -- function is called for tagged record in only one occasion: for imple-
7310 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
7311 -- otherwise the primitive "=" is used directly.
7313 function Expand_Record_Equality
7319 is
7328 -- Return the first field to compare beginning with C, skipping the
7329 -- inherited components.
7331 ----------------------
7332 -- Suitable_Element --
7333 ----------------------
7336 begin
7342 then
7347 then
7352 then
7355 else
7360 -- Start of processing for Expand_Record_Equality
7362 begin
7363 -- Generates the following code: (assuming that Typ has one Discr and
7364 -- component C2 is also a record)
7366 -- True
7367 -- and then Lhs.Discr1 = Rhs.Discr1
7368 -- and then Lhs.C1 = Rhs.C1
7369 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
7370 -- and then ...
7371 -- and then Lhs.Cmpn = Rhs.Cmpn
7377 declare
7382 begin
7387 else
7392 Check :=
7394 Lhs =>
7398 Rhs =>
7404 -- If some (sub)component is an unchecked_union, the whole
7405 -- operation will raise program error.
7411 else
7412 Result :=
7425 -------------------------------------
7426 -- Fixup_Universal_Fixed_Operation --
7427 -------------------------------------
7432 begin
7433 -- We must have a type conversion immediately above us
7437 -- Normally the type conversion gives our target type. The exception
7438 -- occurs in the case of the Round attribute, where the conversion
7439 -- will be to universal real, and our real type comes from the Round
7440 -- attribute (as well as an indication that we must round the result)
7444 then
7448 -- Normal case where type comes from conversion above us
7450 else
7455 ------------------------------
7456 -- Get_Allocator_Final_List --
7457 ------------------------------
7459 function Get_Allocator_Final_List
7463 is
7467 -- The entity whose finalisation list must be used to attach the
7468 -- allocated object.
7470 begin
7473 in N_Subprogram_Specification
7474 then
7475 -- If the context is an access parameter, we need to create
7476 -- a non-anonymous access type in order to have a usable
7477 -- final list, because there is otherwise no pool to which
7478 -- the allocated object can belong. We create both the type
7479 -- and the finalization chain here, because freezing an
7480 -- internal type does not create such a chain. The Final_Chain
7481 -- that is thus created is shared by the access parameter.
7487 Type_Definition =>
7489 Subtype_Indication =>
7495 else
7496 -- Case of an access discriminant, or (Ada 2005) of
7497 -- an anonymous access component: find the final list
7498 -- associated with the scope of the type.
7507 ---------------------------------
7508 -- Has_Inferable_Discriminants --
7509 ---------------------------------
7514 -- Determines whether the left-most prefix of a selected component is a
7515 -- formal parameter in a subprogram. Assumes N is a selected component.
7517 --------------------------------
7518 -- Prefix_Is_Formal_Parameter --
7519 --------------------------------
7524 begin
7525 -- Move to the left-most prefix by climbing up the tree
7529 loop
7536 -- Start of processing for Has_Inferable_Discriminants
7538 begin
7539 -- For identifiers and indexed components, it is sufficent to have a
7540 -- constrained Unchecked_Union nominal subtype.
7543 or else
7545 then
7547 and then
7550 -- For selected components, the subtype of the selector must be a
7551 -- constrained Unchecked_Union. If the component is subject to a
7552 -- per-object constraint, then the enclosing object must have inferable
7553 -- discriminants.
7558 -- A small hack. If we have a per-object constrained selected
7559 -- component of a formal parameter, return True since we do not
7560 -- know the actual parameter association yet.
7566 -- Otherwise, check the enclosing object and the selector
7569 and then
7573 -- The call to Has_Inferable_Discriminants will determine whether
7574 -- the selector has a constrained Unchecked_Union nominal type.
7578 -- A qualified expression has inferable discriminants if its subtype
7579 -- mark is a constrained Unchecked_Union subtype.
7583 and then
7591 -------------------------------
7592 -- Insert_Dereference_Action --
7593 -------------------------------
7602 -- Return true if type of P is derived from Checked_Pool;
7604 -----------------------------
7605 -- Is_Checked_Storage_Pool --
7606 -----------------------------
7611 begin
7620 else
7628 -- Start of processing for Insert_Dereference_Action
7630 begin
7635 then
7646 -- Pool
7650 -- Storage_Address. We use the attribute Pool_Address,
7651 -- which uses the pointer itself to find the address of
7652 -- the object, and which handles unconstrained arrays
7653 -- properly by computing the address of the template.
7654 -- i.e. the correct address of the corresponding allocation.
7660 -- Size_In_Storage_Elements
7663 Left_Opnd =>
7665 Prefix =>
7669 Right_Opnd =>
7672 -- Alignment
7675 Prefix =>
7680 exception
7685 ------------------------------
7686 -- Make_Array_Comparison_Op --
7687 ------------------------------
7689 -- This is a hand-coded expansion of the following generic function:
7691 -- generic
7692 -- type elem is (<>);
7693 -- type index is (<>);
7694 -- type a is array (index range <>) of elem;
7695 --
7696 -- function Gnnn (X : a; Y: a) return boolean is
7697 -- J : index := Y'first;
7698 --
7699 -- begin
7700 -- if X'length = 0 then
7701 -- return false;
7702 --
7703 -- elsif Y'length = 0 then
7704 -- return true;
7705 --
7706 -- else
7707 -- for I in X'range loop
7708 -- if X (I) = Y (J) then
7709 -- if J = Y'last then
7710 -- exit;
7711 -- else
7712 -- J := index'succ (J);
7713 -- end if;
7714 --
7715 -- else
7716 -- return X (I) > Y (J);
7717 -- end if;
7718 -- end loop;
7719 --
7720 -- return X'length > Y'length;
7721 -- end if;
7722 -- end Gnnn;
7724 -- Note that since we are essentially doing this expansion by hand, we
7725 -- do not need to generate an actual or formal generic part, just the
7726 -- instantiated function itself.
7728 function Make_Array_Comparison_Op
7731 is
7752 begin
7753 -- if J = Y'last then
7754 -- exit;
7755 -- else
7756 -- J := index'succ (J);
7757 -- end if;
7759 Inner_If :=
7761 Condition =>
7764 Right_Opnd =>
7772 Else_Statements =>
7773 New_List (
7776 Expression =>
7782 -- if X (I) = Y (J) then
7783 -- if ... end if;
7784 -- else
7785 -- return X (I) > Y (J);
7786 -- end if;
7788 Loop_Body :=
7790 Condition =>
7792 Left_Opnd =>
7797 Right_Opnd =>
7806 Expression =>
7808 Left_Opnd =>
7813 Right_Opnd =>
7819 -- for I in X'range loop
7820 -- if ... end if;
7821 -- end loop;
7823 Loop_Statement :=
7827 Iteration_Scheme =>
7829 Loop_Parameter_Specification =>
7832 Discrete_Subtype_Definition =>
7839 -- if X'length = 0 then
7840 -- return false;
7841 -- elsif Y'length = 0 then
7842 -- return true;
7843 -- else
7844 -- for ... loop ... end loop;
7845 -- return X'length > Y'length;
7846 -- end if;
7848 Length1 :=
7853 Length2 :=
7858 Final_Expr :=
7863 If_Stat :=
7865 Condition =>
7867 Left_Opnd =>
7871 Right_Opnd =>
7874 Then_Statements =>
7875 New_List (
7881 Condition =>
7883 Left_Opnd =>
7887 Right_Opnd =>
7890 Then_Statements =>
7891 New_List (
7896 Loop_Statement,
7900 -- (X : a; Y: a)
7911 -- function Gnnn (...) return boolean is
7912 -- J : index := Y'first;
7913 -- begin
7914 -- if ... end if;
7915 -- end Gnnn;
7919 Func_Body :=
7921 Specification =>
7931 Expression =>
7936 Handled_Statement_Sequence =>
7943 ---------------------------
7944 -- Make_Boolean_Array_Op --
7945 ---------------------------
7947 -- For logical operations on boolean arrays, expand in line the
7948 -- following, replacing 'and' with 'or' or 'xor' where needed:
7950 -- function Annn (A : typ; B: typ) return typ is
7951 -- C : typ;
7952 -- begin
7953 -- for J in A'range loop
7954 -- C (J) := A (J) op B (J);
7955 -- end loop;
7956 -- return C;
7957 -- end Annn;
7959 -- Here typ is the boolean array type
7961 function Make_Boolean_Array_Op
7964 is
7982 begin
7983 A_J :=
7988 B_J :=
7993 C_J :=
7999 Op :=
8005 Op :=
8010 else
8011 Op :=
8017 Loop_Statement :=
8021 Iteration_Scheme =>
8023 Loop_Parameter_Specification =>
8026 Discrete_Subtype_Definition =>
8045 Func_Name :=
8049 Func_Body :=
8051 Specification =>
8062 Handled_Statement_Sequence =>
8065 Loop_Statement,
8072 ------------------------
8073 -- Rewrite_Comparison --
8074 ------------------------
8077 begin
8084 else
8085 declare
8091 -- Res indicates if compare outcome can be compile time determined
8096 begin
8107 and then Constant_Condition_Warnings
8110 and then not In_Instance
8113 then
8114 Error_Msg_N
8131 and then Constant_Condition_Warnings
8134 and then not In_Instance
8137 then
8138 Error_Msg_N
8165 ----------------------------
8166 -- Safe_In_Place_Array_Op --
8167 ----------------------------
8169 function Safe_In_Place_Array_Op
8173 is
8177 -- Operand is safe if it cannot overlap part of the target of the
8178 -- operation. If the operand and the target are identical, the operand
8179 -- is safe. The operand can be empty in the case of negation.
8182 -- Check that N is a stand-alone entity
8184 ------------------
8185 -- Is_Unaliased --
8186 ------------------
8189 begin
8190 return
8196 ---------------------
8197 -- Is_Safe_Operand --
8198 ---------------------
8201 begin
8210 then
8214 return
8221 else
8226 -- Start of processing for Is_Safe_In_Place_Array_Op
8228 begin
8229 -- We skip this processing if the component size is not the
8230 -- same as a system storage unit (since at least for NOT
8231 -- this would cause problems).
8236 -- Cannot do in place stuff on Java_VM since cannot pass addresses
8241 -- Cannot do in place stuff if non-standard Boolean representation
8248 else
8251 return
8257 -----------------------
8258 -- Tagged_Membership --
8259 -----------------------
8261 -- There are two different cases to consider depending on whether
8262 -- the right operand is a class-wide type or not. If not we just
8263 -- compare the actual tag of the left expr to the target type tag:
8264 --
8265 -- Left_Expr.Tag = Right_Type'Tag;
8266 --
8267 -- If it is a class-wide type we use the RT function CW_Membership which
8268 -- is usually implemented by looking in the ancestor tables contained in
8269 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
8280 begin
8288 Obj_Tag :=
8291 Selector_Name =>
8296 -- Ada 2005 (AI-251): Class-wide applied to interfaces
8300 -- Give support to: "Iface_CW_Typ in Typ'Class"
8303 then
8304 -- Issue error if IW_Membership operation not available in a
8305 -- configurable run time setting.
8312 return
8319 New_Reference_To (
8320 Node (First_Elmt
8322 Loc)));
8324 -- Ada 95: Normal case
8326 else
8327 return
8331 Obj_Tag,
8332 New_Reference_To (
8333 Node (First_Elmt
8335 Loc)));
8338 else
8339 return
8342 Right_Opnd =>
8343 New_Reference_To
8348 ------------------------------
8349 -- Unary_Op_Validity_Checks --
8350 ------------------------------
8353 begin