| blob | a65809fb63801a58e08e6749120e035c8bd24af6 |
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 ------------------------------------------------------------------------------
71 -----------------------
72 -- Local Subprograms --
73 -----------------------
77 -- Performs validity checks for a binary operator
79 procedure Build_Boolean_Array_Proc_Call
83 -- If an boolean array assignment can be done in place, build call to
84 -- corresponding library procedure.
87 -- Subsidiary to Expand_N_Allocator, for the case when the expression
88 -- is a qualified expression or an aggregate.
91 -- This routine handles expansion of the comparison operators (N_Op_Lt,
92 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
93 -- code for these operators is similar, differing only in the details of
94 -- the actual comparison call that is made. Special processing (call a
95 -- run-time routine)
97 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. Lhs and Rhs are the array expressions to be compared.
106 -- Bodies is a list on which to attach bodies of local functions that
107 -- are created in the process. It is the responsibility of the
108 -- caller to insert those bodies at the right place. Nod provides
109 -- the Sloc value for the generated code. Normally the types used
110 -- for the generated equality routine are taken from Lhs and Rhs.
111 -- However, in some situations of generated code, the Etype fields
112 -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the
113 -- type to be used for the formal parameters.
116 -- Common expansion processing for Boolean operators (And, Or, Xor)
117 -- for the case of array type arguments.
119 function Expand_Composite_Equality
125 -- Local recursive function used to expand equality for nested
126 -- composite types. Used by Expand_Record/Array_Equality, Bodies
127 -- is a list on which to attach bodies of local functions that are
128 -- created in the process. This is the responsability of the caller
129 -- to insert those bodies at the right place. Nod provides the Sloc
130 -- value for generated code. Lhs and Rhs are the left and right sides
131 -- for the comparison, and Typ is the type of the arrays to compare.
134 -- This routine handles expansion of concatenation operations, where
135 -- N is the N_Op_Concat node being expanded and Operands is the list
136 -- of operands (at least two are present). The caller has dealt with
137 -- converting any singleton operands into singleton aggregates.
140 -- Routine to expand concatenation of 2-5 operands (in the list Operands)
141 -- and replace node Cnode with the result of the contatenation. If there
142 -- are two operands, they can be string or character. If there are more
143 -- than two operands, then are always of type string (i.e. the caller has
144 -- already converted character operands to strings in this case).
147 -- N is either an N_Op_Divide or N_Op_Multiply node whose result is
148 -- universal fixed. We do not have such a type at runtime, so the
149 -- purpose of this routine is to find the real type by looking up
150 -- the tree. We also determine if the operation must be rounded.
152 function Get_Allocator_Final_List
156 -- If the designated type is controlled, build final_list expression
157 -- for created object. If context is an access parameter, create a
158 -- local access type to have a usable finalization list.
161 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
162 -- discriminants if it has a constrained nominal type, unless the object
163 -- is a component of an enclosing Unchecked_Union object that is subject
164 -- to a per-object constraint and the enclosing object lacks inferable
165 -- discriminants.
166 --
167 -- An expression of an Unchecked_Union type has inferable discriminants
168 -- if it is either a name of an object with inferable discriminants or a
169 -- qualified expression whose subtype mark denotes a constrained subtype.
172 -- N is an expression whose type is an access. When the type of the
173 -- associated storage pool is derived from Checked_Pool, generate a
174 -- call to the 'Dereference' primitive operation.
176 function Make_Array_Comparison_Op
179 -- Comparisons between arrays are expanded in line. This function
180 -- produces the body of the implementation of (a > b), where a and b
181 -- are one-dimensional arrays of some discrete type. The original
182 -- node is then expanded into the appropriate call to this function.
183 -- Nod provides the Sloc value for the generated code.
185 function Make_Boolean_Array_Op
188 -- Boolean operations on boolean arrays are expanded in line. This
189 -- function produce the body for the node N, which is (a and b),
190 -- (a or b), or (a xor b). It is used only the normal case and not
191 -- the packed case. The type involved, Typ, is the Boolean array type,
192 -- and the logical operations in the body are simple boolean operations.
193 -- Note that Typ is always a constrained type (the caller has ensured
194 -- this by using Convert_To_Actual_Subtype if necessary).
197 -- If N is the node for a comparison whose outcome can be determined at
198 -- compile time, then the node N can be rewritten with True or False. If
199 -- the outcome cannot be determined at compile time, the call has no
200 -- effect. If N is a type conversion, then this processing is applied to
201 -- its expression. If N is neither comparison nor a type conversion, the
202 -- call has no effect.
205 -- Construct the expression corresponding to the tagged membership test.
206 -- Deals with a second operand being (or not) a class-wide type.
208 function Safe_In_Place_Array_Op
212 -- In the context of an assignment, where the right-hand side is a
213 -- boolean operation on arrays, check whether operation can be performed
214 -- in place.
218 -- Performs validity checks for a unary operator
220 -------------------------------
221 -- Binary_Op_Validity_Checks --
222 -------------------------------
225 begin
232 ------------------------------------
233 -- Build_Boolean_Array_Proc_Call --
234 ------------------------------------
236 procedure Build_Boolean_Array_Proc_Call
240 is
253 begin
257 -- Use negated version of the binary operators
269 Call_Node :=
274 Target,
287 else
290 Call_Node :=
294 Target,
305 else
306 -- We use the following equivalences:
308 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
309 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
310 -- (not X) xor (not Y) = X xor Y
311 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
320 else
324 else
335 else
340 Call_Node :=
344 Target,
359 exception
364 ---------------------------------
365 -- Expand_Allocator_Expression --
366 ---------------------------------
380 -- Type used as source for tag assignment
383 -- Target reference for tag assignment
392 begin
395 -- Ada 2005 (AI-318-02): If the initialization expression is a
396 -- call to a build-in-place function, then access to the allocated
397 -- object must be passed to the function. Currently we limit such
398 -- functions to those with constrained limited result subtypes,
399 -- but eventually we plan to expand the allowed forms of funtions
400 -- that are treated as build-in-place.
404 then
409 -- Actions inserted before:
410 -- Temp : constant ptr_T := new T'(Expression);
411 -- <no CW> Temp._tag := T'tag;
412 -- <CTRL> Adjust (Finalizable (Temp.all));
413 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
415 -- We analyze by hand the new internal allocator to avoid
416 -- any recursion and inappropriate call to Initialize
418 -- We don't want to remove side effects when the expression must be
419 -- built in place. In the case of a build-in-place function call,
420 -- that could lead to a duplication of the call, which was already
421 -- substituted for the allocator.
427 Temp :=
430 -- For a class wide allocation generate the following code:
432 -- type Equiv_Record is record ... end record;
433 -- implicit subtype CW is <Class_Wide_Subytpe>;
434 -- temp : PtrT := new CW'(CW!(expr));
446 Tmp_Node :=
450 Expression =>
454 Set_Comes_From_Source
462 then
463 -- Create local finalization list for access parameter
469 else
480 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
481 -- type, generate an accessibility check to verify that the level of
482 -- the type of the created object is not deeper than the level of the
483 -- access type. If the type of the qualified expression is class-
484 -- wide, then always generate the check. Otherwise, only generate the
485 -- check if the level of the qualified expression type is statically
486 -- deeper than the access type. Although the static accessibility
487 -- will generally have been performed as a legality check, it won't
488 -- have been done in cases where the allocator appears in generic
489 -- body, so a run-time check is needed in general.
494 and then
496 or else
498 then
501 Condition =>
503 Left_Opnd =>
505 Name =>
507 Parameter_Associations =>
509 Prefix =>
511 Attribute_Name =>
512 Name_Tag))),
513 Right_Opnd =>
520 -- Suppress the tag assignment when Java_VM because JVM tags are
521 -- represented implicitly in objects.
531 then
533 TagR :=
540 Tag_Assign :=
542 Name =>
545 Selector_Name =>
548 Expression =>
550 New_Reference_To
552 Loc)));
554 -- The previous assignment has to be done in any case
562 then
563 declare
568 begin
569 -- If it is an allocation on the secondary stack
570 -- (i.e. a value returned from a function), the object
571 -- is attached on the caller side as soon as the call
572 -- is completed (see Expand_Ctrl_Function_Call)
575 declare
579 begin
590 -- Normal case, not a secondary stack allocation
592 else
595 then
596 -- Create local finalization list for access parameter
598 Flist :=
600 else
609 Make_Adjust_Call (
610 Ref =>
612 -- An unchecked conversion is needed in the
613 -- classwide case because the designated type
614 -- can be an ancestor of the subtype mark of
615 -- the allocator.
633 Temp :=
635 Tmp_Node :=
642 Set_Comes_From_Source
654 then
655 -- Apply constraint to designated subtype indication
663 -- Propagate constraint_error to enclosing allocator
667 else
668 -- First check against the type of the qualified expression
669 --
670 -- NOTE: The commented call should be correct, but for
671 -- some reason causes the compiler to bomb (sigsegv) on
672 -- ACVC test c34007g, so for now we just perform the old
673 -- (incorrect) test against the designated subtype with
674 -- no sliding in the else part of the if statement below.
675 -- ???
676 --
677 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
679 -- A check is also needed in cases where the designated
680 -- subtype is constrained and differs from the subtype
681 -- given in the qualified expression. Note that the check
682 -- on the qualified expression does not allow sliding,
683 -- but this check does (a relaxation from Ada 83).
686 and then not Subtypes_Statically_Match
688 then
689 Apply_Constraint_Check
692 -- The nonsliding check should really be performed
693 -- (unconditionally) against the subtype of the
694 -- qualified expression, but that causes a problem
695 -- with c34007g (see above), so for now we retain this.
697 else
698 Apply_Constraint_Check
702 -- For an access to unconstrained packed array, GIGI needs
703 -- to see an expression with a constrained subtype in order
704 -- to compute the proper size for the allocator.
709 then
710 declare
715 begin
719 Subtype_Indication =>
726 -- Ada 2005 (AI-318-02): If the initialization expression is a
727 -- call to a build-in-place function, then access to the allocated
728 -- object must be passed to the function. Currently we limit such
729 -- functions to those with constrained limited result subtypes,
730 -- but eventually we plan to expand the allowed forms of funtions
731 -- that are treated as build-in-place.
735 then
740 exception
745 -----------------------------
746 -- Expand_Array_Comparison --
747 -----------------------------
749 -- Expansion is only required in the case of array types. For the
750 -- unpacked case, an appropriate runtime routine is called. For
751 -- packed cases, and also in some other cases where a runtime
752 -- routine cannot be called, the form of the expansion is:
754 -- [body for greater_nn; boolean_expression]
756 -- The body is built by Make_Array_Comparison_Op, and the form of the
757 -- Boolean expression depends on the operator involved.
773 -- True for byte addressable target
776 -- Returns True if the length of the given operand is known to be
777 -- less than 4. Returns False if this length is known to be four
778 -- or greater or is not known at compile time.
780 ------------------------
781 -- Length_Less_Than_4 --
782 ------------------------
787 begin
791 else
792 declare
799 begin
802 else
808 else
817 -- Start of processing for Expand_Array_Comparison
819 begin
820 -- Deal first with unpacked case, where we can call a runtime routine
821 -- except that we avoid this for targets for which are not addressable
822 -- by bytes, and for the JVM, since the JVM does not support direct
823 -- addressing of array components.
826 and then Byte_Addressable
827 and then not Java_VM
828 then
829 -- The call we generate is:
831 -- Compare_Array_xn[_Unaligned]
832 -- (left'address, right'address, left'length, right'length) <op> 0
834 -- x = U for unsigned, S for signed
835 -- n = 8,16,32,64 for component size
836 -- Add _Unaligned if length < 4 and component size is 8.
837 -- <op> is the standard comparison operator
841 or else
843 then
846 else
850 else
853 else
861 else
868 else
875 else
913 -- Cases where we cannot make runtime call
915 -- For (a <= b) we convert to not (a > b)
920 Right_Opnd =>
927 -- For < the Boolean expression is
928 -- greater__nn (op2, op1)
933 -- Switch operands
938 -- For (a >= b) we convert to not (a < b)
943 Right_Opnd =>
950 -- For > the Boolean expression is
951 -- greater__nn (op1, op2)
953 else
959 Expr :=
968 exception
973 ---------------------------
974 -- Expand_Array_Equality --
975 ---------------------------
977 -- Expand an equality function for multi-dimensional arrays. Here is
978 -- an example of such a function for Nb_Dimension = 2
980 -- function Enn (A : atyp; B : btyp) return boolean is
981 -- begin
982 -- if (A'length (1) = 0 or else A'length (2) = 0)
983 -- and then
984 -- (B'length (1) = 0 or else B'length (2) = 0)
985 -- then
986 -- return True; -- RM 4.5.2(22)
987 -- end if;
989 -- if A'length (1) /= B'length (1)
990 -- or else
991 -- A'length (2) /= B'length (2)
992 -- then
993 -- return False; -- RM 4.5.2(23)
994 -- end if;
996 -- declare
997 -- A1 : Index_T1 := A'first (1);
998 -- B1 : Index_T1 := B'first (1);
999 -- begin
1000 -- loop
1001 -- declare
1002 -- A2 : Index_T2 := A'first (2);
1003 -- B2 : Index_T2 := B'first (2);
1004 -- begin
1005 -- loop
1006 -- if A (A1, A2) /= B (B1, B2) then
1007 -- return False;
1008 -- end if;
1010 -- exit when A2 = A'last (2);
1011 -- A2 := Index_T2'succ (A2);
1012 -- B2 := Index_T2'succ (B2);
1013 -- end loop;
1014 -- end;
1016 -- exit when A1 = A'last (1);
1017 -- A1 := Index_T1'succ (A1);
1018 -- B1 := Index_T1'succ (B1);
1019 -- end loop;
1020 -- end;
1022 -- return true;
1023 -- end Enn;
1025 -- Note on the formal types used (atyp and btyp). If either of the
1026 -- arrays is of a private type, we use the underlying type, and
1027 -- do an unchecked conversion of the actual. If either of the arrays
1028 -- has a bound depending on a discriminant, then we use the base type
1029 -- since otherwise we have an escaped discriminant in the function.
1031 -- If both arrays are constrained and have the same bounds, we can
1032 -- generate a loop with an explicit iteration scheme using a 'Range
1033 -- attribute over the first array.
1035 function Expand_Array_Equality
1041 is
1057 -- The parameter types to be used for the formals
1059 function Arr_Attr
1063 -- This builds the attribute reference Arr'Nam (Expr)
1066 -- Create one statement to compare corresponding components,
1067 -- designated by a full set of indices.
1070 -- Given one of the arguments, computes the appropriate type to
1071 -- be used for that argument in the corresponding function formal
1073 function Handle_One_Dimension
1076 -- This procedure returns the following code
1077 --
1078 -- declare
1079 -- Bn : Index_T := B'First (N);
1080 -- begin
1081 -- loop
1082 -- xxx
1083 -- exit when An = A'Last (N);
1084 -- An := Index_T'Succ (An)
1085 -- Bn := Index_T'Succ (Bn)
1086 -- end loop;
1087 -- end;
1088 --
1089 -- If both indices are constrained and identical, the procedure
1090 -- returns a simpler loop:
1091 --
1092 -- for An in A'Range (N) loop
1093 -- xxx
1094 -- end loop
1095 --
1096 -- N is the dimension for which we are generating a loop. Index is the
1097 -- N'th index node, whose Etype is Index_Type_n in the above code.
1098 -- The xxx statement is either the loop or declare for the next
1099 -- dimension or if this is the last dimension the comparison
1100 -- of corresponding components of the arrays.
1101 --
1102 -- The actual way the code works is to return the comparison
1103 -- of corresponding components for the N+1 call. That's neater!
1106 -- This function constructs the test for both arrays being empty
1107 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1108 -- and then
1109 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1112 -- This function constructs the test for arrays having different
1113 -- lengths in at least one index position, in which case resull
1115 -- A'length (1) /= B'length (1)
1116 -- or else
1117 -- A'length (2) /= B'length (2)
1118 -- or else
1119 -- ...
1121 --------------
1122 -- Arr_Attr --
1123 --------------
1125 function Arr_Attr
1129 is
1130 begin
1131 return
1138 ------------------------
1139 -- Component_Equality --
1140 ------------------------
1146 begin
1147 -- if a(i1...) /= b(j1...) then return false; end if;
1149 L :=
1154 R :=
1159 Test := Expand_Composite_Equality
1162 -- If some (sub)component is an unchecked_union, the whole operation
1163 -- will raise program error.
1167 -- This node is going to be inserted at a location where a
1168 -- statement is expected: clear its Etype so analysis will
1169 -- set it to the expected Standard_Void_Type.
1174 else
1175 return
1184 ------------------
1185 -- Get_Arg_Type --
1186 ------------------
1192 begin
1198 else
1204 or else
1206 then
1218 --------------------------
1219 -- Handle_One_Dimension --
1220 ---------------------------
1222 function Handle_One_Dimension
1225 is
1227 Ltyp /= Rtyp
1229 -- If the index types are identical, and we are working with
1230 -- constrained types, then we can use the same index for both of
1231 -- the arrays.
1241 begin
1246 -- Case where we generate a loop
1251 Bn :=
1254 else
1266 -- Generate guard for loop, followed by increments of indices
1270 Condition =>
1278 Expression =>
1287 Expression =>
1294 -- If separate indexes, we need a declare block for An and Bn, and a
1295 -- loop without an iteration scheme.
1298 Loop_Stm :=
1301 return
1314 Handled_Statement_Sequence =>
1318 -- If no separate indexes, return loop statement with explicit
1319 -- iteration scheme on its own
1321 else
1322 Loop_Stm :=
1325 Iteration_Scheme =>
1327 Loop_Parameter_Specification =>
1330 Discrete_Subtype_Definition =>
1336 -----------------------
1337 -- Test_Empty_Arrays --
1338 -----------------------
1347 begin
1351 Atest :=
1356 Btest :=
1365 else
1366 Alist :=
1371 Blist :=
1378 return
1384 -----------------------------
1385 -- Test_Lengths_Correspond --
1386 -----------------------------
1392 begin
1395 Rtest :=
1402 else
1403 Result :=
1413 -- Start of processing for Expand_Array_Equality
1415 begin
1419 -- For now, if the argument types are not the same, go to the
1420 -- base type, since the code assumes that the formals have the
1421 -- same type. This is fixable in future ???
1429 -- Build list of formals for function
1442 -- Build statement sequence for function
1444 Func_Body :=
1446 Specification =>
1454 Handled_Statement_Sequence =>
1462 Expression =>
1469 Expression =>
1480 -- If the array type is distinct from the type of the arguments,
1481 -- it is the full view of a private type. Apply an unchecked
1482 -- conversion to insure that analysis of the call succeeds.
1484 declare
1487 begin
1493 then
1499 then
1508 return
1514 -----------------------------
1515 -- Expand_Boolean_Operator --
1516 -----------------------------
1518 -- Note that we first get the actual subtypes of the operands,
1519 -- since we always want to deal with types that have bounds.
1524 begin
1525 -- Special case of bit packed array where both operands are known
1526 -- to be properly aligned. In this case we use an efficient run time
1527 -- routine to carry out the operation (see System.Bit_Ops).
1532 then
1537 -- For the normal non-packed case, the general expansion is to build
1538 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1539 -- and then inserting it into the tree. The original operator node is
1540 -- then rewritten as a call to this function. We also use this in the
1541 -- packed case if either operand is a possibly unaligned object.
1543 declare
1550 begin
1559 then
1564 and then
1566 then
1568 else
1574 -- Now rewrite the expression with a call
1579 Parameter_Associations =>
1580 New_List (
1581 L,
1582 Make_Type_Conversion
1590 -------------------------------
1591 -- Expand_Composite_Equality --
1592 -------------------------------
1594 -- This function is only called for comparing internal fields of composite
1595 -- types when these fields are themselves composites. This is a special
1596 -- case because it is not possible to respect normal Ada visibility rules.
1598 function Expand_Composite_Equality
1604 is
1610 begin
1613 else
1617 -- Defense against malformed private types with no completion
1618 -- the error will be diagnosed later by check_completion
1628 -- If the operand is an elementary type other than a floating-point
1629 -- type, then we can simply use the built-in block bitwise equality,
1630 -- since the predefined equality operators always apply and bitwise
1631 -- equality is fine for all these cases.
1635 then
1638 -- For composite component types, and floating-point types, use
1639 -- the expansion. This deals with tagged component types (where
1640 -- we use the applicable equality routine) and floating-point,
1641 -- (where we need to worry about negative zeroes), and also the
1642 -- case of any composite type recursively containing such fields.
1644 else
1650 -- Call the primitive operation "=" of this type
1656 -- If this is derived from an untagged private type completed
1657 -- with a tagged type, it does not have a full view, so we
1658 -- use the primitive operations of the private type.
1659 -- This check should no longer be necessary when these
1660 -- types receive their full views ???
1667 then
1669 else
1673 loop
1685 return
1688 Parameter_Associations =>
1689 New_List
1699 -- Inherited equality from parent type. Convert the actuals
1700 -- to match signature of operation.
1702 declare
1705 begin
1706 return
1709 Parameter_Associations =>
1714 else
1715 -- Comparison between Unchecked_Union components
1718 declare
1724 begin
1725 -- Lhs subtype
1731 -- Rhs subtype
1737 -- Lhs of the composite equality
1741 -- Since the enclosing record can never be an
1742 -- Unchecked_Union (this code is executed for records
1743 -- that do not have variants), we may reference its
1744 -- discriminant(s).
1749 then
1750 Lhs_Discr_Val :=
1753 Selector_Name =>
1754 New_Copy (
1755 Get_Discriminant_Value (
1757 Lhs_Type,
1760 else
1762 Get_Discriminant_Value (
1764 Lhs_Type,
1768 else
1769 -- It is not possible to infer the discriminant since
1770 -- the subtype is not constrained.
1772 return
1777 -- Rhs of the composite equality
1783 then
1784 Rhs_Discr_Val :=
1787 Selector_Name =>
1788 New_Copy (
1789 Get_Discriminant_Value (
1791 Rhs_Type,
1794 else
1796 Get_Discriminant_Value (
1798 Rhs_Type,
1802 else
1803 return
1808 -- Call the TSS equality function with the inferred
1809 -- discriminant values.
1811 return
1815 Lhs,
1816 Rhs,
1817 Lhs_Discr_Val,
1818 Rhs_Discr_Val));
1822 -- Shouldn't this be an else, we can't fall through
1823 -- the above IF, right???
1825 return
1831 else
1835 else
1836 -- It can be a simple record or the full view of a scalar private
1842 ------------------------------
1843 -- Expand_Concatenate_Other --
1844 ------------------------------
1846 -- Let n be the number of array operands to be concatenated, Base_Typ
1847 -- their base type, Ind_Typ their index type, and Arr_Typ the original
1848 -- array type to which the concatenantion operator applies, then the
1849 -- following subprogram is constructed:
1851 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1852 -- L : Ind_Typ;
1853 -- begin
1854 -- if S1'Length /= 0 then
1855 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
1856 -- XXX = Arr_Typ'First otherwise
1857 -- elsif S2'Length /= 0 then
1858 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
1859 -- YYY = Arr_Typ'First otherwise
1860 -- ...
1861 -- elsif Sn-1'Length /= 0 then
1862 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
1863 -- ZZZ = Arr_Typ'First otherwise
1864 -- else
1865 -- return Sn;
1866 -- end if;
1868 -- declare
1869 -- P : Ind_Typ;
1870 -- H : Ind_Typ :=
1871 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1872 -- + Ind_Typ'Pos (L));
1873 -- R : Base_Typ (L .. H);
1874 -- begin
1875 -- if S1'Length /= 0 then
1876 -- P := S1'First;
1877 -- loop
1878 -- R (L) := S1 (P);
1879 -- L := Ind_Typ'Succ (L);
1880 -- exit when P = S1'Last;
1881 -- P := Ind_Typ'Succ (P);
1882 -- end loop;
1883 -- end if;
1884 --
1885 -- if S2'Length /= 0 then
1886 -- L := Ind_Typ'Succ (L);
1887 -- loop
1888 -- R (L) := S2 (P);
1889 -- L := Ind_Typ'Succ (L);
1890 -- exit when P = S2'Last;
1891 -- P := Ind_Typ'Succ (P);
1892 -- end loop;
1893 -- end if;
1895 -- ...
1897 -- if Sn'Length /= 0 then
1898 -- P := Sn'First;
1899 -- loop
1900 -- R (L) := Sn (P);
1901 -- L := Ind_Typ'Succ (L);
1902 -- exit when P = Sn'Last;
1903 -- P := Ind_Typ'Succ (P);
1904 -- end loop;
1905 -- end if;
1907 -- return R;
1908 -- end;
1909 -- end Cnn;]
1947 -- Builds the sequence of statement:
1948 -- P := Si'First;
1949 -- loop
1950 -- R (L) := Si (P);
1951 -- L := Ind_Typ'Succ (L);
1952 -- exit when P = Si'Last;
1953 -- P := Ind_Typ'Succ (P);
1954 -- end loop;
1955 --
1956 -- where i is the input parameter I given.
1957 -- If the flag Last is true, the exit statement is emitted before
1958 -- incrementing the lower bound, to prevent the creation out of
1959 -- bound values.
1962 -- Builds the statement:
1963 -- L := Arr_Typ'First; If Arr_Typ is constrained
1964 -- L := Si'First; otherwise (where I is the input param given)
1967 -- Builds reference to identifier H
1970 -- Builds expression Ind_Typ'Val (E);
1973 -- Builds reference to identifier L
1976 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
1977 -- expression to avoid universal_integer computations whenever possible,
1978 -- in the expression for the upper bound H.
1981 -- Builds expression Ind_Typ'Succ (L)
1984 -- Builds integer literal one
1987 -- Builds reference to identifier P
1990 -- Builds expression Ind_Typ'Succ (P)
1993 -- Builds reference to identifier R
1996 -- Builds reference to identifier Si, where I is the value given
1999 -- Builds expression Si'First, where I is the value given
2002 -- Builds expression Si'Last, where I is the value given
2005 -- Builds expression Si'Length, where I is the value given
2008 -- Builds expression Si'Length /= 0, where I is the value given
2010 -------------------
2011 -- Copy_Into_R_S --
2012 -------------------
2023 begin
2024 -- First construct the initializations
2031 -- Then build the loop
2053 Loop_Stmt :=
2056 else
2057 Loop_Stmt :=
2067 -------
2068 -- H --
2069 -------
2072 begin
2076 -------------
2077 -- Ind_Val --
2078 -------------
2081 begin
2082 return
2089 ------------
2090 -- Init_L --
2091 ------------
2096 begin
2102 else
2109 -------
2110 -- L --
2111 -------
2114 begin
2118 -----------
2119 -- L_Pos --
2120 -----------
2125 begin
2126 -- If the index type is an enumeration type, the computation
2127 -- can be done in standard integer. Otherwise, choose a large
2128 -- enough integer type.
2134 then
2136 else
2140 return
2143 Expression =>
2150 ------------
2151 -- L_Succ --
2152 ------------
2155 begin
2156 return
2163 ---------
2164 -- One --
2165 ---------
2168 begin
2172 -------
2173 -- P --
2174 -------
2177 begin
2181 ------------
2182 -- P_Succ --
2183 ------------
2186 begin
2187 return
2194 -------
2195 -- R --
2196 -------
2199 begin
2203 -------
2204 -- S --
2205 -------
2208 begin
2212 -------------
2213 -- S_First --
2214 -------------
2217 begin
2223 ------------
2224 -- S_Last --
2225 ------------
2228 begin
2234 --------------
2235 -- S_Length --
2236 --------------
2239 begin
2245 -------------------
2246 -- S_Length_Test --
2247 -------------------
2250 begin
2251 return
2257 -- Start of processing for Expand_Concatenate_Other
2259 begin
2260 -- Construct the parameter specs and the overall function spec
2264 Append_To
2267 Defining_Identifier =>
2273 Func_Spec :=
2279 -- Construct L's object declaration
2281 L_Decl :=
2288 -- Construct the if-then-elsif statements
2297 If_Stmt :=
2305 -- Construct the declaration for H
2307 P_Decl :=
2318 H_Decl :=
2324 -- Construct the declaration for R
2327 R_Constr :=
2331 R_Decl :=
2334 Object_Definition =>
2339 -- Construct the declarations for the declare block
2343 -- Construct list of statements for the declare block
2355 -- Construct the declare block
2359 Handled_Statement_Sequence =>
2362 -- Construct the list of function statements
2366 -- Construct the function body
2368 Func_Body :=
2372 Handled_Statement_Sequence =>
2375 -- Insert the newly generated function in the code. This is analyzed
2376 -- with all checks off, since we have completed all the checks.
2378 -- Note that this does *not* fix the array concatenation bug when the
2379 -- low bound is Integer'first sibce that bug comes from the pointer
2380 -- dereferencing an unconstrained array. An there we need a constraint
2381 -- check to make sure the length of the concatenated array is ok. ???
2385 -- Construct list of arguments for the function call
2394 -- Insert the function call
2396 Rewrite
2404 -------------------------------
2405 -- Expand_Concatenate_String --
2406 -------------------------------
2416 -- RE_Id value for function to be called
2418 begin
2419 -- In all cases, we build a call to a routine giving the list of
2420 -- arguments as the parameter list to the routine.
2428 else
2437 else
2442 -- If we have anything other than Standard_Character or
2443 -- Standard_String, then we must have had a serious error
2444 -- earlier, so we just abandon the attempt at expansion.
2446 else
2465 -- Now generate the appropriate call
2474 exception
2479 ------------------------
2480 -- Expand_N_Allocator --
2481 ------------------------
2492 begin
2493 -- RM E.2.3(22). We enforce that the expected type of an allocator
2494 -- shall not be a remote access-to-class-wide-limited-private type
2496 -- Why is this being done at expansion time, seems clearly wrong ???
2500 -- Set the Storage Pool
2513 else
2519 -- Under certain circumstances we can replace an allocator by an
2520 -- access to statically allocated storage. The conditions, as noted
2521 -- in AARM 3.10 (10c) are as follows:
2523 -- Size and initial value is known at compile time
2524 -- Access type is access-to-constant
2526 -- The allocator is not part of a constraint on a record component,
2527 -- because in that case the inserted actions are delayed until the
2528 -- record declaration is fully analyzed, which is too late for the
2529 -- analysis of the rewritten allocator.
2537 then
2538 -- Here we can do the optimization. For the allocator
2540 -- new x'(y)
2542 -- We insert an object declaration
2544 -- Tnn : aliased x := y;
2546 -- and replace the allocator by Tnn'Unrestricted_Access.
2547 -- Tnn is marked as requiring static allocation.
2549 Temp :=
2554 -- If context is constrained, use constrained subtype directly,
2555 -- so that the constant is not labelled as having a nomimally
2556 -- unconstrained subtype.
2577 -- We set the variable as statically allocated, since we don't
2578 -- want it going on the stack of the current procedure!
2584 -- Handle case of qualified expression (other than optimization above)
2589 -- If the allocator is for a type which requires initialization, and
2590 -- there is no initial value (i.e. operand is a subtype indication
2591 -- rather than a qualifed expression), then we must generate a call
2592 -- to the initialization routine. This is done using an expression
2593 -- actions node:
2594 --
2595 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2596 --
2597 -- Here ptr_T is the pointer type for the allocator, and T is the
2598 -- subtype of the allocator. A special case arises if the designated
2599 -- type of the access type is a task or contains tasks. In this case
2600 -- the call to Init (Temp.all ...) is replaced by code that ensures
2601 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2602 -- for details). In addition, if the type T is a task T, then the
2603 -- first argument to Init must be converted to the task record type.
2605 else
2606 declare
2619 begin
2623 -- Case of no initialization procedure present
2627 -- Case of simple initialization required
2640 -- No initialization required
2642 else
2646 -- Case of initialization procedure present, must be called
2648 else
2651 Temp :=
2654 -- Construct argument list for the initialization routine call
2655 -- The CPP constructor needs the address directly
2661 else
2662 Arg1 :=
2668 -- The initialization procedure expects a specific type. if
2669 -- the context is access to class wide, indicate that the
2670 -- object being allocated has the right specific type.
2677 -- If designated type is a concurrent type or if it is private
2678 -- type whose definition is a concurrent type, the first
2679 -- argument in the Init routine has to be unchecked conversion
2680 -- to the corresponding record type. If the designated type is
2681 -- a derived type, we also convert the argument to its root
2682 -- type.
2685 Arg1 :=
2691 then
2692 Arg1 :=
2693 Unchecked_Convert_To
2698 declare
2701 begin
2709 -- For the task case, pass the Master_Id of the access type as
2710 -- the value of the _Master parameter, and _Chain as the value
2711 -- of the _Chain parameter (_Chain will be defined as part of
2712 -- the generated code for the allocator).
2714 -- In Ada 2005, the context may be a function that returns an
2715 -- anonymous access type. In that case the Master_Id has been
2716 -- created when expanding the function declaration.
2721 -- The designated type was an incomplete type, and the
2722 -- access type did not get expanded. Salvage it now.
2724 Expand_N_Full_Type_Declaration
2728 -- If the context of the allocator is a declaration or an
2729 -- assignment, we can generate a meaningful image for it,
2730 -- even though subsequent assignments might remove the
2731 -- connection between task and entity. We build this image
2732 -- when the left-hand side is a simple variable, a simple
2733 -- indexed assignment or a simple selected component.
2736 declare
2739 begin
2741 Decls :=
2742 Build_Task_Image_Decls (
2743 Loc,
2744 New_Occurrence_Of
2750 then
2751 Decls :=
2752 Build_Task_Image_Decls
2754 else
2760 Decls :=
2761 Build_Task_Image_Decls (
2764 else
2769 New_Reference_To
2777 -- Has_Task is false, Decls not used
2779 else
2783 -- Add discriminants if discriminated type
2785 declare
2789 begin
2797 then
2803 -- If the allocated object will be constrained by the
2804 -- default values for discriminants, then build a
2805 -- subtype with those defaults, and change the allocated
2806 -- subtype to that. Note that this happens in fewer
2807 -- cases in Ada 2005 (AI-363).
2814 then
2824 -- AI-416: when the discriminant constraint is an
2825 -- anonymous access type make sure an accessibility
2826 -- check is inserted if necessary (3.10.2(22.q/2))
2829 and then
2831 then
2840 -- We set the allocator as analyzed so that when we analyze the
2841 -- expression actions node, we do not get an unwanted recursive
2842 -- expansion of the allocator expression.
2847 -- Here is the transformation:
2848 -- input: new T
2849 -- output: Temp : constant ptr_T := new T;
2850 -- Init (Temp.all, ...);
2851 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
2852 -- <CTRL> Initialize (Finalizable (Temp.all));
2854 -- Here ptr_T is the pointer type for the allocator, and is the
2855 -- subtype of the allocator.
2857 Temp_Decl :=
2872 -- If the designated type is a task type or contains tasks,
2873 -- create block to activate created tasks, and insert
2874 -- declaration for Task_Image variable ahead of call.
2877 declare
2881 begin
2889 else
2900 else
2904 Make_Init_Call (
2909 Attach_Level)));
2917 else
2926 -- Ada 2005 (AI-251): If the allocated object is accessed through an
2927 -- access to class-wide interface we force the displacement of the
2928 -- pointer to the allocated object to reference the corresponding
2929 -- secondary dispatch table.
2933 then
2934 declare
2937 begin
2938 -- 1) Get access to the allocated object
2946 -- 2) Add the conversion to displace the pointer to reference
2947 -- the secondary dispatch table.
2952 -- 3) The 'access to the secondary dispatch table will be used as
2953 -- the value returned by the allocator.
2964 exception
2969 -----------------------
2970 -- Expand_N_And_Then --
2971 -----------------------
2973 -- Expand into conditional expression if Actions present, and also deal
2974 -- with optimizing case of arguments being True or False.
2983 begin
2984 -- Deal with non-standard booleans
2992 -- Check for cases of left argument is True or False
2996 -- If left argument is True, change (True and then Right) to Right.
2997 -- Any actions associated with Right will be executed unconditionally
2998 -- and can thus be inserted into the tree unconditionally.
3009 -- If left argument is False, change (False and then Right) to False.
3010 -- In this case we can forget the actions associated with Right,
3011 -- since they will never be executed.
3022 -- If Actions are present, we expand
3024 -- left and then right
3026 -- into
3028 -- if left then right else false end
3030 -- with the actions becoming the Then_Actions of the conditional
3031 -- expression. This conditional expression is then further expanded
3032 -- (and will eventually disappear)
3039 Left,
3040 Right,
3049 -- No actions present, check for cases of right argument True/False
3053 -- Change (Left and then True) to Left. Note that we know there
3054 -- are no actions associated with the True operand, since we
3055 -- just checked for this case above.
3060 -- Change (Left and then False) to False, making sure to preserve
3061 -- any side effects associated with the Left operand.
3065 Rewrite
3073 -------------------------------------
3074 -- Expand_N_Conditional_Expression --
3075 -------------------------------------
3077 -- Expand into expression actions if then/else actions present
3088 begin
3089 -- If either then or else actions are present, then given:
3091 -- if cond then then-expr else else-expr end
3093 -- we insert the following sequence of actions (using Insert_Actions):
3095 -- Cnn : typ;
3096 -- if cond then
3097 -- <<then actions>>
3098 -- Cnn := then-expr;
3099 -- else
3100 -- <<else actions>>
3101 -- Cnn := else-expr
3102 -- end if;
3104 -- and replace the conditional expression by a reference to Cnn
3109 New_If :=
3127 Insert_List_Before
3132 Insert_List_Before
3148 -----------------------------------
3149 -- Expand_N_Explicit_Dereference --
3150 -----------------------------------
3153 begin
3154 -- Insert explicit dereference call for the checked storage pool case
3159 -----------------
3160 -- Expand_N_In --
3161 -----------------
3171 -- Replaces node N by Lop'Valid. This is done when we have an explicit
3172 -- test for the left operand being in range of its subtype.
3174 ----------------------------
3175 -- Substitute_Valid_Check --
3176 ----------------------------
3179 begin
3192 -- Start of processing for Expand_N_In
3194 begin
3195 -- Check case of explicit test for an expression in range of its
3196 -- subtype. This is suspicious usage and we replace it with a 'Valid
3197 -- test and give a warning.
3203 then
3204 Substitute_Valid_Check;
3208 -- Do validity check on operands
3215 -- Case of explicit range
3218 declare
3228 begin
3229 -- If test is explicit x'first .. x'last, replace by valid check
3241 then
3242 Substitute_Valid_Check;
3246 -- If we have an explicit range, do a bit of optimization based
3247 -- on range analysis (we may be able to kill one or both checks).
3249 -- If either check is known to fail, replace result by False since
3250 -- the other check does not matter. Preserve the static flag for
3251 -- legality checks, because we are constant-folding beyond RM 4.9.
3260 -- If both checks are known to succeed, replace result
3261 -- by True, since we know we are in range.
3270 -- If lower bound check succeeds and upper bound check is
3271 -- not known to succeed or fail, then replace the range check
3272 -- with a comparison against the upper bound.
3282 -- If upper bound check succeeds and lower bound check is
3283 -- not known to succeed or fail, then replace the range check
3284 -- with a comparison against the lower bound.
3296 -- For all other cases of an explicit range, nothing to be done
3300 -- Here right operand is a subtype mark
3302 else
3303 declare
3309 begin
3312 -- For tagged type, do tagged membership operation
3316 -- No expansion will be performed when Java_VM, as the JVM back
3317 -- end will handle the membership tests directly (tags are not
3318 -- explicitly represented in Java objects, so the normal tagged
3319 -- membership expansion is not what we want).
3328 -- If type is scalar type, rewrite as x in t'first .. t'last.
3329 -- This reason we do this is that the bounds may have the wrong
3330 -- type if they come from the original type definition.
3335 Low_Bound =>
3340 High_Bound =>
3347 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
3348 -- a membership test if the subtype mark denotes a constrained
3349 -- Unchecked_Union subtype and the expression lacks inferable
3350 -- discriminants.
3355 then
3360 -- Prevent Gigi from generating incorrect code by rewriting
3361 -- the test as a standard False.
3369 -- Here we have a non-scalar type
3380 -- For the constrained array case, we have to check the
3381 -- subscripts for an exact match if the lengths are
3382 -- non-zero (the lengths must match in any case).
3387 function Construct_Attribute_Reference
3391 -- Build attribute reference E'Nam(Dim)
3393 -----------------------------------
3394 -- Construct_Attribute_Reference --
3395 -----------------------------------
3397 function Construct_Attribute_Reference
3401 is
3402 begin
3403 return
3411 -- Start processing for Check_Subscripts
3413 begin
3417 Left_Opnd =>
3418 Construct_Attribute_Reference
3421 Right_Opnd =>
3422 Construct_Attribute_Reference
3427 Left_Opnd =>
3428 Construct_Attribute_Reference
3431 Right_Opnd =>
3432 Construct_Attribute_Reference
3437 Cond :=
3439 Left_Opnd =>
3450 -- These are the cases where constraint checks may be
3451 -- required, e.g. records with possible discriminants
3453 else
3454 -- Expand the test into a series of discriminant comparisons.
3455 -- The expression that is built is the negation of the one
3456 -- that is used for checking discriminant constraints.
3466 Left_Opnd =>
3473 else
3484 --------------------------------
3485 -- Expand_N_Indexed_Component --
3486 --------------------------------
3494 begin
3495 -- A special optimization, if we have an indexed component that
3496 -- is selecting from a slice, then we can eliminate the slice,
3497 -- since, for example, x (i .. j)(k) is identical to x(k). The
3498 -- only difference is the range check required by the slice. The
3499 -- range check for the slice itself has already been generated.
3500 -- The range check for the subscripting operation is ensured
3501 -- by converting the subject to the subtype of the slice.
3503 -- This optimization not only generates better code, avoiding
3504 -- slice messing especially in the packed case, but more importantly
3505 -- bypasses some problems in handling this peculiar case, for
3506 -- example, the issue of dealing specially with object renamings.
3513 Convert_To
3520 -- If the prefix is an access type, then we unconditionally rewrite
3521 -- if as an explicit deference. This simplifies processing for several
3522 -- cases, including packed array cases and certain cases in which
3523 -- checks must be generated. We used to try to do this only when it
3524 -- was necessary, but it cleans up the code to do it all the time.
3531 -- Generate index and validity checks
3539 -- All done for the non-packed case
3545 -- For packed arrays that are not bit-packed (i.e. the case of an array
3546 -- with one or more index types with a non-coniguous enumeration type),
3547 -- we can always use the normal packed element get circuit.
3554 -- For a reference to a component of a bit packed array, we have to
3555 -- convert it to a reference to the corresponding Packed_Array_Type.
3556 -- We only want to do this for simple references, and not for:
3558 -- Left side of assignment, or prefix of left side of assignment,
3559 -- or prefix of the prefix, to handle packed arrays of packed arrays,
3560 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3562 -- Renaming objects in renaming associations
3563 -- This case is handled when a use of the renamed variable occurs
3565 -- Actual parameters for a procedure call
3566 -- This case is handled in Exp_Ch6.Expand_Actuals
3568 -- The second expression in a 'Read attribute reference
3570 -- The prefix of an address or size attribute reference
3572 -- The following circuit detects these exceptions
3574 declare
3578 begin
3579 loop
3586 and then
3588 then
3593 or else
3596 then
3601 then
3604 -- If the expression is an index of an indexed component,
3605 -- it must be expanded regardless of context.
3609 then
3615 then
3621 then
3627 then
3630 else
3635 -- Keep looking up tree for unchecked expression, or if we are
3636 -- the prefix of a possible assignment left side.
3644 ---------------------
3645 -- Expand_N_Not_In --
3646 ---------------------
3648 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
3649 -- can be done. This avoids needing to duplicate this expansion code.
3656 begin
3659 Right_Opnd =>
3664 -- We want this tp appear as coming from source if original does (see
3665 -- tranformations in Expand_N_In).
3670 -- Now analyze tranformed node
3675 -------------------
3676 -- Expand_N_Null --
3677 -------------------
3679 -- The only replacement required is for the case of a null of type
3680 -- that is an access to protected subprogram. We represent such
3681 -- access values as a record, and so we must replace the occurrence
3682 -- of null by the equivalent record (with a null address and a null
3683 -- pointer in it), so that the backend creates the proper value.
3690 begin
3692 Agg :=
3701 -- For subsequent semantic analysis, the node must retain its
3702 -- type. Gigi in any case replaces this type by the corresponding
3703 -- record type before processing the node.
3708 exception
3713 ---------------------
3714 -- Expand_N_Op_Abs --
3715 ---------------------
3721 begin
3724 -- Deal with software overflow checking
3726 if not Backend_Overflow_Checks_On_Target
3729 then
3730 -- The only case to worry about is when the argument is
3731 -- equal to the largest negative number, so what we do is
3732 -- to insert the check:
3734 -- [constraint_error when Expr = typ'Base'First]
3736 -- with the usual Duplicate_Subexpr use coding for expr
3740 Condition =>
3743 Right_Opnd =>
3745 Prefix =>
3751 -- Vax floating-point types case
3758 ---------------------
3759 -- Expand_N_Op_Add --
3760 ---------------------
3765 begin
3768 -- N + 0 = 0 + N = N for integer types
3773 then
3779 then
3785 -- Arithmetic overflow checks for signed integer/fixed point types
3789 then
3793 -- Vax floating-point types case
3800 ---------------------
3801 -- Expand_N_Op_And --
3802 ---------------------
3807 begin
3821 ------------------------
3822 -- Expand_N_Op_Concat --
3823 ------------------------
3826 -- This is initialized the first time this routine is called. It records
3827 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3828 -- available in the run-time:
3829 --
3830 -- 0 None available
3831 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
3832 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3833 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3834 -- 5 All routines including RE_Str_Concat_5 available
3837 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3838 -- all three are available, False if any one of these is unavailable.
3842 -- List of operands to be concatenated
3845 -- Single operand for concatenation
3848 -- Node which is to be replaced by the result of concatenating
3849 -- the nodes in the list Opnds.
3852 -- Array type of concatenation result type
3855 -- Component type of concatenation represented by Cnode
3857 begin
3858 -- Initialize global variables showing run-time status
3869 else
3873 Char_Concat_Available :=
3875 and then
3877 and then
3881 -- Ensure validity of both operands
3885 -- If we are the left operand of a concatenation higher up the
3886 -- tree, then do nothing for now, since we want to deal with a
3887 -- series of concatenations as a unit.
3891 then
3895 -- We get here with a concatenation whose left operand may be a
3896 -- concatenation itself with a consistent type. We need to process
3897 -- these concatenation operands from left to right, which means
3898 -- from the deepest node in the tree to the highest node.
3905 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
3906 -- nodes above, so now we process bottom up, doing the operations. We
3907 -- gather a string that is as long as possible up to five operands
3909 -- The outer loop runs more than once if there are more than five
3910 -- concatenations of type Standard.String, the most we handle for
3911 -- this case, or if more than one concatenation type is involved.
3917 -- The inner loop gathers concatenation operands. We gather any
3918 -- number of these in the non-string case, or if no concatenation
3919 -- routines are available for string (since in that case we will
3920 -- treat string like any other non-string case). Otherwise we only
3921 -- gather as many operands as can be handled by the available
3922 -- procedures in the run-time library (normally 5, but may be
3923 -- less for the configurable run-time case).
3927 or else
3929 or else
3931 Max_Available_String_Operands)
3934 loop
3939 -- Here we process the collected operands. First we convert
3940 -- singleton operands to singleton aggregates. This is skipped
3941 -- however for the case of two operands of type String, since
3942 -- we have special routines for these cases.
3948 or else not Char_Concat_Available
3949 then
3951 loop
3964 -- Now call appropriate continuation routine
3968 then
3970 else
3979 ------------------------
3980 -- Expand_N_Op_Divide --
3981 ------------------------
3991 and then
3995 begin
4002 -- N / 1 = N for integer types
4009 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
4010 -- Is_Power_Of_2_For_Shift is set means that we know that our left
4011 -- operand is an unsigned integer, as required for this to work.
4016 -- We cannot do this transformation in configurable run time mode if we
4017 -- have 64-bit -- integers and long shifts are not available.
4019 and then
4022 then
4026 Right_Opnd =>
4032 -- Do required fixup of universal fixed operation
4039 -- Divisions with fixed-point results
4043 -- No special processing if Treat_Fixed_As_Integer is set,
4044 -- since from a semantic point of view such operations are
4045 -- simply integer operations and will be treated that way.
4050 else
4055 -- Other cases of division of fixed-point operands. Again we
4056 -- exclude the case where Treat_Fixed_As_Integer is set.
4061 then
4064 else
4069 -- Mixed-mode operations can appear in a non-static universal
4070 -- context, in which case the integer argument must be converted
4071 -- explicitly.
4075 then
4083 then
4089 -- Non-fixed point cases, do integer zero divide and overflow checks
4094 -- Check for 64-bit division available, or long shifts if the divisor
4095 -- is a small power of 2 (since such divides will be converted into
4096 -- long shifts.
4099 and then not Support_64_Bit_Divides_On_Target
4100 and then
4102 or else not Support_Long_Shifts_On_Target
4109 then
4113 -- Deal with Vax_Float
4121 --------------------
4122 -- Expand_N_Op_Eq --
4123 --------------------
4138 -- If a constructed equality exists for the type or for its parent,
4139 -- build and analyze call, adding conversions if the operation is
4140 -- inherited.
4143 -- Determines whether a type has a subcompoment of an unconstrained
4144 -- Unchecked_Union subtype. Typ is a record type.
4146 -------------------------
4147 -- Build_Equality_Call --
4148 -------------------------
4155 begin
4158 then
4163 -- If we have an Unchecked_Union, we need to add the inferred
4164 -- discriminant values as actuals in the function call. At this
4165 -- point, the expansion has determined that both operands have
4166 -- inferable discriminants.
4169 declare
4175 begin
4176 -- Per-object constrained selected components require special
4177 -- attention. If the enclosing scope of the component is an
4178 -- Unchecked_Union, we cannot reference its discriminants
4179 -- directly. This is why we use the two extra parameters of
4180 -- the equality function of the enclosing Unchecked_Union.
4182 -- type UU_Type (Discr : Integer := 0) is
4183 -- . . .
4184 -- end record;
4185 -- pragma Unchecked_Union (UU_Type);
4187 -- 1. Unchecked_Union enclosing record:
4189 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
4190 -- . . .
4191 -- Comp : UU_Type (Discr);
4192 -- . . .
4193 -- end Enclosing_UU_Type;
4194 -- pragma Unchecked_Union (Enclosing_UU_Type);
4196 -- Obj1 : Enclosing_UU_Type;
4197 -- Obj2 : Enclosing_UU_Type (1);
4199 -- [. . .] Obj1 = Obj2 [. . .]
4201 -- Generated code:
4203 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4205 -- A and B are the formal parameters of the equality function
4206 -- of Enclosing_UU_Type. The function always has two extra
4207 -- formals to capture the inferred discriminant values.
4209 -- 2. Non-Unchecked_Union enclosing record:
4211 -- type
4212 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
4213 -- is record
4214 -- . . .
4215 -- Comp : UU_Type (Discr);
4216 -- . . .
4217 -- end Enclosing_Non_UU_Type;
4219 -- Obj1 : Enclosing_Non_UU_Type;
4220 -- Obj2 : Enclosing_Non_UU_Type (1);
4222 -- ... Obj1 = Obj2 ...
4224 -- Generated code:
4226 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
4227 -- obj1.discr, obj2.discr)) then
4229 -- In this case we can directly reference the discriminants of
4230 -- the enclosing record.
4232 -- Lhs of equality
4235 and then Has_Per_Object_Constraint
4237 then
4238 -- Enclosing record is an Unchecked_Union, use formal A
4242 then
4243 Lhs_Discr_Val :=
4247 -- Enclosing record is of a non-Unchecked_Union type, it is
4248 -- possible to reference the discriminant.
4250 else
4251 Lhs_Discr_Val :=
4254 Selector_Name =>
4255 New_Copy
4256 (Get_Discriminant_Value
4258 Lhs_Type,
4262 -- Comment needed here ???
4264 else
4265 -- Infer the discriminant value
4267 Lhs_Discr_Val :=
4268 New_Copy
4269 (Get_Discriminant_Value
4271 Lhs_Type,
4275 -- Rhs of equality
4278 and then Has_Per_Object_Constraint
4280 then
4281 if Is_Unchecked_Union
4283 then
4284 Rhs_Discr_Val :=
4288 else
4289 Rhs_Discr_Val :=
4292 Selector_Name =>
4295 Rhs_Type,
4299 else
4300 Rhs_Discr_Val :=
4303 Rhs_Type,
4312 L_Exp,
4313 R_Exp,
4314 Lhs_Discr_Val,
4315 Rhs_Discr_Val)));
4318 -- Normal case, not an unchecked union
4320 else
4330 ------------------------------------
4331 -- Has_Unconstrained_UU_Component --
4332 ------------------------------------
4334 function Has_Unconstrained_UU_Component
4336 is
4342 function Component_Is_Unconstrained_UU
4344 -- Determines whether the subtype of the component is an
4345 -- unconstrained Unchecked_Union.
4347 function Variant_Is_Unconstrained_UU
4349 -- Determines whether a component of the variant has an unconstrained
4350 -- Unchecked_Union subtype.
4352 -----------------------------------
4353 -- Component_Is_Unconstrained_UU --
4354 -----------------------------------
4356 function Component_Is_Unconstrained_UU
4358 is
4359 begin
4364 declare
4368 begin
4369 -- Unconstrained nominal type. In the case of a constraint
4370 -- present, the node kind would have been N_Subtype_Indication.
4380 ---------------------------------
4381 -- Variant_Is_Unconstrained_UU --
4382 ---------------------------------
4384 function Variant_Is_Unconstrained_UU
4386 is
4389 begin
4394 -- We only need to test one component
4396 declare
4399 begin
4409 -- None of the components withing the variant were of
4410 -- unconstrained Unchecked_Union type.
4415 -- Start of processing for Has_Unconstrained_UU_Component
4417 begin
4425 -- Inspect available components
4428 declare
4431 begin
4434 -- One component is sufficent
4445 -- Inspect available components withing variants
4448 declare
4451 begin
4454 -- One component within a variant is sufficent
4465 -- Neither the available components, nor the components inside the
4466 -- variant parts were of an unconstrained Unchecked_Union subtype.
4471 -- Start of processing for Expand_N_Op_Eq
4473 begin
4480 else
4484 -- It may happen in error situations that the underlying type is not
4485 -- set. The error will be detected later, here we just defend the
4486 -- expander code.
4494 -- Boolean types (requiring handling of non-standard case)
4502 -- Array types
4506 -- If we are doing full validity checking, then expand out array
4507 -- comparisons to make sure that we check the array elements.
4510 declare
4512 Force_Validity_Checks;
4513 begin
4516 Expand_Array_Equality
4520 Bodies,
4521 Typl));
4527 -- Packed case where both operands are known aligned
4532 then
4535 -- Where the component type is elementary we can use a block bit
4536 -- comparison (if supported on the target) exception in the case
4537 -- of floating-point (negative zero issues require element by
4538 -- element comparison), and atomic types (where we must be sure
4539 -- to load elements independently) and possibly unaligned arrays.
4546 and then Support_Composite_Compare_On_Target
4547 then
4550 -- For composite and floating-point cases, expand equality loop
4551 -- to make sure of using proper comparisons for tagged types,
4552 -- and correctly handling the floating-point case.
4554 else
4556 Expand_Array_Equality
4560 Bodies,
4561 Typl));
4566 -- Record Types
4570 -- For tagged types, use the primitive "="
4574 -- If this is derived from an untagged private type completed
4575 -- with a tagged type, it does not have a full view, so we
4576 -- use the primitive operations of the private type.
4577 -- This check should no longer be necessary when these
4578 -- types receive their full views ???
4584 then
4585 -- Search for equality operation, checking that the
4586 -- operands have the same type. Note that we must find
4587 -- a matching entry, or something is very wrong!
4595 and then
4604 -- Find the type's predefined equality or an overriding
4605 -- user-defined equality. The reason for not simply calling
4606 -- Find_Prim_Op here is that there may be a user-defined
4607 -- overloaded equality op that precedes the equality that
4608 -- we want, so we have to explicitly search (e.g., there
4609 -- could be an equality with two different parameter types).
4611 else
4621 and then
4633 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
4634 -- predefined equality operator for a type which has a subcomponent
4635 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
4642 -- Prevent Gigi from generating incorrect code by rewriting the
4643 -- equality as a standard False.
4650 -- If we can infer the discriminants of the operands, we make a
4651 -- call to the TSS equality function.
4654 and then
4656 then
4657 Build_Equality_Call
4660 else
4661 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4662 -- the predefined equality operator for an Unchecked_Union type
4663 -- if either of the operands lack inferable discriminants.
4669 -- Prevent Gigi from generating incorrect code by rewriting
4670 -- the equality as a standard False.
4677 -- If a type support function is present (for complex cases), use it
4680 Build_Equality_Call
4683 -- Otherwise expand the component by component equality. Note that
4684 -- we never use block-bit coparisons for records, because of the
4685 -- problems with gaps. The backend will often be able to recombine
4686 -- the separate comparisons that we generate here.
4688 else
4699 -- Test if result is known at compile time
4703 -- If we still have comparison for Vax_Float, process it
4711 -----------------------
4712 -- Expand_N_Op_Expon --
4713 -----------------------
4731 begin
4734 -- If either operand is of a private type, then we have the use of
4735 -- an intrinsic operator, and we get rid of the privateness, by using
4736 -- root types of underlying types for the actual operation. Otherwise
4737 -- the private types will cause trouble if we expand multiplications
4738 -- or shifts etc. We also do this transformation if the result type
4739 -- is different from the base type.
4742 or else
4744 or else
4746 or else
4748 then
4749 declare
4753 begin
4764 -- Test for case of known right argument
4769 -- We only fold small non-negative exponents. You might think we
4770 -- could fold small negative exponents for the real case, but we
4771 -- can't because we are required to raise Constraint_Error for
4772 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
4773 -- See ACVC test C4A012B.
4777 -- X ** 0 = 1 (or 1.0)
4782 else
4786 -- X ** 1 = X
4791 -- X ** 2 = X * X
4794 Xnode :=
4799 -- X ** 3 = X * X * X
4802 Xnode :=
4804 Left_Opnd =>
4810 -- X ** 4 ->
4811 -- En : constant base'type := base * base;
4812 -- ...
4813 -- En * En
4816 Temp :=
4824 Expression =>
4829 Xnode :=
4841 -- Case of (2 ** expression) appearing as an argument of an integer
4842 -- multiplication, or as the right argument of a division of a non-
4843 -- negative integer. In such cases we leave the node untouched, setting
4844 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
4845 -- of the higher level node converts it into a shift.
4852 and then not Ovflo
4854 then
4855 declare
4860 begin
4862 and then
4864 or else
4868 or else
4874 then
4881 -- Fall through if exponentiation must be done using a runtime routine
4883 -- First deal with modular case
4887 -- Non-binary case, we call the special exponentiation routine for
4888 -- the non-binary case, converting the argument to Long_Long_Integer
4889 -- and passing the modulus value. Then the result is converted back
4890 -- to the base type.
4900 Exp))));
4902 -- Binary case, in this case, we call one of two routines, either
4903 -- the unsigned integer case, or the unsigned long long integer
4904 -- case, with a final "and" operation to do the required mod.
4906 else
4909 else
4916 Left_Opnd =>
4921 Exp)),
4922 Right_Opnd =>
4927 -- Common exit point for modular type case
4932 -- Signed integer cases, done using either Integer or Long_Long_Integer.
4933 -- It is not worth having routines for Short_[Short_]Integer, since for
4934 -- most machines it would not help, and it would generate more code that
4935 -- might need certification when a certified run time is required.
4937 -- In the integer cases, we have two routines, one for when overflow
4938 -- checks are required, and one when they are not required, since there
4939 -- is a real gain in omitting checks on many machines.
4943 and then
4946 then
4951 else
4960 else
4964 -- Floating-point cases, always done using Long_Long_Float. We do not
4965 -- need separate routines for the overflow case here, since in the case
4966 -- of floating-point, we generate infinities anyway as a rule (either
4967 -- that or we automatically trap overflow), and if there is an infinity
4968 -- generated and a range check is required, the check will fail anyway.
4970 else
4976 -- Common processing for integer cases and floating-point cases.
4977 -- If we are in the right type, we can call runtime routine directly
4982 then
4988 -- Otherwise we have to introduce conversions (conversions are also
4989 -- required in the universal cases, since the runtime routine is
4990 -- typed using one of the standard types.
4992 else
4999 Exp))));
5005 exception
5010 --------------------
5011 -- Expand_N_Op_Ge --
5012 --------------------
5020 begin
5037 -- If we still have comparison, and Vax_Float type, process it
5045 --------------------
5046 -- Expand_N_Op_Gt --
5047 --------------------
5055 begin
5072 -- If we still have comparison, and Vax_Float type, process it
5080 --------------------
5081 -- Expand_N_Op_Le --
5082 --------------------
5090 begin
5107 -- If we still have comparison, and Vax_Float type, process it
5115 --------------------
5116 -- Expand_N_Op_Lt --
5117 --------------------
5125 begin
5142 -- If we still have comparison, and Vax_Float type, process it
5150 -----------------------
5151 -- Expand_N_Op_Minus --
5152 -----------------------
5158 begin
5161 if not Backend_Overflow_Checks_On_Target
5164 then
5165 -- Software overflow checking expands -expr into (0 - expr)
5174 -- Vax floating-point types case
5181 ---------------------
5182 -- Expand_N_Op_Mod --
5183 ---------------------
5201 begin
5207 -- Convert mod to rem if operands are known non-negative. We do this
5208 -- since it is quite likely that this will improve the quality of code,
5209 -- (the operation now corresponds to the hardware remainder), and it
5210 -- does not seem likely that it could be harmful.
5213 and then
5215 then
5221 -- Instead of reanalyzing the node we do the analysis manually.
5222 -- This avoids anomalies when the replacement is done in an
5223 -- instance and is epsilon more efficient.
5232 -- Otherwise, normal mod processing
5234 else
5239 -- Apply optimization x mod 1 = 0. We don't really need that with
5240 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5241 -- certainly harmless.
5246 then
5252 -- Deal with annoying case of largest negative number remainder
5253 -- minus one. Gigi does not handle this case correctly, because
5254 -- it generates a divide instruction which may trap in this case.
5256 -- In fact the check is quite easy, if the right operand is -1,
5257 -- then the mod value is always 0, and we can just ignore the
5258 -- left operand completely in this case.
5260 -- The operand type may be private (e.g. in the expansion of an
5261 -- an intrinsic operation) so we must use the underlying type to
5262 -- get the bounds, and convert the literals explicitly.
5264 LLB :=
5265 Expr_Value
5269 and then
5271 then
5277 Right_Opnd =>
5290 --------------------------
5291 -- Expand_N_Op_Multiply --
5292 --------------------------
5311 begin
5314 -- Special optimizations for integer types
5318 -- N * 0 = 0 * N = 0 for integer types
5322 or else
5325 then
5331 -- N * 1 = 1 * N = N for integer types
5333 -- This optimisation is not done if we are going to
5334 -- rewrite the product 1 * 2 ** N to a shift.
5338 and then not Lp2
5339 then
5345 and then not Rp2
5346 then
5352 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5353 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5354 -- operand is an integer, as required for this to work.
5359 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
5364 Right_Opnd =>
5371 else
5375 Right_Opnd =>
5381 -- Same processing for the operands the other way round
5387 Right_Opnd =>
5393 -- Do required fixup of universal fixed operation
5400 -- Multiplications with fixed-point results
5404 -- No special processing if Treat_Fixed_As_Integer is set,
5405 -- since from a semantic point of view such operations are
5406 -- simply integer operations and will be treated that way.
5410 -- Case of fixed * integer => fixed
5415 -- Case of integer * fixed => fixed
5420 -- Case of fixed * fixed => fixed
5422 else
5427 -- Other cases of multiplication of fixed-point operands. Again
5428 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
5432 then
5435 else
5440 -- Mixed-mode operations can appear in a non-static universal
5441 -- context, in which case the integer argument must be converted
5442 -- explicitly.
5446 then
5453 then
5458 -- Non-fixed point cases, check software overflow checking required
5463 -- Deal with VAX float case
5471 --------------------
5472 -- Expand_N_Op_Ne --
5473 --------------------
5478 begin
5479 -- Case of elementary type with standard operator
5483 then
5486 -- Boolean types (requiring handling of non-standard case)
5497 -- If we still have comparison for Vax_Float, process it
5504 -- For all cases other than elementary types, we rewrite node as the
5505 -- negation of an equality operation, and reanalyze. The equality to be
5506 -- used is defined in the same scope and has the same signature. This
5507 -- signature must be set explicitly since in an instance it may not have
5508 -- the same visibility as in the generic unit. This avoids duplicating
5509 -- or factoring the complex code for record/array equality tests etc.
5511 else
5512 declare
5517 begin
5520 Neg :=
5522 Right_Opnd =>
5532 -- For navigation purposes, the inequality is treated as an
5533 -- implicit reference to the corresponding equality. Preserve the
5534 -- Comes_From_ source flag so that the proper Xref entry is
5535 -- generated.
5545 ---------------------
5546 -- Expand_N_Op_Not --
5547 ---------------------
5549 -- If the argument is other than a Boolean array type, there is no
5550 -- special expansion required.
5552 -- For the packed case, we call the special routine in Exp_Pakd, except
5553 -- that if the component size is greater than one, we use the standard
5554 -- routine generating a gruesome loop (it is so peculiar to have packed
5555 -- arrays with non-standard Boolean representations anyway, so it does
5556 -- not matter that we do not handle this case efficiently).
5558 -- For the unpacked case (and for the special packed case where we have
5559 -- non standard Booleans, as discussed above), we generate and insert
5560 -- into the tree the following function definition:
5562 -- function Nnnn (A : arr) is
5563 -- B : arr;
5564 -- begin
5565 -- for J in a'range loop
5566 -- B (J) := not A (J);
5567 -- end loop;
5568 -- return B;
5569 -- end Nnnn;
5571 -- Here arr is the actual subtype of the parameter (and hence always
5572 -- constrained). Then we replace the not with a call to this function.
5588 begin
5591 -- For boolean operand, deal with non-standard booleans
5600 -- Only array types need any other processing
5606 -- Case of array operand. If bit packed with a component size of 1,
5607 -- handle it in Exp_Pakd if the operand is known to be aligned.
5612 then
5617 -- Case of array operand which is not bit-packed. If the context is
5618 -- a safe assignment, call in-place operation, If context is a larger
5619 -- boolean expression in the context of a safe assignment, expansion is
5620 -- done by enclosing operation.
5632 -- Special case the negation of a binary operation
5637 and then Safe_In_Place_Array_Op
5639 then
5646 then
5647 declare
5652 begin
5656 then
5657 -- (not A) op (not B) can be reduced to a single call
5663 then
5664 -- A xor (not B) can also be special-cased
5676 A_J :=
5681 B_J :=
5686 Loop_Statement :=
5690 Iteration_Scheme =>
5692 Loop_Parameter_Specification =>
5695 Discrete_Subtype_Definition =>
5710 Specification =>
5724 Handled_Statement_Sequence =>
5727 Loop_Statement,
5729 Expression =>
5740 --------------------
5741 -- Expand_N_Op_Or --
5742 --------------------
5747 begin
5761 ----------------------
5762 -- Expand_N_Op_Plus --
5763 ----------------------
5766 begin
5770 ---------------------
5771 -- Expand_N_Op_Rem --
5772 ---------------------
5789 begin
5796 -- Apply optimization x rem 1 = 0. We don't really need that with
5797 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5798 -- certainly harmless.
5803 then
5809 -- Deal with annoying case of largest negative number remainder
5810 -- minus one. Gigi does not handle this case correctly, because
5811 -- it generates a divide instruction which may trap in this case.
5813 -- In fact the check is quite easy, if the right operand is -1,
5814 -- then the remainder is always 0, and we can just ignore the
5815 -- left operand completely in this case.
5820 -- The operand type may be private (e.g. in the expansion of an
5821 -- an intrinsic operation) so we must use the underlying type to
5822 -- get the bounds, and convert the literals explicitly.
5824 LLB :=
5825 Expr_Value
5828 -- Now perform the test, generating code only if needed
5831 and then
5833 then
5839 Right_Opnd =>
5853 -----------------------------
5854 -- Expand_N_Op_Rotate_Left --
5855 -----------------------------
5858 begin
5862 ------------------------------
5863 -- Expand_N_Op_Rotate_Right --
5864 ------------------------------
5867 begin
5871 ----------------------------
5872 -- Expand_N_Op_Shift_Left --
5873 ----------------------------
5876 begin
5880 -----------------------------
5881 -- Expand_N_Op_Shift_Right --
5882 -----------------------------
5885 begin
5889 ----------------------------------------
5890 -- Expand_N_Op_Shift_Right_Arithmetic --
5891 ----------------------------------------
5894 begin
5898 --------------------------
5899 -- Expand_N_Op_Subtract --
5900 --------------------------
5905 begin
5908 -- N - 0 = N for integer types
5913 then
5918 -- Arithemtic overflow checks for signed integer/fixed point types
5922 then
5925 -- Vax floating-point types case
5932 ---------------------
5933 -- Expand_N_Op_Xor --
5934 ---------------------
5939 begin
5953 ----------------------
5954 -- Expand_N_Or_Else --
5955 ----------------------
5957 -- Expand into conditional expression if Actions present, and also
5958 -- deal with optimizing case of arguments being True or False.
5967 begin
5968 -- Deal with non-standard booleans
5976 -- Check for cases of left argument is True or False
5980 -- If left argument is False, change (False or else Right) to Right.
5981 -- Any actions associated with Right will be executed unconditionally
5982 -- and can thus be inserted into the tree unconditionally.
5993 -- If left argument is True, change (True and then Right) to
5994 -- True. In this case we can forget the actions associated with
5995 -- Right, since they will never be executed.
6006 -- If Actions are present, we expand
6008 -- left or else right
6010 -- into
6012 -- if left then True else right end
6014 -- with the actions becoming the Else_Actions of the conditional
6015 -- expression. This conditional expression is then further expanded
6016 -- (and will eventually disappear)
6023 Left,
6025 Right)));
6033 -- No actions present, check for cases of right argument True/False
6037 -- Change (Left or else False) to Left. Note that we know there
6038 -- are no actions associated with the True operand, since we
6039 -- just checked for this case above.
6044 -- Change (Left or else True) to True, making sure to preserve
6045 -- any side effects associated with the Left operand.
6049 Rewrite
6057 -----------------------------------
6058 -- Expand_N_Qualified_Expression --
6059 -----------------------------------
6065 begin
6066 -- Do validity check if validity checking operands
6068 if Validity_Checks_On
6069 and then Validity_Check_Operands
6070 then
6074 -- Apply possible constraint check
6079 ---------------------------------
6080 -- Expand_N_Selected_Component --
6081 ---------------------------------
6083 -- If the selector is a discriminant of a concurrent object, rewrite the
6084 -- prefix to denote the corresponding record type.
6096 -- Gigi needs a temporary for prefixes that depend on a discriminant,
6097 -- unless the context of an assignment can provide size information.
6098 -- Don't we have a general routine that does this???
6100 -----------------------
6101 -- In_Left_Hand_Side --
6102 -----------------------
6105 begin
6113 -- Start of processing for Expand_N_Selected_Component
6115 begin
6116 -- Insert explicit dereference if required
6124 then
6131 -- Deal with discriminant check required
6135 -- Present the discrminant checking function to the backend,
6136 -- so that it can inline the call to the function.
6138 Add_Inlined_Body
6139 (Discriminant_Checking_Func
6142 -- Now reset the flag and generate the call
6148 -- Gigi cannot handle unchecked conversions that are the prefix of a
6149 -- selected component with discriminants. This must be checked during
6150 -- expansion, because during analysis the type of the selector is not
6151 -- known at the point the prefix is analyzed. If the conversion is the
6152 -- target of an assignment, then we cannot force the evaluation.
6157 then
6161 -- Remaining processing applies only if selector is a discriminant
6165 -- If the selector is a discriminant of a constrained record type,
6166 -- we may be able to rewrite the expression with the actual value
6167 -- of the discriminant, a useful optimization in some cases.
6172 then
6173 -- Do this optimization for discrete types only, and not for
6174 -- access types (access discriminants get us into trouble!)
6179 -- Don't do this on the left hand of an assignment statement.
6180 -- Normally one would think that references like this would
6181 -- not occur, but they do in generated code, and mean that
6182 -- we really do want to assign the discriminant!
6186 then
6189 -- Don't do this optimization for the prefix of an attribute
6190 -- or the operand of an object renaming declaration since these
6191 -- are contexts where we do not want the value anyway.
6196 then
6199 -- Don't do this optimization if we are within the code for a
6200 -- discriminant check, since the whole point of such a check may
6201 -- be to verify the condition on which the code below depends!
6206 -- Green light to see if we can do the optimization. There is
6207 -- still one condition that inhibits the optimization below
6208 -- but now is the time to check the particular discriminant.
6210 else
6211 -- Loop through discriminants to find the matching
6212 -- discriminant constraint to see if we can copy it.
6218 -- Check if this is the matching discriminant
6222 -- Here we have the matching discriminant. Check for
6223 -- the case of a discriminant of a component that is
6224 -- constrained by an outer discriminant, which cannot
6225 -- be optimized away.
6227 if
6228 Denotes_Discriminant
6230 then
6233 -- In the context of a case statement, the expression
6234 -- may have the base type of the discriminant, and we
6235 -- need to preserve the constraint to avoid spurious
6236 -- errors on missing cases.
6240 then
6243 Subtype_Mark =>
6245 Expression =>
6249 -- In case that comes out as a static expression,
6250 -- reset it (a selected component is never static).
6255 -- Otherwise we can just copy the constraint, but the
6256 -- result is certainly not static! In some cases the
6257 -- discriminant constraint has been analyzed in the
6258 -- context of the original subtype indication, but for
6259 -- itypes the constraint might not have been analyzed
6260 -- yet, and this must be done now.
6262 else
6274 -- Note: the above loop should always find a matching
6275 -- discriminant, but if it does not, we just missed an
6276 -- optimization due to some glitch (perhaps a previous
6277 -- error), so ignore.
6282 -- The only remaining processing is in the case of a discriminant of
6283 -- a concurrent object, where we rewrite the prefix to denote the
6284 -- corresponding record type. If the type is derived and has renamed
6285 -- discriminants, use corresponding discriminant, which is the one
6286 -- that appears in the corresponding record.
6296 then
6300 New_N :=
6302 Prefix =>
6312 --------------------
6313 -- Expand_N_Slice --
6314 --------------------
6323 -- Check whether the argument is an actual for a procedure call,
6324 -- in which case the expansion of a bit-packed slice is deferred
6325 -- until the call itself is expanded. The reason this is required
6326 -- is that we might have an IN OUT or OUT parameter, and the copy out
6327 -- is essential, and that copy out would be missed if we created a
6328 -- temporary here in Expand_N_Slice. Note that we don't bother
6329 -- to test specifically for an IN OUT or OUT mode parameter, since it
6330 -- is a bit tricky to do, and it is harmless to defer expansion
6331 -- in the IN case, since the call processing will still generate the
6332 -- appropriate copy in operation, which will take care of the slice.
6335 -- Create a named variable for the value of the slice, in
6336 -- cases where the back-end cannot handle it properly, e.g.
6337 -- when packed types or unaligned slices are involved.
6339 -------------------------
6340 -- Is_Procedure_Actual --
6341 -------------------------
6346 begin
6347 loop
6348 -- If our parent is a procedure call we can return
6353 -- If our parent is a type conversion, keep climbing the
6354 -- tree, since a type conversion can be a procedure actual.
6355 -- Also keep climbing if parameter association or a qualified
6356 -- expression, since these are additional cases that do can
6357 -- appear on procedure actuals.
6362 then
6365 -- Any other case is not what we are looking for
6367 else
6373 --------------------
6374 -- Make_Temporary --
6375 --------------------
6381 begin
6382 Decl :=
6390 Decl,
6399 -- Start of processing for Expand_N_Slice
6401 begin
6402 -- Special handling for access types
6415 -- Range checks are potentially also needed for cases involving
6416 -- a slice indexed by a subtype indication, but Do_Range_Check
6417 -- can currently only be set for expressions ???
6423 then
6427 -- The remaining case to be handled is packed slices. We can leave
6428 -- packed slices as they are in the following situations:
6430 -- 1. Right or left side of an assignment (we can handle this
6431 -- situation correctly in the assignment statement expansion).
6433 -- 2. Prefix of indexed component (the slide is optimized away
6434 -- in this case, see the start of Expand_N_Slice.
6436 -- 3. Object renaming declaration, since we want the name of
6437 -- the slice, not the value.
6439 -- 4. Argument to procedure call, since copy-in/copy-out handling
6440 -- may be required, and this is handled in the expansion of
6441 -- call itself.
6443 -- 5. Prefix of an address attribute (this is an error which
6444 -- is caught elsewhere, and the expansion would intefere
6445 -- with generating the error message).
6449 -- Apply transformation for actuals of a function call,
6450 -- where Expand_Actuals is not used.
6454 then
6455 Make_Temporary;
6461 then
6467 then
6472 then
6475 else
6476 Make_Temporary;
6480 ------------------------------
6481 -- Expand_N_Type_Conversion --
6482 ------------------------------
6491 -- This is called in the case of record and array type conversions
6492 -- to see if there is a change of representation to be handled.
6493 -- Change of representation is actually handled at the assignment
6494 -- statement level, and what this procedure does is rewrite node N
6495 -- conversion as an assignment to temporary. If there is no change
6496 -- of representation, then the conversion node is unchanged.
6499 -- Handles generation of range check for real target value
6501 -----------------------------------
6502 -- Handle_Changed_Representation --
6503 -----------------------------------
6513 begin
6514 -- Nothing else to do if no change of representation
6519 -- The real change of representation work is done by the assignment
6520 -- statement processing. So if this type conversion is appearing as
6521 -- the expression of an assignment statement, nothing needs to be
6522 -- done to the conversion.
6527 -- Otherwise we need to generate a temporary variable, and do the
6528 -- change of representation assignment into that temporary variable.
6529 -- The conversion is then replaced by a reference to this variable.
6531 else
6534 -- If type is unconstrained we have to add a constraint,
6535 -- copied from the actual value of the left hand side.
6550 Selector_Name =>
6561 -- We convert the bounds explicitly. We use an unchecked
6562 -- conversion because bounds checks are done elsewhere.
6566 Low_Bound =>
6569 Prefix =>
6570 Duplicate_Subexpr_No_Checks
6576 High_Bound =>
6579 Prefix =>
6580 Duplicate_Subexpr_No_Checks
6594 Odef :=
6597 Constraint =>
6603 Decl :=
6610 -- Insert required actions. It is essential to suppress checks
6611 -- since we have suppressed default initialization, which means
6612 -- that the variable we create may have no discriminants.
6615 New_List (
6616 Decl,
6627 ----------------------
6628 -- Real_Range_Check --
6629 ----------------------
6631 -- Case of conversions to floating-point or fixed-point. If range
6632 -- checks are enabled and the target type has a range constraint,
6633 -- we convert:
6635 -- typ (x)
6637 -- to
6639 -- Tnn : typ'Base := typ'Base (x);
6640 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
6641 -- Tnn
6643 -- This is necessary when there is a conversion of integer to float
6644 -- or to fixed-point to ensure that the correct checks are made. It
6645 -- is not necessary for float to float where it is enough to simply
6646 -- set the Do_Range_Check flag.
6656 begin
6657 -- Nothing to do if conversion was rewritten
6663 -- Nothing to do if range checks suppressed, or target has the
6664 -- same range as the base type (or is the base type).
6668 and then
6670 then
6674 -- Nothing to do if expression is an entity on which checks
6675 -- have been suppressed.
6679 then
6683 -- Nothing to do if bounds are all static and we can tell that
6684 -- the expression is within the bounds of the target. Note that
6685 -- if the operand is of an unconstrained floating-point type,
6686 -- then we do not trust it to be in range (might be infinite)
6688 declare
6692 begin
6699 then
6700 declare
6706 begin
6710 else
6718 then
6726 -- For float to float conversions, we are done
6729 and then
6731 then
6735 -- Otherwise rewrite the conversion as described above
6738 Rewrite
6742 -- Enable overflow except for case of integer to float conversions,
6743 -- where it is never required, since we can never have overflow in
6744 -- this case.
6750 Tnn :=
6761 Condition =>
6763 Left_Opnd =>
6766 Right_Opnd =>
6769 Prefix =>
6772 Right_Opnd =>
6775 Right_Opnd =>
6778 Prefix =>
6786 -- Start of processing for Expand_N_Type_Conversion
6788 begin
6789 -- Nothing at all to do if conversion is to the identical type
6790 -- so remove the conversion completely, it is useless.
6797 -- Nothing to do if this is the second argument of read. This
6798 -- is a "backwards" conversion that will be handled by the
6799 -- specialized code in attribute processing.
6804 then
6808 -- Here if we may need to expand conversion
6810 -- Do validity check if validity checking operands
6812 if Validity_Checks_On
6813 and then Validity_Check_Operands
6814 then
6818 -- Special case of converting from non-standard boolean type
6822 then
6828 -- Case of converting to an access type
6832 -- Apply an accessibility check if the operand is an
6833 -- access parameter. Note that other checks may still
6834 -- need to be applied below (such as tagged type checks).
6839 then
6842 -- If the level of the operand type is statically deeper
6843 -- then the level of the target type, then force Program_Error.
6844 -- Note that this can only occur for cases where the attribute
6845 -- is within the body of an instantiation (otherwise the
6846 -- conversion will already have been rejected as illegal).
6847 -- Note: warnings are issued by the analyzer for the instance
6848 -- cases.
6850 elsif In_Instance_Body
6853 then
6859 -- When the operand is a selected access discriminant
6860 -- the check needs to be made against the level of the
6861 -- object denoted by the prefix of the selected name.
6862 -- Force Program_Error for this case as well (this
6863 -- accessibility violation can only happen if within
6864 -- the body of an instantiation).
6866 elsif In_Instance_Body
6871 then
6879 -- Case of conversions of tagged types and access to tagged types
6881 -- When needed, that is to say when the expression is class-wide,
6882 -- Add runtime a tag check for (strict) downward conversion by using
6883 -- the membership test, generating:
6885 -- [constraint_error when Operand not in Target_Type'Class]
6887 -- or in the access type case
6889 -- [constraint_error
6890 -- when Operand /= null
6891 -- and then Operand.all not in
6892 -- Designated_Type (Target_Type)'Class]
6897 then
6898 -- Do not do any expansion in the access type case if the
6899 -- parent is a renaming, since this is an error situation
6900 -- which will be caught by Sem_Ch8, and the expansion can
6901 -- intefere with this error check.
6905 then
6909 -- Oherwise, proceed with processing tagged conversion
6911 declare
6917 begin
6922 else
6927 -- Ada 2005 (AI-251): Handle interface type conversion
6936 and then Is_Ancestor
6938 Actual_Target_Type)
6940 then
6941 -- The conversion is valid for any descendant of the
6942 -- target type
6947 Cond :=
6949 Left_Opnd =>
6954 Right_Opnd =>
6956 Left_Opnd =>
6958 Prefix =>
6960 Right_Opnd =>
6963 else
6964 Cond :=
6967 Right_Opnd =>
6976 declare
6978 begin
6979 Conv :=
6989 -- Case of other access type conversions
6994 -- Case of conversions from a fixed-point type
6996 -- These conversions require special expansion and processing, found
6997 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
6998 -- set, since from a semantic point of view, these are simple integer
6999 -- conversions, which do not need further processing.
7003 then
7004 -- We should never see universal fixed at this case, since the
7005 -- expansion of the constituent divide or multiply should have
7006 -- eliminated the explicit mention of universal fixed.
7010 -- Check for special case of the conversion to universal real
7011 -- that occurs as a result of the use of a round attribute.
7012 -- In this case, the real type for the conversion is taken
7013 -- from the target type of the Round attribute and the
7014 -- result must be marked as rounded.
7019 then
7024 -- Otherwise do correct fixed-conversion, but skip these if the
7025 -- Conversion_OK flag is set, because from a semantic point of
7026 -- view these are simple integer conversions needing no further
7027 -- processing (the backend will simply treat them as integers)
7032 Real_Range_Check;
7037 else
7040 Real_Range_Check;
7044 -- Case of conversions to a fixed-point type
7046 -- These conversions require special expansion and processing, found
7047 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
7048 -- is set, since from a semantic point of view, these are simple
7049 -- integer conversions, which do not need further processing.
7053 then
7056 Real_Range_Check;
7057 else
7060 Real_Range_Check;
7063 -- Case of float-to-integer conversions
7065 -- We also handle float-to-fixed conversions with Conversion_OK set
7066 -- since semantically the fixed-point target is treated as though it
7067 -- were an integer in such cases.
7070 and then
7072 or else
7074 then
7075 -- Special processing required if the conversion is the expression
7076 -- of a Truncation attribute reference. In this case we replace:
7078 -- ityp (ftyp'Truncation (x))
7080 -- by
7082 -- ityp (x)
7084 -- with the Float_Truncate flag set. This is clearly more efficient
7088 then
7094 -- One more check here, gcc is still not able to do conversions of
7095 -- this type with proper overflow checking, and so gigi is doing an
7096 -- approximation of what is required by doing floating-point compares
7097 -- with the end-point. But that can lose precision in some cases, and
7098 -- give a wrong result. Converting the operand to Universal_Real is
7099 -- helpful, but still does not catch all cases with 64-bit integers
7100 -- on targets with only 64-bit floats ???
7105 Subtype_Mark =>
7107 Expression =>
7115 -- Case of array conversions
7117 -- Expansion of array conversions, add required length/range checks
7118 -- but only do this if there is no change of representation. For
7119 -- handling of this case, see Handle_Changed_Representation.
7125 else
7129 Handle_Changed_Representation;
7131 -- Case of conversions of discriminated types
7133 -- Add required discriminant checks if target is constrained. Again
7134 -- this change is skipped if we have a change of representation.
7138 then
7140 Handle_Changed_Representation;
7142 -- Case of all other record conversions. The only processing required
7143 -- is to check for a change of representation requiring the special
7144 -- assignment processing.
7148 -- Ada 2005 (AI-216): Program_Error is raised when converting from
7149 -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
7150 -- Union type if the operand lacks inferable discriminants.
7157 then
7158 -- To prevent Gigi from generating illegal code, we make a
7159 -- Program_Error node, but we give it the target type of the
7160 -- conversion.
7162 declare
7166 begin
7171 else
7172 Handle_Changed_Representation;
7175 -- Case of conversions of enumeration types
7179 -- Special processing is required if there is a change of
7180 -- representation (from enumeration representation clauses)
7184 -- Convert: x(y) to x'val (ytyp'val (y))
7199 -- Case of conversions to floating-point
7202 Real_Range_Check;
7205 -- At this stage, either the conversion node has been transformed
7206 -- into some other equivalent expression, or left as a conversion
7207 -- that can be handled by Gigi. The conversions that Gigi can handle
7208 -- are the following:
7210 -- Conversions with no change of representation or type
7212 -- Numeric conversions involving integer values, floating-point
7213 -- values, and fixed-point values. Fixed-point values are allowed
7214 -- only if Conversion_OK is set, i.e. if the fixed-point values
7215 -- are to be treated as integers.
7217 -- No other conversions should be passed to Gigi
7219 -- Check: are these rules stated in sinfo??? if so, why restate here???
7221 -- The only remaining step is to generate a range check if we still
7222 -- have a type conversion at this stage and Do_Range_Check is set.
7223 -- For now we do this only for conversions of discrete types.
7227 then
7228 declare
7233 begin
7236 then
7239 -- Before we do a range check, we have to deal with treating
7240 -- a fixed-point operand as an integer. The way we do this
7241 -- is simply to do an unchecked conversion to an appropriate
7242 -- integer type large enough to hold the result.
7244 -- This code is not active yet, because we are only dealing
7245 -- with discrete types so far ???
7249 then
7254 else
7261 -- Reset overflow flag, since the range check will include
7262 -- dealing with possible overflow, and generate the check
7263 -- If Address is either source or target type, suppress
7264 -- range check to avoid typing anomalies when it is a visible
7265 -- integer type.
7270 then
7271 Generate_Range_Check
7278 -- Final step, if the result is a type conversion involving Vax_Float
7279 -- types, then it is subject for further special processing.
7283 then
7289 -----------------------------------
7290 -- Expand_N_Unchecked_Expression --
7291 -----------------------------------
7293 -- Remove the unchecked expression node from the tree. It's job was simply
7294 -- to make sure that its constituent expression was handled with checks
7295 -- off, and now that that is done, we can remove it from the tree, and
7296 -- indeed must, since gigi does not expect to see these nodes.
7301 begin
7306 ----------------------------------------
7307 -- Expand_N_Unchecked_Type_Conversion --
7308 ----------------------------------------
7310 -- If this cannot be handled by Gigi and we haven't already made
7311 -- a temporary for it, do it now.
7318 begin
7319 -- If we have a conversion of a compile time known value to a target
7320 -- type and the value is in range of the target type, then we can simply
7321 -- replace the construct by an integer literal of the correct type. We
7322 -- only apply this to integer types being converted. Possibly it may
7323 -- apply in other cases, but it is too much trouble to worry about.
7325 -- Note that we do not do this transformation if the Kill_Range_Check
7326 -- flag is set, since then the value may be outside the expected range.
7327 -- This happens in the Normalize_Scalars case.
7329 -- We also skip this if either the target or operand type is biased
7330 -- because in this case, the unchecked conversion is supposed to
7331 -- preserve the bit pattern, not the integer value.
7339 then
7340 declare
7343 begin
7345 and then
7347 and then
7349 and then
7351 then
7354 -- If Address is the target type, just set the type
7355 -- to avoid a spurious type error on the literal when
7356 -- Address is a visible integer type.
7360 else
7369 -- Nothing to do if conversion is safe
7375 -- Otherwise force evaluation unless Assignment_OK flag is set (this
7376 -- flag indicates ??? -- more comments needed here)
7380 else
7385 ----------------------------
7386 -- Expand_Record_Equality --
7387 ----------------------------
7389 -- For non-variant records, Equality is expanded when needed into:
7391 -- and then Lhs.Discr1 = Rhs.Discr1
7392 -- and then ...
7393 -- and then Lhs.Discrn = Rhs.Discrn
7394 -- and then Lhs.Cmp1 = Rhs.Cmp1
7395 -- and then ...
7396 -- and then Lhs.Cmpn = Rhs.Cmpn
7398 -- The expression is folded by the back-end for adjacent fields. This
7399 -- function is called for tagged record in only one occasion: for imple-
7400 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
7401 -- otherwise the primitive "=" is used directly.
7403 function Expand_Record_Equality
7409 is
7418 -- Return the first field to compare beginning with C, skipping the
7419 -- inherited components.
7421 ----------------------
7422 -- Suitable_Element --
7423 ----------------------
7426 begin
7432 then
7437 then
7442 then
7445 else
7450 -- Start of processing for Expand_Record_Equality
7452 begin
7453 -- Generates the following code: (assuming that Typ has one Discr and
7454 -- component C2 is also a record)
7456 -- True
7457 -- and then Lhs.Discr1 = Rhs.Discr1
7458 -- and then Lhs.C1 = Rhs.C1
7459 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
7460 -- and then ...
7461 -- and then Lhs.Cmpn = Rhs.Cmpn
7467 declare
7472 begin
7477 else
7482 Check :=
7484 Lhs =>
7488 Rhs =>
7494 -- If some (sub)component is an unchecked_union, the whole
7495 -- operation will raise program error.
7501 else
7502 Result :=
7515 -------------------------------------
7516 -- Fixup_Universal_Fixed_Operation --
7517 -------------------------------------
7522 begin
7523 -- We must have a type conversion immediately above us
7527 -- Normally the type conversion gives our target type. The exception
7528 -- occurs in the case of the Round attribute, where the conversion
7529 -- will be to universal real, and our real type comes from the Round
7530 -- attribute (as well as an indication that we must round the result)
7534 then
7538 -- Normal case where type comes from conversion above us
7540 else
7545 ------------------------------
7546 -- Get_Allocator_Final_List --
7547 ------------------------------
7549 function Get_Allocator_Final_List
7553 is
7557 -- The entity whose finalisation list must be used to attach the
7558 -- allocated object.
7560 begin
7563 in N_Subprogram_Specification
7564 then
7565 -- If the context is an access parameter, we need to create
7566 -- a non-anonymous access type in order to have a usable
7567 -- final list, because there is otherwise no pool to which
7568 -- the allocated object can belong. We create both the type
7569 -- and the finalization chain here, because freezing an
7570 -- internal type does not create such a chain. The Final_Chain
7571 -- that is thus created is shared by the access parameter.
7577 Type_Definition =>
7579 Subtype_Indication =>
7585 else
7586 -- Case of an access discriminant, or (Ada 2005) of
7587 -- an anonymous access component: find the final list
7588 -- associated with the scope of the type.
7597 ---------------------------------
7598 -- Has_Inferable_Discriminants --
7599 ---------------------------------
7604 -- Determines whether the left-most prefix of a selected component is a
7605 -- formal parameter in a subprogram. Assumes N is a selected component.
7607 --------------------------------
7608 -- Prefix_Is_Formal_Parameter --
7609 --------------------------------
7614 begin
7615 -- Move to the left-most prefix by climbing up the tree
7619 loop
7626 -- Start of processing for Has_Inferable_Discriminants
7628 begin
7629 -- For identifiers and indexed components, it is sufficent to have a
7630 -- constrained Unchecked_Union nominal subtype.
7633 or else
7635 then
7637 and then
7640 -- For selected components, the subtype of the selector must be a
7641 -- constrained Unchecked_Union. If the component is subject to a
7642 -- per-object constraint, then the enclosing object must have inferable
7643 -- discriminants.
7648 -- A small hack. If we have a per-object constrained selected
7649 -- component of a formal parameter, return True since we do not
7650 -- know the actual parameter association yet.
7656 -- Otherwise, check the enclosing object and the selector
7659 and then
7663 -- The call to Has_Inferable_Discriminants will determine whether
7664 -- the selector has a constrained Unchecked_Union nominal type.
7668 -- A qualified expression has inferable discriminants if its subtype
7669 -- mark is a constrained Unchecked_Union subtype.
7673 and then
7681 -------------------------------
7682 -- Insert_Dereference_Action --
7683 -------------------------------
7692 -- Return true if type of P is derived from Checked_Pool;
7694 -----------------------------
7695 -- Is_Checked_Storage_Pool --
7696 -----------------------------
7701 begin
7710 else
7718 -- Start of processing for Insert_Dereference_Action
7720 begin
7725 then
7736 -- Pool
7740 -- Storage_Address. We use the attribute Pool_Address,
7741 -- which uses the pointer itself to find the address of
7742 -- the object, and which handles unconstrained arrays
7743 -- properly by computing the address of the template.
7744 -- i.e. the correct address of the corresponding allocation.
7750 -- Size_In_Storage_Elements
7753 Left_Opnd =>
7755 Prefix =>
7759 Right_Opnd =>
7762 -- Alignment
7765 Prefix =>
7770 exception
7775 ------------------------------
7776 -- Make_Array_Comparison_Op --
7777 ------------------------------
7779 -- This is a hand-coded expansion of the following generic function:
7781 -- generic
7782 -- type elem is (<>);
7783 -- type index is (<>);
7784 -- type a is array (index range <>) of elem;
7786 -- function Gnnn (X : a; Y: a) return boolean is
7787 -- J : index := Y'first;
7789 -- begin
7790 -- if X'length = 0 then
7791 -- return false;
7793 -- elsif Y'length = 0 then
7794 -- return true;
7796 -- else
7797 -- for I in X'range loop
7798 -- if X (I) = Y (J) then
7799 -- if J = Y'last then
7800 -- exit;
7801 -- else
7802 -- J := index'succ (J);
7803 -- end if;
7805 -- else
7806 -- return X (I) > Y (J);
7807 -- end if;
7808 -- end loop;
7810 -- return X'length > Y'length;
7811 -- end if;
7812 -- end Gnnn;
7814 -- Note that since we are essentially doing this expansion by hand, we
7815 -- do not need to generate an actual or formal generic part, just the
7816 -- instantiated function itself.
7818 function Make_Array_Comparison_Op
7821 is
7842 begin
7843 -- if J = Y'last then
7844 -- exit;
7845 -- else
7846 -- J := index'succ (J);
7847 -- end if;
7849 Inner_If :=
7851 Condition =>
7854 Right_Opnd =>
7862 Else_Statements =>
7863 New_List (
7866 Expression =>
7872 -- if X (I) = Y (J) then
7873 -- if ... end if;
7874 -- else
7875 -- return X (I) > Y (J);
7876 -- end if;
7878 Loop_Body :=
7880 Condition =>
7882 Left_Opnd =>
7887 Right_Opnd =>
7896 Expression =>
7898 Left_Opnd =>
7903 Right_Opnd =>
7909 -- for I in X'range loop
7910 -- if ... end if;
7911 -- end loop;
7913 Loop_Statement :=
7917 Iteration_Scheme =>
7919 Loop_Parameter_Specification =>
7922 Discrete_Subtype_Definition =>
7929 -- if X'length = 0 then
7930 -- return false;
7931 -- elsif Y'length = 0 then
7932 -- return true;
7933 -- else
7934 -- for ... loop ... end loop;
7935 -- return X'length > Y'length;
7936 -- end if;
7938 Length1 :=
7943 Length2 :=
7948 Final_Expr :=
7953 If_Stat :=
7955 Condition =>
7957 Left_Opnd =>
7961 Right_Opnd =>
7964 Then_Statements =>
7965 New_List (
7971 Condition =>
7973 Left_Opnd =>
7977 Right_Opnd =>
7980 Then_Statements =>
7981 New_List (
7986 Loop_Statement,
7990 -- (X : a; Y: a)
8001 -- function Gnnn (...) return boolean is
8002 -- J : index := Y'first;
8003 -- begin
8004 -- if ... end if;
8005 -- end Gnnn;
8009 Func_Body :=
8011 Specification =>
8021 Expression =>
8026 Handled_Statement_Sequence =>
8033 ---------------------------
8034 -- Make_Boolean_Array_Op --
8035 ---------------------------
8037 -- For logical operations on boolean arrays, expand in line the
8038 -- following, replacing 'and' with 'or' or 'xor' where needed:
8040 -- function Annn (A : typ; B: typ) return typ is
8041 -- C : typ;
8042 -- begin
8043 -- for J in A'range loop
8044 -- C (J) := A (J) op B (J);
8045 -- end loop;
8046 -- return C;
8047 -- end Annn;
8049 -- Here typ is the boolean array type
8051 function Make_Boolean_Array_Op
8054 is
8072 begin
8073 A_J :=
8078 B_J :=
8083 C_J :=
8089 Op :=
8095 Op :=
8100 else
8101 Op :=
8107 Loop_Statement :=
8111 Iteration_Scheme =>
8113 Loop_Parameter_Specification =>
8116 Discrete_Subtype_Definition =>
8135 Func_Name :=
8139 Func_Body :=
8141 Specification =>
8152 Handled_Statement_Sequence =>
8155 Loop_Statement,
8162 ------------------------
8163 -- Rewrite_Comparison --
8164 ------------------------
8167 begin
8176 declare
8182 -- Res indicates if compare outcome can be compile time determined
8187 begin
8198 and then Constant_Condition_Warnings
8201 and then not In_Instance
8204 then
8205 Error_Msg_N
8222 and then Constant_Condition_Warnings
8225 and then not In_Instance
8228 then
8229 Error_Msg_N
8255 ----------------------------
8256 -- Safe_In_Place_Array_Op --
8257 ----------------------------
8259 function Safe_In_Place_Array_Op
8263 is
8267 -- Operand is safe if it cannot overlap part of the target of the
8268 -- operation. If the operand and the target are identical, the operand
8269 -- is safe. The operand can be empty in the case of negation.
8272 -- Check that N is a stand-alone entity
8274 ------------------
8275 -- Is_Unaliased --
8276 ------------------
8279 begin
8280 return
8286 ---------------------
8287 -- Is_Safe_Operand --
8288 ---------------------
8291 begin
8300 then
8304 return
8311 else
8316 -- Start of processing for Is_Safe_In_Place_Array_Op
8318 begin
8319 -- We skip this processing if the component size is not the
8320 -- same as a system storage unit (since at least for NOT
8321 -- this would cause problems).
8326 -- Cannot do in place stuff on Java_VM since cannot pass addresses
8331 -- Cannot do in place stuff if non-standard Boolean representation
8338 else
8341 return
8347 -----------------------
8348 -- Tagged_Membership --
8349 -----------------------
8351 -- There are two different cases to consider depending on whether
8352 -- the right operand is a class-wide type or not. If not we just
8353 -- compare the actual tag of the left expr to the target type tag:
8354 --
8355 -- Left_Expr.Tag = Right_Type'Tag;
8356 --
8357 -- If it is a class-wide type we use the RT function CW_Membership which
8358 -- is usually implemented by looking in the ancestor tables contained in
8359 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
8370 begin
8378 Obj_Tag :=
8381 Selector_Name =>
8386 -- Ada 2005 (AI-251): Class-wide applied to interfaces
8390 -- Give support to: "Iface_CW_Typ in Typ'Class"
8393 then
8394 -- Issue error if IW_Membership operation not available in a
8395 -- configurable run time setting.
8402 return
8409 New_Reference_To (
8410 Node (First_Elmt
8412 Loc)));
8414 -- Ada 95: Normal case
8416 else
8417 return
8421 Obj_Tag,
8422 New_Reference_To (
8423 Node (First_Elmt
8425 Loc)));
8428 else
8429 return
8432 Right_Opnd =>
8433 New_Reference_To
8438 ------------------------------
8439 -- Unary_Op_Validity_Checks --
8440 ------------------------------
8443 begin