| blob | 192e89805d4a26bf224cf91a9d977819c178a51d |
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-2003, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
69 ------------------------
70 -- Local Subprograms --
71 ------------------------
75 -- Performs validity checks for a binary operator
77 procedure Build_Boolean_Array_Proc_Call
81 -- If an boolean array assignment can be done in place, build call to
82 -- corresponding library procedure.
85 -- Subsidiary to Expand_N_Allocator, for the case when the expression
86 -- is a qualified expression or an aggregate.
89 -- This routine handles expansion of the comparison operators (N_Op_Lt,
90 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
91 -- code for these operators is similar, differing only in the details of
92 -- the actual comparison call that is made. Special processing (call a
93 -- run-time routine)
95 function Expand_Array_Equality
103 -- Expand an array equality into a call to a function implementing this
104 -- equality, and a call to it. Loc is the location for the generated
105 -- nodes. Typ is the type of the array, and Lhs, Rhs are the array
106 -- expressions to be compared. A_Typ is the type of the arguments,
107 -- which may be a private type, in which case Typ is its full view.
108 -- Bodies is a list on which to attach bodies of local functions that
109 -- are created in the process. This is the responsibility of the
110 -- caller to insert those bodies at the right place. Nod provides
111 -- the Sloc value for the generated code.
114 -- Common expansion processing for Boolean operators (And, Or, Xor)
115 -- for the case of array type arguments.
117 function Expand_Composite_Equality
124 -- Local recursive function used to expand equality for nested
125 -- composite types. Used by Expand_Record/Array_Equality, Bodies
126 -- is a list on which to attach bodies of local functions that are
127 -- created in the process. This is the responsability of the caller
128 -- to insert those bodies at the right place. Nod provides the Sloc
129 -- value for generated code.
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
155 -- If the designated type is controlled, build final_list expression
156 -- for created object. If context is an access parameter, create a
157 -- local access type to have a usable finalization list.
160 -- N is an expression whose type is an access. When the type is derived
161 -- from Checked_Pool, expands a call to the primitive 'dereference'.
163 function Make_Array_Comparison_Op
167 -- Comparisons between arrays are expanded in line. This function
168 -- produces the body of the implementation of (a > b), where a and b
169 -- are one-dimensional arrays of some discrete type. The original
170 -- node is then expanded into the appropriate call to this function.
171 -- Nod provides the Sloc value for the generated code.
173 function Make_Boolean_Array_Op
177 -- Boolean operations on boolean arrays are expanded in line. This
178 -- function produce the body for the node N, which is (a and b),
179 -- (a or b), or (a xor b). It is used only the normal case and not
180 -- the packed case. The type involved, Typ, is the Boolean array type,
181 -- and the logical operations in the body are simple boolean operations.
182 -- Note that Typ is always a constrained type (the caller has ensured
183 -- this by using Convert_To_Actual_Subtype if necessary).
186 -- N is the node for a compile time comparison. If this outcome of this
187 -- comparison can be determined at compile time, then the node N can be
188 -- rewritten with True or False. If the outcome cannot be determined at
189 -- compile time, the call has no effect.
192 -- Construct the expression corresponding to the tagged membership test.
193 -- Deals with a second operand being (or not) a class-wide type.
195 function Safe_In_Place_Array_Op
200 -- In the context of an assignment, where the right-hand side is a
201 -- boolean operation on arrays, check whether operation can be performed
202 -- in place.
206 -- Performs validity checks for a unary operator
208 -------------------------------
209 -- Binary_Op_Validity_Checks --
210 -------------------------------
213 begin
220 ------------------------------------
221 -- Build_Boolean_Array_Proc_Call --
222 ------------------------------------
224 procedure Build_Boolean_Array_Proc_Call
228 is
241 begin
245 -- Use negated version of the binary operators.
257 Call_Node :=
262 Target,
275 else
278 Call_Node :=
282 Target,
293 else
294 -- We use the following equivalences:
296 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
297 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
298 -- (not X) xor (not Y) = X xor Y
299 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
308 else
312 else
323 else
328 Call_Node :=
332 Target,
347 exception
352 ---------------------------------
353 -- Expand_Allocator_Expression --
354 ---------------------------------
371 begin
374 -- Actions inserted before:
375 -- Temp : constant ptr_T := new T'(Expression);
376 -- <no CW> Temp._tag := T'tag;
377 -- <CTRL> Adjust (Finalizable (Temp.all));
378 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
380 -- We analyze by hand the new internal allocator to avoid
381 -- any recursion and inappropriate call to Initialize
386 Temp :=
389 -- For a class wide allocation generate the following code:
391 -- type Equiv_Record is record ... end record;
392 -- implicit subtype CW is <Class_Wide_Subytpe>;
393 -- temp : PtrT := new CW'(CW!(expr));
405 Tmp_Node :=
409 Expression =>
413 Set_Comes_From_Source
421 then
422 -- Create local finalization list for access parameter.
428 else
439 -- Suppress the tag assignment when Java_VM because JVM tags
440 -- are represented implicitly in objects.
444 and then not Java_VM
445 then
446 Tag_Assign :=
448 Name =>
451 Selector_Name =>
454 Expression =>
458 -- The previous assignment has to be done in any case
465 and then not Java_VM
466 then
467 declare
474 begin
475 Tag_Assign :=
477 Name =>
480 Selector_Name =>
483 Expression =>
485 New_Reference_To (
495 then
496 declare
501 begin
502 -- If it is an allocation on the secondary stack
503 -- (i.e. a value returned from a function), the object
504 -- is attached on the caller side as soon as the call
505 -- is completed (see Expand_Ctrl_Function_Call)
508 declare
512 begin
523 -- Normal case, not a secondary stack allocation
525 else
532 Make_Adjust_Call (
533 Ref =>
535 -- An unchecked conversion is needed in the
536 -- classwide case because the designated type
537 -- can be an ancestor of the subtype mark of
538 -- the allocator.
555 Temp :=
557 Tmp_Node :=
564 Set_Comes_From_Source
576 then
577 -- Apply constraint to designated subtype indication.
585 -- Propagate constraint_error to enclosing allocator
589 else
590 -- First check against the type of the qualified expression
591 --
592 -- NOTE: The commented call should be correct, but for
593 -- some reason causes the compiler to bomb (sigsegv) on
594 -- ACVC test c34007g, so for now we just perform the old
595 -- (incorrect) test against the designated subtype with
596 -- no sliding in the else part of the if statement below.
597 -- ???
598 --
599 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
601 -- A check is also needed in cases where the designated
602 -- subtype is constrained and differs from the subtype
603 -- given in the qualified expression. Note that the check
604 -- on the qualified expression does not allow sliding,
605 -- but this check does (a relaxation from Ada 83).
608 and then not Subtypes_Statically_Match
610 then
611 Apply_Constraint_Check
614 -- The nonsliding check should really be performed
615 -- (unconditionally) against the subtype of the
616 -- qualified expression, but that causes a problem
617 -- with c34007g (see above), so for now we retain this.
619 else
620 Apply_Constraint_Check
625 exception
630 -----------------------------
631 -- Expand_Array_Comparison --
632 -----------------------------
634 -- Expansion is only required in the case of array types. For the
635 -- unpacked case, an appropriate runtime routine is called. For
636 -- packed cases, and also in some other cases where a runtime
637 -- routine cannot be called, the form of the expansion is:
639 -- [body for greater_nn; boolean_expression]
641 -- The body is built by Make_Array_Comparison_Op, and the form of the
642 -- Boolean expression depends on the operator involved.
658 -- Returns True if the length of the given operand is known to be
659 -- less than 4. Returns False if this length is known to be four
660 -- or greater or is not known at compile time.
662 ------------------------
663 -- Length_Less_Than_4 --
664 ------------------------
669 begin
673 else
674 declare
681 begin
684 else
690 else
699 -- Start of processing for Expand_Array_Comparison
701 begin
702 -- Deal first with unpacked case, where we can call a runtime routine
703 -- except that we avoid this for targets for which are not addressable
704 -- by bytes, and for the JVM, since the JVM does not support direct
705 -- addressing of array components.
709 and then not Java_VM
710 then
711 -- The call we generate is:
713 -- Compare_Array_xn[_Unaligned]
714 -- (left'address, right'address, left'length, right'length) <op> 0
716 -- x = U for unsigned, S for signed
717 -- n = 8,16,32,64 for component size
718 -- Add _Unaligned if length < 4 and component size is 8.
719 -- <op> is the standard comparison operator
723 or else
725 then
728 else
732 else
735 else
743 else
750 else
757 else
795 -- Cases where we cannot make runtime call
797 -- For (a <= b) we convert to not (a > b)
802 Right_Opnd =>
809 -- For < the Boolean expression is
810 -- greater__nn (op2, op1)
815 -- Switch operands
820 -- For (a >= b) we convert to not (a < b)
825 Right_Opnd =>
832 -- For > the Boolean expression is
833 -- greater__nn (op1, op2)
835 else
841 Expr :=
850 exception
855 ---------------------------
856 -- Expand_Array_Equality --
857 ---------------------------
859 -- Expand an equality function for multi-dimensional arrays. Here is
860 -- an example of such a function for Nb_Dimension = 2
862 -- function Enn (A : arr; B : arr) return boolean is
863 -- begin
864 -- if (A'length (1) = 0 or else A'length (2) = 0)
865 -- and then
866 -- (B'length (1) = 0 or else B'length (2) = 0)
867 -- then
868 -- return True; -- RM 4.5.2(22)
869 -- end if;
870 --
871 -- if A'length (1) /= B'length (1)
872 -- or else
873 -- A'length (2) /= B'length (2)
874 -- then
875 -- return False; -- RM 4.5.2(23)
876 -- end if;
877 --
878 -- declare
879 -- A1 : Index_type_1 := A'first (1)
880 -- B1 : Index_Type_1 := B'first (1)
881 -- begin
882 -- loop
883 -- declare
884 -- A2 : Index_type_2 := A'first (2);
885 -- B2 : Index_type_2 := B'first (2)
886 -- begin
887 -- loop
888 -- if A (A1, A2) /= B (B1, B2) then
889 -- return False;
890 -- end if;
891 --
892 -- exit when A2 = A'last (2);
893 -- A2 := Index_type2'succ (A2);
894 -- B2 := Index_type2'succ (B2);
895 -- end loop;
896 -- end;
897 --
898 -- exit when A1 = A'last (1);
899 -- A1 := Index_type1'succ (A1);
900 -- B1 := Index_type1'succ (B1);
901 -- end loop;
902 -- end;
903 --
904 -- return true;
905 -- end Enn;
907 function Expand_Array_Equality
914 return Node_Id
915 is
929 function Arr_Attr
934 -- This builds the attribute reference Arr'Nam (Expr).
937 -- Create one statement to compare corresponding components,
938 -- designated by a full set of indices.
940 function Handle_One_Dimension
944 -- This procedure returns a declare block:
945 --
946 -- declare
947 -- An : Index_Type_n := A'First (n);
948 -- Bn : Index_Type_n := B'First (n);
949 -- begin
950 -- loop
951 -- xxx
952 -- exit when An = A'Last (n);
953 -- An := Index_Type_n'Succ (An)
954 -- Bn := Index_Type_n'Succ (Bn)
955 -- end loop;
956 -- end;
957 --
958 -- where N is the value of "n" in the above code. Index is the
959 -- N'th index node, whose Etype is Index_Type_n in the above code.
960 -- The xxx statement is either the declare block for the next
961 -- dimension or if this is the last dimension the comparison
962 -- of corresponding components of the arrays.
963 --
964 -- The actual way the code works is to return the comparison
965 -- of corresponding components for the N+1 call. That's neater!
968 -- This function constructs the test for both arrays being empty
969 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
970 -- and then
971 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
974 -- This function constructs the test for arrays having different
975 -- lengths in at least one index position, in which case resull
977 -- A'length (1) /= B'length (1)
978 -- or else
979 -- A'length (2) /= B'length (2)
980 -- or else
981 -- ...
983 --------------
984 -- Arr_Attr --
985 --------------
987 function Arr_Attr
991 return Node_Id
992 is
993 begin
994 return
1001 ------------------------
1002 -- Component_Equality --
1003 ------------------------
1009 begin
1010 -- if a(i1...) /= b(j1...) then return false; end if;
1012 L :=
1017 R :=
1022 Test := Expand_Composite_Equality
1025 return
1033 --------------------------
1034 -- Handle_One_Dimension --
1035 ---------------------------
1037 function Handle_One_Dimension
1040 return Node_Id
1041 is
1048 begin
1053 -- Case where we generate a declare block
1059 return
1064 Object_Definition =>
1070 Object_Definition =>
1074 Handled_Statement_Sequence =>
1082 Condition =>
1089 Expression =>
1091 Prefix =>
1099 Expression =>
1101 Prefix =>
1108 -----------------------
1109 -- Test_Empty_Arrays --
1110 -----------------------
1119 begin
1123 Atest :=
1128 Btest :=
1137 else
1138 Alist :=
1143 Blist :=
1150 return
1156 -----------------------------
1157 -- Test_Lengths_Correspond --
1158 -----------------------------
1164 begin
1167 Rtest :=
1174 else
1175 Result :=
1185 -- Start of processing for Expand_Array_Equality
1187 begin
1199 -- Build statement sequence for function
1201 Func_Body :=
1203 Specification =>
1211 Handled_Statement_Sequence =>
1219 Expression =>
1226 Expression =>
1236 -- If the array type is distinct from the type of the arguments,
1237 -- it is the full view of a private type. Apply an unchecked
1238 -- conversion to insure that analysis of the call succeeds.
1244 else
1250 return
1256 -----------------------------
1257 -- Expand_Boolean_Operator --
1258 -----------------------------
1260 -- Note that we first get the actual subtypes of the operands,
1261 -- since we always want to deal with types that have bounds.
1266 begin
1270 else
1271 -- For the normal non-packed case, the general expansion is
1272 -- to build a function for carrying out the comparison (using
1273 -- Make_Boolean_Array_Op) and then inserting it into the tree.
1274 -- The original operator node is then rewritten as a call to
1275 -- this function.
1277 declare
1284 begin
1293 then
1298 and then
1300 then
1302 else
1308 -- Now rewrite the expression with a call
1313 Parameter_Associations =>
1314 New_List
1324 -------------------------------
1325 -- Expand_Composite_Equality --
1326 -------------------------------
1328 -- This function is only called for comparing internal fields of composite
1329 -- types when these fields are themselves composites. This is a special
1330 -- case because it is not possible to respect normal Ada visibility rules.
1332 function Expand_Composite_Equality
1338 return Node_Id
1339 is
1345 begin
1348 else
1352 -- Defense against malformed private types with no completion
1353 -- the error will be diagnosed later by check_completion
1363 -- If the operand is an elementary type other than a floating-point
1364 -- type, then we can simply use the built-in block bitwise equality,
1365 -- since the predefined equality operators always apply and bitwise
1366 -- equality is fine for all these cases.
1370 then
1373 -- For composite component types, and floating-point types, use
1374 -- the expansion. This deals with tagged component types (where
1375 -- we use the applicable equality routine) and floating-point,
1376 -- (where we need to worry about negative zeroes), and also the
1377 -- case of any composite type recursively containing such fields.
1379 else
1380 return Expand_Array_Equality
1386 -- Call the primitive operation "=" of this type
1392 -- If this is derived from an untagged private type completed
1393 -- with a tagged type, it does not have a full view, so we
1394 -- use the primitive operations of the private type.
1395 -- This check should no longer be necessary when these
1396 -- types receive their full views ???
1403 then
1405 else
1409 loop
1420 return
1423 Parameter_Associations =>
1424 New_List
1434 -- Inherited equality from parent type. Convert the actuals
1435 -- to match signature of operation.
1437 declare
1440 begin
1441 return
1444 Parameter_Associations =>
1449 else
1450 return
1456 else
1460 else
1461 -- It can be a simple record or the full view of a scalar private
1467 ------------------------------
1468 -- Expand_Concatenate_Other --
1469 ------------------------------
1471 -- Let n be the number of array operands to be concatenated, Base_Typ
1472 -- their base type, Ind_Typ their index type, and Arr_Typ the original
1473 -- array type to which the concatenantion operator applies, then the
1474 -- following subprogram is constructed:
1476 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1477 -- L : Ind_Typ;
1478 -- begin
1479 -- if S1'Length /= 0 then
1480 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
1481 -- XXX = Arr_Typ'First otherwise
1482 -- elsif S2'Length /= 0 then
1483 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
1484 -- YYY = Arr_Typ'First otherwise
1485 -- ...
1486 -- elsif Sn-1'Length /= 0 then
1487 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
1488 -- ZZZ = Arr_Typ'First otherwise
1489 -- else
1490 -- return Sn;
1491 -- end if;
1493 -- declare
1494 -- P : Ind_Typ;
1495 -- H : Ind_Typ :=
1496 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1497 -- + Ind_Typ'Pos (L));
1498 -- R : Base_Typ (L .. H);
1499 -- begin
1500 -- if S1'Length /= 0 then
1501 -- P := S1'First;
1502 -- loop
1503 -- R (L) := S1 (P);
1504 -- L := Ind_Typ'Succ (L);
1505 -- exit when P = S1'Last;
1506 -- P := Ind_Typ'Succ (P);
1507 -- end loop;
1508 -- end if;
1509 --
1510 -- if S2'Length /= 0 then
1511 -- L := Ind_Typ'Succ (L);
1512 -- loop
1513 -- R (L) := S2 (P);
1514 -- L := Ind_Typ'Succ (L);
1515 -- exit when P = S2'Last;
1516 -- P := Ind_Typ'Succ (P);
1517 -- end loop;
1518 -- end if;
1520 -- ...
1522 -- if Sn'Length /= 0 then
1523 -- P := Sn'First;
1524 -- loop
1525 -- R (L) := Sn (P);
1526 -- L := Ind_Typ'Succ (L);
1527 -- exit when P = Sn'Last;
1528 -- P := Ind_Typ'Succ (P);
1529 -- end loop;
1530 -- end if;
1532 -- return R;
1533 -- end;
1534 -- end Cnn;]
1572 -- Builds the sequence of statement:
1573 -- P := Si'First;
1574 -- loop
1575 -- R (L) := Si (P);
1576 -- L := Ind_Typ'Succ (L);
1577 -- exit when P = Si'Last;
1578 -- P := Ind_Typ'Succ (P);
1579 -- end loop;
1580 --
1581 -- where i is the input parameter I given.
1582 -- If the flag Last is true, the exit statement is emitted before
1583 -- incrementing the lower bound, to prevent the creation out of
1584 -- bound values.
1587 -- Builds the statement:
1588 -- L := Arr_Typ'First; If Arr_Typ is constrained
1589 -- L := Si'First; otherwise (where I is the input param given)
1592 -- Builds reference to identifier H.
1595 -- Builds expression Ind_Typ'Val (E);
1598 -- Builds reference to identifier L.
1601 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)).
1602 -- We qualify the expression to avoid universal_integer computations
1603 -- whenever possible, in the expression for the upper bound H.
1606 -- Builds expression Ind_Typ'Succ (L).
1609 -- Builds integer literal one.
1612 -- Builds reference to identifier P.
1615 -- Builds expression Ind_Typ'Succ (P).
1618 -- Builds reference to identifier R.
1621 -- Builds reference to identifier Si, where I is the value given.
1624 -- Builds expression Si'First, where I is the value given.
1627 -- Builds expression Si'Last, where I is the value given.
1630 -- Builds expression Si'Length, where I is the value given.
1633 -- Builds expression Si'Length /= 0, where I is the value given.
1635 -------------------
1636 -- Copy_Into_R_S --
1637 -------------------
1648 begin
1649 -- First construct the initializations
1656 -- Then build the loop
1678 Loop_Stmt :=
1681 else
1682 Loop_Stmt :=
1692 -------
1693 -- H --
1694 -------
1697 begin
1701 -------------
1702 -- Ind_Val --
1703 -------------
1706 begin
1707 return
1714 ------------
1715 -- Init_L --
1716 ------------
1721 begin
1727 else
1734 -------
1735 -- L --
1736 -------
1739 begin
1743 -----------
1744 -- L_Pos --
1745 -----------
1750 begin
1751 -- If the index type is an enumeration type, the computation
1752 -- can be done in standard integer. Otherwise, choose a large
1753 -- enough integer type.
1759 then
1761 else
1765 return
1768 Expression =>
1775 ------------
1776 -- L_Succ --
1777 ------------
1780 begin
1781 return
1788 ---------
1789 -- One --
1790 ---------
1793 begin
1797 -------
1798 -- P --
1799 -------
1802 begin
1806 ------------
1807 -- P_Succ --
1808 ------------
1811 begin
1812 return
1819 -------
1820 -- R --
1821 -------
1824 begin
1828 -------
1829 -- S --
1830 -------
1833 begin
1837 -------------
1838 -- S_First --
1839 -------------
1842 begin
1848 ------------
1849 -- S_Last --
1850 ------------
1853 begin
1859 --------------
1860 -- S_Length --
1861 --------------
1864 begin
1870 -------------------
1871 -- S_Length_Test --
1872 -------------------
1875 begin
1876 return
1882 -- Start of processing for Expand_Concatenate_Other
1884 begin
1885 -- Construct the parameter specs and the overall function spec
1889 Append_To
1892 Defining_Identifier =>
1898 Func_Spec :=
1904 -- Construct L's object declaration
1906 L_Decl :=
1913 -- Construct the if-then-elsif statements
1922 If_Stmt :=
1930 -- Construct the declaration for H
1932 P_Decl :=
1943 H_Decl :=
1949 -- Construct the declaration for R
1952 R_Constr :=
1956 R_Decl :=
1959 Object_Definition =>
1964 -- Construct the declarations for the declare block
1968 -- Construct list of statements for the declare block
1980 -- Construct the declare block
1984 Handled_Statement_Sequence =>
1987 -- Construct the list of function statements
1991 -- Construct the function body
1993 Func_Body :=
1997 Handled_Statement_Sequence =>
2000 -- Insert the newly generated function in the code. This is analyzed
2001 -- with all checks off, since we have completed all the checks.
2003 -- Note that this does *not* fix the array concatenation bug when the
2004 -- low bound is Integer'first sibce that bug comes from the pointer
2005 -- dereferencing an unconstrained array. An there we need a constraint
2006 -- check to make sure the length of the concatenated array is ok. ???
2010 -- Construct list of arguments for the function call
2019 -- Insert the function call
2021 Rewrite
2029 -------------------------------
2030 -- Expand_Concatenate_String --
2031 -------------------------------
2041 -- RE_Id value for function to be called
2043 begin
2044 -- In all cases, we build a call to a routine giving the list of
2045 -- arguments as the parameter list to the routine.
2053 else
2062 else
2067 -- If we have anything other than Standard_Character or
2068 -- Standard_String, then we must have had a serious error
2069 -- earlier, so we just abandon the attempt at expansion.
2071 else
2090 -- Now generate the appropriate call
2099 exception
2104 ------------------------
2105 -- Expand_N_Allocator --
2106 ------------------------
2115 begin
2116 -- RM E.2.3(22). We enforce that the expected type of an allocator
2117 -- shall not be a remote access-to-class-wide-limited-private type
2119 -- Why is this being done at expansion time, seems clearly wrong ???
2123 -- Set the Storage Pool
2136 else
2142 -- Under certain circumstances we can replace an allocator by an
2143 -- access to statically allocated storage. The conditions, as noted
2144 -- in AARM 3.10 (10c) are as follows:
2146 -- Size and initial value is known at compile time
2147 -- Access type is access-to-constant
2149 -- The allocator is not part of a constraint on a record component,
2150 -- because in that case the inserted actions are delayed until the
2151 -- record declaration is fully analyzed, which is too late for the
2152 -- analysis of the rewritten allocator.
2160 then
2161 -- Here we can do the optimization. For the allocator
2163 -- new x'(y)
2165 -- We insert an object declaration
2167 -- Tnn : aliased x := y;
2169 -- and replace the allocator by Tnn'Unrestricted_Access.
2170 -- Tnn is marked as requiring static allocation.
2172 Temp :=
2177 -- If context is constrained, use constrained subtype directly,
2178 -- so that the constant is not labelled as having a nomimally
2179 -- unconstrained subtype.
2200 -- We set the variable as statically allocated, since we don't
2201 -- want it going on the stack of the current procedure!
2210 -- If the allocator is for a type which requires initialization, and
2211 -- there is no initial value (i.e. operand is a subtype indication
2212 -- rather than a qualifed expression), then we must generate a call
2213 -- to the initialization routine. This is done using an expression
2214 -- actions node:
2215 --
2216 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2217 --
2218 -- Here ptr_T is the pointer type for the allocator, and T is the
2219 -- subtype of the allocator. A special case arises if the designated
2220 -- type of the access type is a task or contains tasks. In this case
2221 -- the call to Init (Temp.all ...) is replaced by code that ensures
2222 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2223 -- for details). In addition, if the type T is a task T, then the
2224 -- first argument to Init must be converted to the task record type.
2226 else
2227 declare
2239 begin
2244 -- Case of no initialization procedure present
2248 -- Case of simple initialization required
2261 -- No initialization required
2263 else
2267 -- Case of initialization procedure present, must be called
2269 else
2272 Temp :=
2275 -- Construct argument list for the initialization routine call
2276 -- The CPP constructor needs the address directly
2282 else
2283 Arg1 :=
2289 -- The initialization procedure expects a specific type.
2290 -- if the context is access to class wide, indicate that
2291 -- the object being allocated has the right specific type.
2298 -- If designated type is a concurrent type or if it is a
2299 -- private type whose definition is a concurrent type,
2300 -- the first argument in the Init routine has to be
2301 -- unchecked conversion to the corresponding record type.
2302 -- If the designated type is a derived type, we also
2303 -- convert the argument to its root type.
2306 Arg1 :=
2312 then
2313 Arg1 :=
2314 Unchecked_Convert_To
2319 declare
2322 begin
2330 -- For the task case, pass the Master_Id of the access type
2331 -- as the value of the _Master parameter, and _Chain as the
2332 -- value of the _Chain parameter (_Chain will be defined as
2333 -- part of the generated code for the allocator).
2339 -- The designated type was an incomplete type, and
2340 -- the access type did not get expanded. Salvage
2341 -- it now.
2343 Expand_N_Full_Type_Declaration
2347 -- If the context of the allocator is a declaration or
2348 -- an assignment, we can generate a meaningful image for
2349 -- it, even though subsequent assignments might remove
2350 -- the connection between task and entity. We build this
2351 -- image when the left-hand side is a simple variable,
2352 -- a simple indexed assignment or a simple selected
2353 -- component.
2356 declare
2359 begin
2361 Decls :=
2362 Build_Task_Image_Decls (
2363 Loc,
2364 New_Occurrence_Of
2370 then
2371 Decls :=
2372 Build_Task_Image_Decls
2374 else
2380 Decls :=
2381 Build_Task_Image_Decls (
2384 else
2389 New_Reference_To
2397 -- Has_Task is false, Decls not used
2399 else
2403 -- Add discriminants if discriminated type
2416 then
2417 Discr :=
2426 -- We set the allocator as analyzed so that when we analyze the
2427 -- expression actions node, we do not get an unwanted recursive
2428 -- expansion of the allocator expression.
2433 -- Here is the transformation:
2434 -- input: new T
2435 -- output: Temp : constant ptr_T := new T;
2436 -- Init (Temp.all, ...);
2437 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
2438 -- <CTRL> Initialize (Finalizable (Temp.all));
2440 -- Here ptr_T is the pointer type for the allocator, and T
2441 -- is the subtype of the allocator.
2443 Temp_Decl :=
2458 -- If the designated type is task type or contains tasks,
2459 -- Create block to activate created tasks, and insert
2460 -- declaration for Task_Image variable ahead of call.
2463 declare
2467 begin
2475 else
2486 Make_Init_Call (
2498 else
2507 exception
2512 -----------------------
2513 -- Expand_N_And_Then --
2514 -----------------------
2516 -- Expand into conditional expression if Actions present, and also
2517 -- deal with optimizing case of arguments being True or False.
2526 begin
2527 -- Deal with non-standard booleans
2535 -- Check for cases of left argument is True or False
2539 -- If left argument is True, change (True and then Right) to Right.
2540 -- Any actions associated with Right will be executed unconditionally
2541 -- and can thus be inserted into the tree unconditionally.
2552 -- If left argument is False, change (False and then Right) to
2553 -- False. In this case we can forget the actions associated with
2554 -- Right, since they will never be executed.
2565 -- If Actions are present, we expand
2567 -- left and then right
2569 -- into
2571 -- if left then right else false end
2573 -- with the actions becoming the Then_Actions of the conditional
2574 -- expression. This conditional expression is then further expanded
2575 -- (and will eventually disappear)
2582 Left,
2583 Right,
2592 -- No actions present, check for cases of right argument True/False
2596 -- Change (Left and then True) to Left. Note that we know there
2597 -- are no actions associated with the True operand, since we
2598 -- just checked for this case above.
2603 -- Change (Left and then False) to False, making sure to preserve
2604 -- any side effects associated with the Left operand.
2608 Rewrite
2616 -------------------------------------
2617 -- Expand_N_Conditional_Expression --
2618 -------------------------------------
2620 -- Expand into expression actions if then/else actions present
2631 begin
2632 -- If either then or else actions are present, then given:
2634 -- if cond then then-expr else else-expr end
2636 -- we insert the following sequence of actions (using Insert_Actions):
2638 -- Cnn : typ;
2639 -- if cond then
2640 -- <<then actions>>
2641 -- Cnn := then-expr;
2642 -- else
2643 -- <<else actions>>
2644 -- Cnn := else-expr
2645 -- end if;
2647 -- and replace the conditional expression by a reference to Cnn.
2652 New_If :=
2670 Insert_List_Before
2675 Insert_List_Before
2691 -----------------------------------
2692 -- Expand_N_Explicit_Dereference --
2693 -----------------------------------
2696 begin
2697 -- The only processing required is an insertion of an explicit
2698 -- dereference call for the checked storage pool case.
2703 -----------------
2704 -- Expand_N_In --
2705 -----------------
2713 begin
2714 -- If we have an explicit range, do a bit of optimization based
2715 -- on range analysis (we may be able to kill one or both checks).
2718 declare
2724 begin
2725 -- If either check is known to fail, replace result
2726 -- by False, since the other check does not matter.
2734 -- If both checks are known to succeed, replace result
2735 -- by True, since we know we are in range.
2743 -- If lower bound check succeeds and upper bound check is
2744 -- not known to succeed or fail, then replace the range check
2745 -- with a comparison against the upper bound.
2755 -- If upper bound check succeeds and lower bound check is
2756 -- not known to succeed or fail, then replace the range check
2757 -- with a comparison against the lower bound.
2769 -- For all other cases of an explicit range, nothing to be done
2773 -- Here right operand is a subtype mark
2775 else
2776 declare
2782 begin
2785 -- For tagged type, do tagged membership operation
2789 -- No expansion will be performed when Java_VM, as the
2790 -- JVM back end will handle the membership tests directly
2791 -- (tags are not explicitly represented in Java objects,
2792 -- so the normal tagged membership expansion is not what
2793 -- we want).
2802 -- If type is scalar type, rewrite as x in t'first .. t'last
2803 -- This reason we do this is that the bounds may have the wrong
2804 -- type if they come from the original type definition.
2809 Low_Bound =>
2814 High_Bound =>
2822 -- Here we have a non-scalar type
2833 -- For the constrained array case, we have to check the
2834 -- subscripts for an exact match if the lengths are
2835 -- non-zero (the lengths must match in any case).
2840 function Construct_Attribute_Reference
2845 -- Build attribute reference E'Nam(Dim)
2847 -----------------------------------
2848 -- Construct_Attribute_Reference --
2849 -----------------------------------
2851 function Construct_Attribute_Reference
2855 return Node_Id
2856 is
2857 begin
2858 return
2866 -- Start processing for Check_Subscripts
2868 begin
2872 Left_Opnd =>
2873 Construct_Attribute_Reference
2876 Right_Opnd =>
2877 Construct_Attribute_Reference
2882 Left_Opnd =>
2883 Construct_Attribute_Reference
2886 Right_Opnd =>
2887 Construct_Attribute_Reference
2892 Cond :=
2894 Left_Opnd =>
2905 -- These are the cases where constraint checks may be
2906 -- required, e.g. records with possible discriminants
2908 else
2909 -- Expand the test into a series of discriminant comparisons.
2910 -- The expression that is built is the negation of the one
2911 -- that is used for checking discriminant constraints.
2921 Left_Opnd =>
2928 else
2939 --------------------------------
2940 -- Expand_N_Indexed_Component --
2941 --------------------------------
2949 begin
2950 -- A special optimization, if we have an indexed component that
2951 -- is selecting from a slice, then we can eliminate the slice,
2952 -- since, for example, x (i .. j)(k) is identical to x(k). The
2953 -- only difference is the range check required by the slice. The
2954 -- range check for the slice itself has already been generated.
2955 -- The range check for the subscripting operation is ensured
2956 -- by converting the subject to the subtype of the slice.
2958 -- This optimization not only generates better code, avoiding
2959 -- slice messing especially in the packed case, but more importantly
2960 -- bypasses some problems in handling this peculiar case, for
2961 -- example, the issue of dealing specially with object renamings.
2968 Convert_To
2975 -- If the prefix is an access type, then we unconditionally rewrite
2976 -- if as an explicit deference. This simplifies processing for several
2977 -- cases, including packed array cases and certain cases in which
2978 -- checks must be generated. We used to try to do this only when it
2979 -- was necessary, but it cleans up the code to do it all the time.
2983 -- Check whether the prefix comes from a debug pool, and generate
2984 -- the check before rewriting.
2994 -- Generate index and validity checks
3002 -- All done for the non-packed case
3008 -- For packed arrays that are not bit-packed (i.e. the case of an array
3009 -- with one or more index types with a non-coniguous enumeration type),
3010 -- we can always use the normal packed element get circuit.
3017 -- For a reference to a component of a bit packed array, we have to
3018 -- convert it to a reference to the corresponding Packed_Array_Type.
3019 -- We only want to do this for simple references, and not for:
3021 -- Left side of assignment, or prefix of left side of assignment,
3022 -- or prefix of the prefix, to handle packed arrays of packed arrays,
3023 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3025 -- Renaming objects in renaming associations
3026 -- This case is handled when a use of the renamed variable occurs
3028 -- Actual parameters for a procedure call
3029 -- This case is handled in Exp_Ch6.Expand_Actuals
3031 -- The second expression in a 'Read attribute reference
3033 -- The prefix of an address or size attribute reference
3035 -- The following circuit detects these exceptions
3037 declare
3041 begin
3042 loop
3049 and then
3051 then
3056 or else
3059 then
3064 then
3067 -- If the expression is an index of an indexed component,
3068 -- it must be expanded regardless of context.
3072 then
3078 then
3084 then
3090 then
3093 else
3098 -- Keep looking up tree for unchecked expression, or if we are
3099 -- the prefix of a possible assignment left side.
3108 ---------------------
3109 -- Expand_N_Not_In --
3110 ---------------------
3112 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
3113 -- can be done. This avoids needing to duplicate this expansion code.
3119 begin
3122 Right_Opnd =>
3129 -------------------
3130 -- Expand_N_Null --
3131 -------------------
3133 -- The only replacement required is for the case of a null of type
3134 -- that is an access to protected subprogram. We represent such
3135 -- access values as a record, and so we must replace the occurrence
3136 -- of null by the equivalent record (with a null address and a null
3137 -- pointer in it), so that the backend creates the proper value.
3144 begin
3146 Agg :=
3155 -- For subsequent semantic analysis, the node must retain its
3156 -- type. Gigi in any case replaces this type by the corresponding
3157 -- record type before processing the node.
3162 exception
3167 ---------------------
3168 -- Expand_N_Op_Abs --
3169 ---------------------
3175 begin
3178 -- Deal with software overflow checking
3180 if not Backend_Overflow_Checks_On_Target
3183 then
3184 -- The only case to worry about is when the argument is
3185 -- equal to the largest negative number, so what we do is
3186 -- to insert the check:
3188 -- [constraint_error when Expr = typ'Base'First]
3190 -- with the usual Duplicate_Subexpr use coding for expr
3194 Condition =>
3197 Right_Opnd =>
3199 Prefix =>
3205 -- Vax floating-point types case
3212 ---------------------
3213 -- Expand_N_Op_Add --
3214 ---------------------
3219 begin
3222 -- N + 0 = 0 + N = N for integer types
3227 then
3233 then
3239 -- Arithmetic overflow checks for signed integer/fixed point types
3243 then
3247 -- Vax floating-point types case
3254 ---------------------
3255 -- Expand_N_Op_And --
3256 ---------------------
3261 begin
3275 ------------------------
3276 -- Expand_N_Op_Concat --
3277 ------------------------
3280 -- This is initialized the first time this routine is called. It records
3281 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3282 -- available in the run-time:
3283 --
3284 -- 0 None available
3285 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
3286 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3287 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3288 -- 5 All routines including RE_Str_Concat_5 available
3291 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3292 -- all three are available, False if any one of these is unavailable.
3297 -- List of operands to be concatenated
3300 -- Single operand for concatenation
3303 -- Node which is to be replaced by the result of concatenating
3304 -- the nodes in the list Opnds.
3307 -- Array type of concatenation result type
3310 -- Component type of concatenation represented by Cnode
3312 begin
3313 -- Initialize global variables showing run-time status
3324 else
3328 Char_Concat_Available :=
3330 and then
3332 and then
3336 -- Ensure validity of both operands
3340 -- If we are the left operand of a concatenation higher up the
3341 -- tree, then do nothing for now, since we want to deal with a
3342 -- series of concatenations as a unit.
3346 then
3350 -- We get here with a concatenation whose left operand may be a
3351 -- concatenation itself with a consistent type. We need to process
3352 -- these concatenation operands from left to right, which means
3353 -- from the deepest node in the tree to the highest node.
3360 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
3361 -- nodes above, so now we process bottom up, doing the operations. We
3362 -- gather a string that is as long as possible up to five operands
3364 -- The outer loop runs more than once if there are more than five
3365 -- concatenations of type Standard.String, the most we handle for
3366 -- this case, or if more than one concatenation type is involved.
3372 -- The inner loop gathers concatenation operands. We gather any
3373 -- number of these in the non-string case, or if no concatenation
3374 -- routines are available for string (since in that case we will
3375 -- treat string like any other non-string case). Otherwise we only
3376 -- gather as many operands as can be handled by the available
3377 -- procedures in the run-time library (normally 5, but may be
3378 -- less for the configurable run-time case).
3382 or else
3384 or else
3386 Max_Available_String_Operands)
3389 loop
3394 -- Here we process the collected operands. First we convert
3395 -- singleton operands to singleton aggregates. This is skipped
3396 -- however for the case of two operands of type String, since
3397 -- we have special routines for these cases.
3403 or else not Char_Concat_Available
3404 then
3406 loop
3419 -- Now call appropriate continuation routine
3423 then
3425 else
3434 ------------------------
3435 -- Expand_N_Op_Divide --
3436 ------------------------
3444 begin
3447 -- Vax_Float is a special case
3454 -- N / 1 = N for integer types
3459 then
3464 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3465 -- Is_Power_Of_2_For_Shift is set means that we know that our left
3466 -- operand is an unsigned integer, as required for this to work.
3471 -- We cannot do this transformation in configurable run time mode if we
3472 -- have 64-bit -- integers and long shifts are not available.
3474 and then
3477 then
3481 Right_Opnd =>
3487 -- Do required fixup of universal fixed operation
3494 -- Divisions with fixed-point results
3498 -- No special processing if Treat_Fixed_As_Integer is set,
3499 -- since from a semantic point of view such operations are
3500 -- simply integer operations and will be treated that way.
3505 else
3510 -- Other cases of division of fixed-point operands. Again we
3511 -- exclude the case where Treat_Fixed_As_Integer is set.
3516 then
3519 else
3524 -- Mixed-mode operations can appear in a non-static universal
3525 -- context, in which case the integer argument must be converted
3526 -- explicitly.
3530 then
3538 then
3544 -- Non-fixed point cases, do zero divide and overflow checks
3549 -- Check for 64-bit division available
3552 and then not Support_64_Bit_Divides_On_Target
3553 then
3559 --------------------
3560 -- Expand_N_Op_Eq --
3561 --------------------
3576 -- If a constructed equality exists for the type or for its parent,
3577 -- build and analyze call, adding conversions if the operation is
3578 -- inherited.
3580 -------------------------
3581 -- Build_Equality_Call --
3582 -------------------------
3589 begin
3592 then
3605 -- Start of processing for Expand_N_Op_Eq
3607 begin
3617 -- It may happen in error situations that the underlying type is not
3618 -- set. The error will be detected later, here we just defend the
3619 -- expander code.
3627 -- Vax float types
3633 -- Boolean types (requiring handling of non-standard case)
3641 -- Array types
3645 -- If we are doing full validity checking, then expand out array
3646 -- comparisons to make sure that we check the array elements.
3649 declare
3651 Force_Validity_Checks;
3652 begin
3663 -- Packed case
3668 -- For non-floating-point elementary types, the primitive equality
3669 -- always applies, and block-bit comparison is fine. Floating-point
3670 -- is an exception because of negative zeroes.
3674 and then Support_Composite_Compare_On_Target
3675 then
3678 -- For composite and floating-point cases, expand equality loop
3679 -- to make sure of using proper comparisons for tagged types,
3680 -- and correctly handling the floating-point case.
3682 else
3691 -- Record Types
3695 -- For tagged types, use the primitive "="
3699 -- If this is derived from an untagged private type completed
3700 -- with a tagged type, it does not have a full view, so we
3701 -- use the primitive operations of the private type.
3702 -- This check should no longer be necessary when these
3703 -- types receive their full views ???
3709 then
3719 -- Find the type's predefined equality or an overriding
3720 -- user-defined equality. The reason for not simply calling
3721 -- Find_Prim_Op here is that there may be a user-defined
3722 -- overloaded equality op that precedes the equality that
3723 -- we want, so we have to explicitly search (e.g., there
3724 -- could be an equality with two different parameter types).
3726 else
3737 and then
3749 -- If a type support function is present (for complex cases), use it
3752 Build_Equality_Call
3755 -- Otherwise expand the component by component equality. Note that
3756 -- we never use block-bit coparisons for records, because of the
3757 -- problems with gaps. The backend will often be able to recombine
3758 -- the separate comparisons that we generate here.
3760 else
3771 -- If we still have an equality comparison (i.e. it was not rewritten
3772 -- in some way), then we can test if result is needed at compile time).
3779 -----------------------
3780 -- Expand_N_Op_Expon --
3781 -----------------------
3799 begin
3802 -- If either operand is of a private type, then we have the use of
3803 -- an intrinsic operator, and we get rid of the privateness, by using
3804 -- root types of underlying types for the actual operation. Otherwise
3805 -- the private types will cause trouble if we expand multiplications
3806 -- or shifts etc. We also do this transformation if the result type
3807 -- is different from the base type.
3810 or else
3812 or else
3814 or else
3816 then
3817 declare
3821 begin
3832 -- Test for case of known right argument
3837 -- We only fold small non-negative exponents. You might think we
3838 -- could fold small negative exponents for the real case, but we
3839 -- can't because we are required to raise Constraint_Error for
3840 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
3841 -- See ACVC test C4A012B.
3845 -- X ** 0 = 1 (or 1.0)
3850 else
3854 -- X ** 1 = X
3859 -- X ** 2 = X * X
3862 Xnode :=
3867 -- X ** 3 = X * X * X
3870 Xnode :=
3872 Left_Opnd =>
3878 -- X ** 4 ->
3879 -- En : constant base'type := base * base;
3880 -- ...
3881 -- En * En
3884 Temp :=
3892 Expression =>
3897 Xnode :=
3909 -- Case of (2 ** expression) appearing as an argument of an integer
3910 -- multiplication, or as the right argument of a division of a non-
3911 -- negative integer. In such cases we leave the node untouched, setting
3912 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
3913 -- of the higher level node converts it into a shift.
3920 and then not Ovflo
3922 then
3923 declare
3928 begin
3930 and then
3932 or else
3936 or else
3942 then
3949 -- Fall through if exponentiation must be done using a runtime routine
3951 -- First deal with modular case
3955 -- Non-binary case, we call the special exponentiation routine for
3956 -- the non-binary case, converting the argument to Long_Long_Integer
3957 -- and passing the modulus value. Then the result is converted back
3958 -- to the base type.
3968 Exp))));
3970 -- Binary case, in this case, we call one of two routines, either
3971 -- the unsigned integer case, or the unsigned long long integer
3972 -- case, with a final "and" operation to do the required mod.
3974 else
3977 else
3984 Left_Opnd =>
3989 Exp)),
3990 Right_Opnd =>
3995 -- Common exit point for modular type case
4000 -- Signed integer cases, done using either Integer or Long_Long_Integer.
4001 -- It is not worth having routines for Short_[Short_]Integer, since for
4002 -- most machines it would not help, and it would generate more code that
4003 -- might need certification in the HI-E case.
4005 -- In the integer cases, we have two routines, one for when overflow
4006 -- checks are required, and one when they are not required, since
4007 -- there is a real gain in ommitting checks on many machines.
4011 and then
4014 then
4019 else
4028 else
4032 -- Floating-point cases, always done using Long_Long_Float. We do not
4033 -- need separate routines for the overflow case here, since in the case
4034 -- of floating-point, we generate infinities anyway as a rule (either
4035 -- that or we automatically trap overflow), and if there is an infinity
4036 -- generated and a range check is required, the check will fail anyway.
4038 else
4044 -- Common processing for integer cases and floating-point cases.
4045 -- If we are in the right type, we can call runtime routine directly
4050 then
4056 -- Otherwise we have to introduce conversions (conversions are also
4057 -- required in the universal cases, since the runtime routine is
4058 -- typed using one of the standard types.
4060 else
4067 Exp))));
4073 exception
4078 --------------------
4079 -- Expand_N_Op_Ge --
4080 --------------------
4088 begin
4110 --------------------
4111 -- Expand_N_Op_Gt --
4112 --------------------
4120 begin
4142 --------------------
4143 -- Expand_N_Op_Le --
4144 --------------------
4152 begin
4174 --------------------
4175 -- Expand_N_Op_Lt --
4176 --------------------
4184 begin
4206 -----------------------
4207 -- Expand_N_Op_Minus --
4208 -----------------------
4214 begin
4217 if not Backend_Overflow_Checks_On_Target
4220 then
4221 -- Software overflow checking expands -expr into (0 - expr)
4230 -- Vax floating-point types case
4237 ---------------------
4238 -- Expand_N_Op_Mod --
4239 ---------------------
4257 begin
4263 -- Convert mod to rem if operands are known non-negative. We do this
4264 -- since it is quite likely that this will improve the quality of code,
4265 -- (the operation now corresponds to the hardware remainder), and it
4266 -- does not seem likely that it could be harmful.
4269 and then
4271 then
4277 -- Instead of reanalyzing the node we do the analysis manually.
4278 -- This avoids anomalies when the replacement is done in an
4279 -- instance and is epsilon more efficient.
4288 -- Otherwise, normal mod processing
4290 else
4295 -- Apply optimization x mod 1 = 0. We don't really need that with
4296 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
4297 -- certainly harmless.
4302 then
4308 -- Deal with annoying case of largest negative number remainder
4309 -- minus one. Gigi does not handle this case correctly, because
4310 -- it generates a divide instruction which may trap in this case.
4312 -- In fact the check is quite easy, if the right operand is -1,
4313 -- then the mod value is always 0, and we can just ignore the
4314 -- left operand completely in this case.
4316 -- The operand type may be private (e.g. in the expansion of an
4317 -- an intrinsic operation) so we must use the underlying type to
4318 -- get the bounds, and convert the literals explicitly.
4320 LLB :=
4321 Expr_Value
4325 and then
4327 then
4333 Right_Opnd =>
4346 --------------------------
4347 -- Expand_N_Op_Multiply --
4348 --------------------------
4367 begin
4370 -- Special optimizations for integer types
4374 -- N * 0 = 0 * N = 0 for integer types
4378 or else
4381 then
4387 -- N * 1 = 1 * N = N for integer types
4389 -- This optimisation is not done if we are going to
4390 -- rewrite the product 1 * 2 ** N to a shift.
4394 and then not Lp2
4395 then
4401 and then not Rp2
4402 then
4408 -- Deal with VAX float case
4415 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
4416 -- Is_Power_Of_2_For_Shift is set means that we know that our left
4417 -- operand is an integer, as required for this to work.
4422 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
4427 Right_Opnd =>
4434 else
4438 Right_Opnd =>
4444 -- Same processing for the operands the other way round
4450 Right_Opnd =>
4456 -- Do required fixup of universal fixed operation
4463 -- Multiplications with fixed-point results
4467 -- No special processing if Treat_Fixed_As_Integer is set,
4468 -- since from a semantic point of view such operations are
4469 -- simply integer operations and will be treated that way.
4473 -- Case of fixed * integer => fixed
4478 -- Case of integer * fixed => fixed
4483 -- Case of fixed * fixed => fixed
4485 else
4490 -- Other cases of multiplication of fixed-point operands. Again
4491 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
4495 then
4498 else
4503 -- Mixed-mode operations can appear in a non-static universal
4504 -- context, in which case the integer argument must be converted
4505 -- explicitly.
4509 then
4516 then
4521 -- Non-fixed point cases, check software overflow checking required
4528 --------------------
4529 -- Expand_N_Op_Ne --
4530 --------------------
4532 -- Rewrite node as the negation of an equality operation, and reanalyze.
4533 -- The equality to be used is defined in the same scope and has the same
4534 -- signature. It must be set explicitly because in an instance it may not
4535 -- have the same visibility as in the generic unit.
4542 begin
4545 Neg :=
4547 Right_Opnd =>
4557 -- For navigation purposes, the inequality is treated as an implicit
4558 -- reference to the corresponding equality. Preserve the Comes_From_
4559 -- source flag so that the proper Xref entry is generated.
4567 ---------------------
4568 -- Expand_N_Op_Not --
4569 ---------------------
4571 -- If the argument is other than a Boolean array type, there is no
4572 -- special expansion required.
4574 -- For the packed case, we call the special routine in Exp_Pakd, except
4575 -- that if the component size is greater than one, we use the standard
4576 -- routine generating a gruesome loop (it is so peculiar to have packed
4577 -- arrays with non-standard Boolean representations anyway, so it does
4578 -- not matter that we do not handle this case efficiently).
4580 -- For the unpacked case (and for the special packed case where we have
4581 -- non standard Booleans, as discussed above), we generate and insert
4582 -- into the tree the following function definition:
4584 -- function Nnnn (A : arr) is
4585 -- B : arr;
4586 -- begin
4587 -- for J in a'range loop
4588 -- B (J) := not A (J);
4589 -- end loop;
4590 -- return B;
4591 -- end Nnnn;
4593 -- Here arr is the actual subtype of the parameter (and hence always
4594 -- constrained). Then we replace the not with a call to this function.
4610 begin
4613 -- For boolean operand, deal with non-standard booleans
4622 -- Only array types need any other processing
4628 -- Case of array operand. If bit packed, handle it in Exp_Pakd
4635 -- Case of array operand which is not bit-packed. If the context is
4636 -- a safe assignment, call in-place operation, If context is a larger
4637 -- boolean expression in the context of a safe assignment, expansion is
4638 -- done by enclosing operation.
4650 -- Special case the negation of a binary operation.
4655 and then Safe_In_Place_Array_Op
4657 then
4664 then
4665 declare
4670 begin
4674 then
4675 -- (not A) op (not B) can be reduced to a single call.
4681 then
4682 -- A xor (not B) can also be special-cased.
4694 A_J :=
4699 B_J :=
4704 Loop_Statement :=
4708 Iteration_Scheme =>
4710 Loop_Parameter_Specification =>
4713 Discrete_Subtype_Definition =>
4728 Specification =>
4742 Handled_Statement_Sequence =>
4745 Loop_Statement,
4747 Expression =>
4758 --------------------
4759 -- Expand_N_Op_Or --
4760 --------------------
4765 begin
4779 ----------------------
4780 -- Expand_N_Op_Plus --
4781 ----------------------
4784 begin
4788 ---------------------
4789 -- Expand_N_Op_Rem --
4790 ---------------------
4807 begin
4814 -- Apply optimization x rem 1 = 0. We don't really need that with
4815 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
4816 -- certainly harmless.
4821 then
4827 -- Deal with annoying case of largest negative number remainder
4828 -- minus one. Gigi does not handle this case correctly, because
4829 -- it generates a divide instruction which may trap in this case.
4831 -- In fact the check is quite easy, if the right operand is -1,
4832 -- then the remainder is always 0, and we can just ignore the
4833 -- left operand completely in this case.
4838 -- The operand type may be private (e.g. in the expansion of an
4839 -- an intrinsic operation) so we must use the underlying type to
4840 -- get the bounds, and convert the literals explicitly.
4842 LLB :=
4843 Expr_Value
4846 -- Now perform the test, generating code only if needed
4849 and then
4851 then
4857 Right_Opnd =>
4871 -----------------------------
4872 -- Expand_N_Op_Rotate_Left --
4873 -----------------------------
4876 begin
4880 ------------------------------
4881 -- Expand_N_Op_Rotate_Right --
4882 ------------------------------
4885 begin
4889 ----------------------------
4890 -- Expand_N_Op_Shift_Left --
4891 ----------------------------
4894 begin
4898 -----------------------------
4899 -- Expand_N_Op_Shift_Right --
4900 -----------------------------
4903 begin
4907 ----------------------------------------
4908 -- Expand_N_Op_Shift_Right_Arithmetic --
4909 ----------------------------------------
4912 begin
4916 --------------------------
4917 -- Expand_N_Op_Subtract --
4918 --------------------------
4923 begin
4926 -- N - 0 = N for integer types
4931 then
4936 -- Arithemtic overflow checks for signed integer/fixed point types
4940 then
4943 -- Vax floating-point types case
4950 ---------------------
4951 -- Expand_N_Op_Xor --
4952 ---------------------
4957 begin
4971 ----------------------
4972 -- Expand_N_Or_Else --
4973 ----------------------
4975 -- Expand into conditional expression if Actions present, and also
4976 -- deal with optimizing case of arguments being True or False.
4985 begin
4986 -- Deal with non-standard booleans
4994 -- Check for cases of left argument is True or False
4998 -- If left argument is False, change (False or else Right) to Right.
4999 -- Any actions associated with Right will be executed unconditionally
5000 -- and can thus be inserted into the tree unconditionally.
5011 -- If left argument is True, change (True and then Right) to
5012 -- True. In this case we can forget the actions associated with
5013 -- Right, since they will never be executed.
5024 -- If Actions are present, we expand
5026 -- left or else right
5028 -- into
5030 -- if left then True else right end
5032 -- with the actions becoming the Else_Actions of the conditional
5033 -- expression. This conditional expression is then further expanded
5034 -- (and will eventually disappear)
5041 Left,
5043 Right)));
5051 -- No actions present, check for cases of right argument True/False
5055 -- Change (Left or else False) to Left. Note that we know there
5056 -- are no actions associated with the True operand, since we
5057 -- just checked for this case above.
5062 -- Change (Left or else True) to True, making sure to preserve
5063 -- any side effects associated with the Left operand.
5067 Rewrite
5075 -----------------------------------
5076 -- Expand_N_Qualified_Expression --
5077 -----------------------------------
5083 begin
5087 ---------------------------------
5088 -- Expand_N_Selected_Component --
5089 ---------------------------------
5091 -- If the selector is a discriminant of a concurrent object, rewrite the
5092 -- prefix to denote the corresponding record type.
5104 -- Gigi needs a temporary for prefixes that depend on a discriminant,
5105 -- unless the context of an assignment can provide size information.
5106 -- Don't we have a general routine that does this???
5108 -----------------------
5109 -- In_Left_Hand_Side --
5110 -----------------------
5113 begin
5121 -- Start of processing for Expand_N_Selected_Component
5123 begin
5124 -- Insert explicit dereference if required
5131 then
5138 -- Deal with discriminant check required
5142 -- Present the discrminant checking function to the backend,
5143 -- so that it can inline the call to the function.
5145 Add_Inlined_Body
5146 (Discriminant_Checking_Func
5149 -- Now reset the flag and generate the call
5155 -- Gigi cannot handle unchecked conversions that are the prefix of a
5156 -- selected component with discriminants. This must be checked during
5157 -- expansion, because during analysis the type of the selector is not
5158 -- known at the point the prefix is analyzed. If the conversion is the
5159 -- target of an assignment, then we cannot force the evaluation.
5164 then
5168 -- Remaining processing applies only if selector is a discriminant
5172 -- If the selector is a discriminant of a constrained record type,
5173 -- we may be able to rewrite the expression with the actual value
5174 -- of the discriminant, a useful optimization in some cases.
5179 then
5180 -- Do this optimization for discrete types only, and not for
5181 -- access types (access discriminants get us into trouble!)
5186 -- Don't do this on the left hand of an assignment statement.
5187 -- Normally one would think that references like this would
5188 -- not occur, but they do in generated code, and mean that
5189 -- we really do want to assign the discriminant!
5193 then
5196 -- Don't do this optimization for the prefix of an attribute
5197 -- or the operand of an object renaming declaration since these
5198 -- are contexts where we do not want the value anyway.
5203 then
5206 -- Don't do this optimization if we are within the code for a
5207 -- discriminant check, since the whole point of such a check may
5208 -- be to verify the condition on which the code below depends!
5213 -- Green light to see if we can do the optimization. There is
5214 -- still one condition that inhibits the optimization below
5215 -- but now is the time to check the particular discriminant.
5217 else
5218 -- Loop through discriminants to find the matching
5219 -- discriminant constraint to see if we can copy it.
5225 -- Check if this is the matching discriminant
5229 -- Here we have the matching discriminant. Check for
5230 -- the case of a discriminant of a component that is
5231 -- constrained by an outer discriminant, which cannot
5232 -- be optimized away.
5234 if
5235 Denotes_Discriminant
5237 then
5240 -- In the context of a case statement, the expression
5241 -- may have the base type of the discriminant, and we
5242 -- need to preserve the constraint to avoid spurious
5243 -- errors on missing cases.
5247 then
5248 -- RBKD is suspicious of the following code. The
5249 -- call to New_Copy instead of New_Copy_Tree is
5250 -- suspicious, and the call to Analyze instead
5251 -- of Analyze_And_Resolve is also suspicious ???
5253 -- Wouldn't it be good enough to do a perfectly
5254 -- normal Analyze_And_Resolve call using the
5255 -- subtype of the discriminant here???
5259 Subtype_Mark =>
5261 Expression =>
5265 -- In case that comes out as a static expression,
5266 -- reset it (a selected component is never static).
5271 -- Otherwise we can just copy the constraint, but the
5272 -- result is certainly not static!
5274 -- Again the New_Copy here and the failure to even
5275 -- to an analyze call is uneasy ???
5277 else
5288 -- Note: the above loop should always find a matching
5289 -- discriminant, but if it does not, we just missed an
5290 -- optimization due to some glitch (perhaps a previous
5291 -- error), so ignore.
5296 -- The only remaining processing is in the case of a discriminant of
5297 -- a concurrent object, where we rewrite the prefix to denote the
5298 -- corresponding record type. If the type is derived and has renamed
5299 -- discriminants, use corresponding discriminant, which is the one
5300 -- that appears in the corresponding record.
5310 then
5314 New_N :=
5316 Prefix =>
5326 --------------------
5327 -- Expand_N_Slice --
5328 --------------------
5337 -- Check whether context is a procedure call, in which case
5338 -- expansion of a bit-packed slice is deferred until the call
5339 -- itself is expanded.
5342 -- Create a named variable for the value of the slice, in
5343 -- cases where the back-end cannot handle it properly, e.g.
5344 -- when packed types or unaligned slices are involved.
5346 -------------------------
5347 -- Is_Procedure_Actual --
5348 -------------------------
5353 begin
5356 loop
5359 else
5367 --------------------
5368 -- Make_Temporary --
5369 --------------------
5375 begin
5376 Decl :=
5384 Decl,
5393 -- Start of processing for Expand_N_Slice
5395 begin
5396 -- Special handling for access types
5400 -- Check for explicit dereference required for checked pool
5404 -- If we have an access to a packed array type, then put in an
5405 -- explicit dereference. We do this in case the slice must be
5406 -- expanded, and we want to make sure we get an access check.
5419 -- Range checks are potentially also needed for cases involving
5420 -- a slice indexed by a subtype indication, but Do_Range_Check
5421 -- can currently only be set for expressions ???
5427 then
5431 -- The remaining case to be handled is packed slices. We can leave
5432 -- packed slices as they are in the following situations:
5434 -- 1. Right or left side of an assignment (we can handle this
5435 -- situation correctly in the assignment statement expansion).
5437 -- 2. Prefix of indexed component (the slide is optimized away
5438 -- in this case, see the start of Expand_N_Slice.
5440 -- 3. Object renaming declaration, since we want the name of
5441 -- the slice, not the value.
5443 -- 4. Argument to procedure call, since copy-in/copy-out handling
5444 -- may be required, and this is handled in the expansion of
5445 -- call itself.
5447 -- 5. Prefix of an address attribute (this is an error which
5448 -- is caught elsewhere, and the expansion would intefere
5449 -- with generating the error message).
5453 -- Apply transformation for actuals of a function call,
5454 -- where Expand_Actuals is not used.
5458 then
5459 Make_Temporary;
5465 then
5471 then
5476 then
5479 else
5480 Make_Temporary;
5484 ------------------------------
5485 -- Expand_N_Type_Conversion --
5486 ------------------------------
5495 -- This is called in the case of record and array type conversions
5496 -- to see if there is a change of representation to be handled.
5497 -- Change of representation is actually handled at the assignment
5498 -- statement level, and what this procedure does is rewrite node N
5499 -- conversion as an assignment to temporary. If there is no change
5500 -- of representation, then the conversion node is unchanged.
5503 -- Handles generation of range check for real target value
5505 -----------------------------------
5506 -- Handle_Changed_Representation --
5507 -----------------------------------
5517 begin
5518 -- Nothing to do if no change of representation
5523 -- The real change of representation work is done by the assignment
5524 -- statement processing. So if this type conversion is appearing as
5525 -- the expression of an assignment statement, nothing needs to be
5526 -- done to the conversion.
5531 -- Otherwise we need to generate a temporary variable, and do the
5532 -- change of representation assignment into that temporary variable.
5533 -- The conversion is then replaced by a reference to this variable.
5535 else
5538 -- If type is unconstrained we have to add a constraint,
5539 -- copied from the actual value of the left hand side.
5554 Selector_Name =>
5565 -- We convert the bounds explicitly. We use an unchecked
5566 -- conversion because bounds checks are done elsewhere.
5570 Low_Bound =>
5573 Prefix =>
5574 Duplicate_Subexpr_No_Checks
5580 High_Bound =>
5583 Prefix =>
5584 Duplicate_Subexpr_No_Checks
5598 Odef :=
5601 Constraint =>
5607 Decl :=
5614 -- Insert required actions. It is essential to suppress checks
5615 -- since we have suppressed default initialization, which means
5616 -- that the variable we create may have no discriminants.
5619 New_List (
5620 Decl,
5631 ----------------------
5632 -- Real_Range_Check --
5633 ----------------------
5635 -- Case of conversions to floating-point or fixed-point. If range
5636 -- checks are enabled and the target type has a range constraint,
5637 -- we convert:
5639 -- typ (x)
5641 -- to
5643 -- Tnn : typ'Base := typ'Base (x);
5644 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
5645 -- Tnn
5647 -- This is necessary when there is a conversion of integer to float
5648 -- or to fixed-point to ensure that the correct checks are made. It
5649 -- is not necessary for float to float where it is enough to simply
5650 -- set the Do_Range_Check flag.
5660 begin
5661 -- Nothing to do if conversion was rewritten
5667 -- Nothing to do if range checks suppressed, or target has the
5668 -- same range as the base type (or is the base type).
5672 and then
5674 then
5678 -- Nothing to do if expression is an entity on which checks
5679 -- have been suppressed.
5683 then
5687 -- Nothing to do if bounds are all static and we can tell that
5688 -- the expression is within the bounds of the target. Note that
5689 -- if the operand is of an unconstrained floating-point type,
5690 -- then we do not trust it to be in range (might be infinite)
5692 declare
5696 begin
5703 then
5704 declare
5710 begin
5714 else
5722 then
5730 -- For float to float conversions, we are done
5733 and then
5735 then
5739 -- Otherwise rewrite the conversion as described above
5742 Rewrite
5746 -- Enable overflow except in the case of integer to float
5747 -- conversions, where it is never required, since we can
5748 -- never have overflow in this case.
5754 Tnn :=
5765 Condition =>
5767 Left_Opnd =>
5770 Right_Opnd =>
5773 Prefix =>
5776 Right_Opnd =>
5779 Right_Opnd =>
5782 Prefix =>
5790 -- Start of processing for Expand_N_Type_Conversion
5792 begin
5793 -- Nothing at all to do if conversion is to the identical type
5794 -- so remove the conversion completely, it is useless.
5801 -- Deal with Vax floating-point cases
5808 -- Nothing to do if this is the second argument of read. This
5809 -- is a "backwards" conversion that will be handled by the
5810 -- specialized code in attribute processing.
5815 then
5819 -- Here if we may need to expand conversion
5821 -- Special case of converting from non-standard boolean type
5825 then
5831 -- Case of converting to an access type
5835 -- Apply an accessibility check if the operand is an
5836 -- access parameter. Note that other checks may still
5837 -- need to be applied below (such as tagged type checks).
5842 then
5845 -- If the level of the operand type is statically deeper
5846 -- then the level of the target type, then force Program_Error.
5847 -- Note that this can only occur for cases where the attribute
5848 -- is within the body of an instantiation (otherwise the
5849 -- conversion will already have been rejected as illegal).
5850 -- Note: warnings are issued by the analyzer for the instance
5851 -- cases.
5853 elsif In_Instance_Body
5856 then
5862 -- When the operand is a selected access discriminant
5863 -- the check needs to be made against the level of the
5864 -- object denoted by the prefix of the selected name.
5865 -- Force Program_Error for this case as well (this
5866 -- accessibility violation can only happen if within
5867 -- the body of an instantiation).
5869 elsif In_Instance_Body
5874 then
5882 -- Case of conversions of tagged types and access to tagged types
5884 -- When needed, that is to say when the expression is class-wide,
5885 -- Add runtime a tag check for (strict) downward conversion by using
5886 -- the membership test, generating:
5888 -- [constraint_error when Operand not in Target_Type'Class]
5890 -- or in the access type case
5892 -- [constraint_error
5893 -- when Operand /= null
5894 -- and then Operand.all not in
5895 -- Designated_Type (Target_Type)'Class]
5900 then
5901 -- Do not do any expansion in the access type case if the
5902 -- parent is a renaming, since this is an error situation
5903 -- which will be caught by Sem_Ch8, and the expansion can
5904 -- intefere with this error check.
5908 then
5912 -- Oherwise, proceed with processing tagged conversion
5914 declare
5920 begin
5925 else
5932 and then Is_Ancestor
5934 Actual_Target_Type)
5936 then
5937 -- The conversion is valid for any descendant of the
5938 -- target type
5943 Cond :=
5945 Left_Opnd =>
5950 Right_Opnd =>
5952 Left_Opnd =>
5954 Prefix =>
5956 Right_Opnd =>
5959 else
5960 Cond :=
5963 Right_Opnd =>
5977 -- Case of other access type conversions
5982 -- Case of conversions from a fixed-point type
5984 -- These conversions require special expansion and processing, found
5985 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
5986 -- set, since from a semantic point of view, these are simple integer
5987 -- conversions, which do not need further processing.
5991 then
5992 -- We should never see universal fixed at this case, since the
5993 -- expansion of the constituent divide or multiply should have
5994 -- eliminated the explicit mention of universal fixed.
5998 -- Check for special case of the conversion to universal real
5999 -- that occurs as a result of the use of a round attribute.
6000 -- In this case, the real type for the conversion is taken
6001 -- from the target type of the Round attribute and the
6002 -- result must be marked as rounded.
6007 then
6012 -- Otherwise do correct fixed-conversion, but skip these if the
6013 -- Conversion_OK flag is set, because from a semantic point of
6014 -- view these are simple integer conversions needing no further
6015 -- processing (the backend will simply treat them as integers)
6020 Real_Range_Check;
6025 else
6028 Real_Range_Check;
6032 -- Case of conversions to a fixed-point type
6034 -- These conversions require special expansion and processing, found
6035 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6036 -- is set, since from a semantic point of view, these are simple
6037 -- integer conversions, which do not need further processing.
6041 then
6044 Real_Range_Check;
6045 else
6048 Real_Range_Check;
6051 -- Case of float-to-integer conversions
6053 -- We also handle float-to-fixed conversions with Conversion_OK set
6054 -- since semantically the fixed-point target is treated as though it
6055 -- were an integer in such cases.
6058 and then
6060 or else
6062 then
6063 -- Special processing required if the conversion is the expression
6064 -- of a Truncation attribute reference. In this case we replace:
6066 -- ityp (ftyp'Truncation (x))
6068 -- by
6070 -- ityp (x)
6072 -- with the Float_Truncate flag set. This is clearly more efficient.
6076 then
6082 -- One more check here, gcc is still not able to do conversions of
6083 -- this type with proper overflow checking, and so gigi is doing an
6084 -- approximation of what is required by doing floating-point compares
6085 -- with the end-point. But that can lose precision in some cases, and
6086 -- give a wrong result. Converting the operand to Long_Long_Float is
6087 -- helpful, but still does not catch all cases with 64-bit integers
6088 -- on targets with only 64-bit floats ???
6093 Subtype_Mark =>
6095 Expression =>
6103 -- Case of array conversions
6105 -- Expansion of array conversions, add required length/range checks
6106 -- but only do this if there is no change of representation. For
6107 -- handling of this case, see Handle_Changed_Representation.
6113 else
6117 Handle_Changed_Representation;
6119 -- Case of conversions of discriminated types
6121 -- Add required discriminant checks if target is constrained. Again
6122 -- this change is skipped if we have a change of representation.
6126 then
6128 Handle_Changed_Representation;
6130 -- Case of all other record conversions. The only processing required
6131 -- is to check for a change of representation requiring the special
6132 -- assignment processing.
6135 Handle_Changed_Representation;
6137 -- Case of conversions of enumeration types
6141 -- Special processing is required if there is a change of
6142 -- representation (from enumeration representation clauses)
6146 -- Convert: x(y) to x'val (ytyp'val (y))
6161 -- Case of conversions to floating-point
6164 Real_Range_Check;
6166 -- The remaining cases require no front end processing
6168 else
6172 -- At this stage, either the conversion node has been transformed
6173 -- into some other equivalent expression, or left as a conversion
6174 -- that can be handled by Gigi. The conversions that Gigi can handle
6175 -- are the following:
6177 -- Conversions with no change of representation or type
6179 -- Numeric conversions involving integer values, floating-point
6180 -- values, and fixed-point values. Fixed-point values are allowed
6181 -- only if Conversion_OK is set, i.e. if the fixed-point values
6182 -- are to be treated as integers.
6184 -- No other conversions should be passed to Gigi.
6186 -- The only remaining step is to generate a range check if we still
6187 -- have a type conversion at this stage and Do_Range_Check is set.
6188 -- For now we do this only for conversions of discrete types.
6192 then
6193 declare
6198 begin
6201 then
6204 -- Before we do a range check, we have to deal with treating
6205 -- a fixed-point operand as an integer. The way we do this
6206 -- is simply to do an unchecked conversion to an appropriate
6207 -- integer type large enough to hold the result.
6209 -- This code is not active yet, because we are only dealing
6210 -- with discrete types so far ???
6214 then
6219 else
6226 -- Reset overflow flag, since the range check will include
6227 -- dealing with possible overflow, and generate the check
6230 Generate_Range_Check
6237 -----------------------------------
6238 -- Expand_N_Unchecked_Expression --
6239 -----------------------------------
6241 -- Remove the unchecked expression node from the tree. It's job was simply
6242 -- to make sure that its constituent expression was handled with checks
6243 -- off, and now that that is done, we can remove it from the tree, and
6244 -- indeed must, since gigi does not expect to see these nodes.
6249 begin
6254 ----------------------------------------
6255 -- Expand_N_Unchecked_Type_Conversion --
6256 ----------------------------------------
6258 -- If this cannot be handled by Gigi and we haven't already made
6259 -- a temporary for it, do it now.
6266 begin
6267 -- If we have a conversion of a compile time known value to a target
6268 -- type and the value is in range of the target type, then we can simply
6269 -- replace the construct by an integer literal of the correct type. We
6270 -- only apply this to integer types being converted. Possibly it may
6271 -- apply in other cases, but it is too much trouble to worry about.
6273 -- Note that we do not do this transformation if the Kill_Range_Check
6274 -- flag is set, since then the value may be outside the expected range.
6275 -- This happens in the Normalize_Scalars case.
6281 then
6282 declare
6285 begin
6287 and then
6289 and then
6291 and then
6293 then
6301 -- Nothing to do if conversion is safe
6307 -- Otherwise force evaluation unless Assignment_OK flag is set (this
6308 -- flag indicates ??? -- more comments needed here)
6312 else
6317 ----------------------------
6318 -- Expand_Record_Equality --
6319 ----------------------------
6321 -- For non-variant records, Equality is expanded when needed into:
6323 -- and then Lhs.Discr1 = Rhs.Discr1
6324 -- and then ...
6325 -- and then Lhs.Discrn = Rhs.Discrn
6326 -- and then Lhs.Cmp1 = Rhs.Cmp1
6327 -- and then ...
6328 -- and then Lhs.Cmpn = Rhs.Cmpn
6330 -- The expression is folded by the back-end for adjacent fields. This
6331 -- function is called for tagged record in only one occasion: for imple-
6332 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
6333 -- otherwise the primitive "=" is used directly.
6335 function Expand_Record_Equality
6341 return Node_Id
6342 is
6346 -- Return the first field to compare beginning with C, skipping the
6347 -- inherited components
6350 begin
6356 then
6361 then
6366 then
6369 else
6379 -- Start of processing for Expand_Record_Equality
6381 begin
6382 -- Special processing for the unchecked union case, which will occur
6383 -- only in the context of tagged types and dynamic dispatching, since
6384 -- other cases are handled statically. We return True, but insert a
6385 -- raise Program_Error statement.
6389 -- If this is a component of an enclosing record, return the Raise
6390 -- statement directly.
6393 Result :=
6399 else
6407 -- Generates the following code: (assuming that Typ has one Discr and
6408 -- component C2 is also a record)
6410 -- True
6411 -- and then Lhs.Discr1 = Rhs.Discr1
6412 -- and then Lhs.C1 = Rhs.C1
6413 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
6414 -- and then ...
6415 -- and then Lhs.Cmpn = Rhs.Cmpn
6422 declare
6426 begin
6432 else
6437 Result :=
6440 Right_Opnd =>
6442 Lhs =>
6446 Rhs =>
6459 -------------------------------------
6460 -- Fixup_Universal_Fixed_Operation --
6461 -------------------------------------
6466 begin
6467 -- We must have a type conversion immediately above us
6471 -- Normally the type conversion gives our target type. The exception
6472 -- occurs in the case of the Round attribute, where the conversion
6473 -- will be to universal real, and our real type comes from the Round
6474 -- attribute (as well as an indication that we must round the result)
6478 then
6482 -- Normal case where type comes from conversion above us
6484 else
6489 ------------------------------
6490 -- Get_Allocator_Final_List --
6491 ------------------------------
6493 function Get_Allocator_Final_List
6497 return Entity_Id
6498 is
6502 begin
6503 -- If the context is an access parameter, we need to create
6504 -- a non-anonymous access type in order to have a usable
6505 -- final list, because there is otherwise no pool to which
6506 -- the allocated object can belong. We create both the type
6507 -- and the finalization chain here, because freezing an
6508 -- internal type does not create such a chain. The Final_Chain
6509 -- that is thus created is shared by the access parameter.
6516 Type_Definition =>
6518 Subtype_Indication =>
6525 else
6530 -------------------------------
6531 -- Insert_Dereference_Action --
6532 -------------------------------
6540 -- return true if type of P is derived from Checked_Pool;
6545 begin
6554 else
6562 -- Start of processing for Insert_Dereference_Action
6564 begin
6579 -- Pool
6583 -- Storage_Address. We use the attribute Pool_Address,
6584 -- which uses the pointer itself to find the address of
6585 -- the object, and which handles unconstrained arrays
6586 -- properly by computing the address of the template.
6587 -- i.e. the correct address of the corresponding allocation.
6593 -- Size_In_Storage_Elements
6596 Left_Opnd =>
6598 Prefix =>
6602 Right_Opnd =>
6605 -- Alignment
6608 Prefix =>
6613 exception
6618 ------------------------------
6619 -- Make_Array_Comparison_Op --
6620 ------------------------------
6622 -- This is a hand-coded expansion of the following generic function:
6624 -- generic
6625 -- type elem is (<>);
6626 -- type index is (<>);
6627 -- type a is array (index range <>) of elem;
6628 --
6629 -- function Gnnn (X : a; Y: a) return boolean is
6630 -- J : index := Y'first;
6631 --
6632 -- begin
6633 -- if X'length = 0 then
6634 -- return false;
6635 --
6636 -- elsif Y'length = 0 then
6637 -- return true;
6638 --
6639 -- else
6640 -- for I in X'range loop
6641 -- if X (I) = Y (J) then
6642 -- if J = Y'last then
6643 -- exit;
6644 -- else
6645 -- J := index'succ (J);
6646 -- end if;
6647 --
6648 -- else
6649 -- return X (I) > Y (J);
6650 -- end if;
6651 -- end loop;
6652 --
6653 -- return X'length > Y'length;
6654 -- end if;
6655 -- end Gnnn;
6657 -- Note that since we are essentially doing this expansion by hand, we
6658 -- do not need to generate an actual or formal generic part, just the
6659 -- instantiated function itself.
6661 function Make_Array_Comparison_Op
6664 return Node_Id
6665 is
6686 begin
6687 -- if J = Y'last then
6688 -- exit;
6689 -- else
6690 -- J := index'succ (J);
6691 -- end if;
6693 Inner_If :=
6695 Condition =>
6698 Right_Opnd =>
6706 Else_Statements =>
6707 New_List (
6710 Expression =>
6716 -- if X (I) = Y (J) then
6717 -- if ... end if;
6718 -- else
6719 -- return X (I) > Y (J);
6720 -- end if;
6722 Loop_Body :=
6724 Condition =>
6726 Left_Opnd =>
6731 Right_Opnd =>
6740 Expression =>
6742 Left_Opnd =>
6747 Right_Opnd =>
6753 -- for I in X'range loop
6754 -- if ... end if;
6755 -- end loop;
6757 Loop_Statement :=
6761 Iteration_Scheme =>
6763 Loop_Parameter_Specification =>
6766 Discrete_Subtype_Definition =>
6773 -- if X'length = 0 then
6774 -- return false;
6775 -- elsif Y'length = 0 then
6776 -- return true;
6777 -- else
6778 -- for ... loop ... end loop;
6779 -- return X'length > Y'length;
6780 -- end if;
6782 Length1 :=
6787 Length2 :=
6792 Final_Expr :=
6797 If_Stat :=
6799 Condition =>
6801 Left_Opnd =>
6805 Right_Opnd =>
6808 Then_Statements =>
6809 New_List (
6815 Condition =>
6817 Left_Opnd =>
6821 Right_Opnd =>
6824 Then_Statements =>
6825 New_List (
6830 Loop_Statement,
6834 -- (X : a; Y: a)
6845 -- function Gnnn (...) return boolean is
6846 -- J : index := Y'first;
6847 -- begin
6848 -- if ... end if;
6849 -- end Gnnn;
6853 Func_Body :=
6855 Specification =>
6865 Expression =>
6870 Handled_Statement_Sequence =>
6878 ---------------------------
6879 -- Make_Boolean_Array_Op --
6880 ---------------------------
6882 -- For logical operations on boolean arrays, expand in line the
6883 -- following, replacing 'and' with 'or' or 'xor' where needed:
6885 -- function Annn (A : typ; B: typ) return typ is
6886 -- C : typ;
6887 -- begin
6888 -- for J in A'range loop
6889 -- C (J) := A (J) op B (J);
6890 -- end loop;
6891 -- return C;
6892 -- end Annn;
6894 -- Here typ is the boolean array type
6896 function Make_Boolean_Array_Op
6899 return Node_Id
6900 is
6918 begin
6919 A_J :=
6924 B_J :=
6929 C_J :=
6935 Op :=
6941 Op :=
6946 else
6947 Op :=
6953 Loop_Statement :=
6957 Iteration_Scheme =>
6959 Loop_Parameter_Specification =>
6962 Discrete_Subtype_Definition =>
6981 Func_Name :=
6985 Func_Body :=
6987 Specification =>
6998 Handled_Statement_Sequence =>
7001 Loop_Statement,
7008 ------------------------
7009 -- Rewrite_Comparison --
7010 ------------------------
7018 -- Res indicates if compare outcome can be determined at compile time
7023 begin
7064 ----------------------------
7065 -- Safe_In_Place_Array_Op --
7066 ----------------------------
7068 function Safe_In_Place_Array_Op
7073 is
7077 -- Operand is safe if it cannot overlap part of the target of the
7078 -- operation. If the operand and the target are identical, the operand
7079 -- is safe. The operand can be empty in the case of negation.
7082 -- Check that N is a stand-alone entity.
7084 ------------------
7085 -- Is_Unaliased --
7086 ------------------
7089 begin
7090 return
7096 ---------------------
7097 -- Is_Safe_Operand --
7098 ---------------------
7101 begin
7110 then
7114 return
7121 else
7126 -- Start of processing for Is_Safe_In_Place_Array_Op
7128 begin
7129 -- We skip this processing if the component size is not the
7130 -- same as a system storage unit (since at least for NOT
7131 -- this would cause problems).
7136 -- Cannot do in place stuff on Java_VM since cannot pass addresses
7141 -- Cannot do in place stuff if non-standard Boolean representation
7148 else
7151 return
7157 -----------------------
7158 -- Tagged_Membership --
7159 -----------------------
7161 -- There are two different cases to consider depending on whether
7162 -- the right operand is a class-wide type or not. If not we just
7163 -- compare the actual tag of the left expr to the target type tag:
7164 --
7165 -- Left_Expr.Tag = Right_Type'Tag;
7166 --
7167 -- If it is a class-wide type we use the RT function CW_Membership which
7168 -- is usually implemented by looking in the ancestor tables contained in
7169 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
7180 begin
7188 Obj_Tag :=
7194 return
7198 Obj_Tag,
7199 New_Reference_To (
7201 else
7202 return
7205 Right_Opnd =>
7211 ------------------------------
7212 -- Unary_Op_Validity_Checks --
7213 ------------------------------
7216 begin