| blob | bd5ddfb63c2574ecf29636debf338fb36c02a1fa |
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-2007, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
80 -- Performs validity checks for a binary operator
82 procedure Build_Boolean_Array_Proc_Call
86 -- If an boolean array assignment can be done in place, build call to
87 -- corresponding library procedure.
90 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
91 -- Expand_Allocator_Expression. Allocating class-wide interface objects
92 -- this routine displaces the pointer to the allocated object to reference
93 -- the component referencing the corresponding secondary dispatch table.
96 -- Subsidiary to Expand_N_Allocator, for the case when the expression
97 -- is a qualified expression or an aggregate.
100 -- This routine handles expansion of the comparison operators (N_Op_Lt,
101 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
102 -- code for these operators is similar, differing only in the details of
103 -- the actual comparison call that is made. Special processing (call a
104 -- run-time routine)
106 function Expand_Array_Equality
112 -- Expand an array equality into a call to a function implementing this
113 -- equality, and a call to it. Loc is the location for the generated
114 -- nodes. Lhs and Rhs are the array expressions to be compared.
115 -- Bodies is a list on which to attach bodies of local functions that
116 -- are created in the process. It is the responsibility of the
117 -- caller to insert those bodies at the right place. Nod provides
118 -- the Sloc value for the generated code. Normally the types used
119 -- for the generated equality routine are taken from Lhs and Rhs.
120 -- However, in some situations of generated code, the Etype fields
121 -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the
122 -- type to be used for the formal parameters.
125 -- Common expansion processing for Boolean operators (And, Or, Xor)
126 -- for the case of array type arguments.
128 function Expand_Composite_Equality
134 -- Local recursive function used to expand equality for nested
135 -- composite types. Used by Expand_Record/Array_Equality, Bodies
136 -- is a list on which to attach bodies of local functions that are
137 -- created in the process. This is the responsability of the caller
138 -- to insert those bodies at the right place. Nod provides the Sloc
139 -- value for generated code. Lhs and Rhs are the left and right sides
140 -- for the comparison, and Typ is the type of the arrays to compare.
143 -- This routine handles expansion of concatenation operations, where
144 -- N is the N_Op_Concat node being expanded and Operands is the list
145 -- of operands (at least two are present). The caller has dealt with
146 -- converting any singleton operands into singleton aggregates.
149 -- Routine to expand concatenation of 2-5 operands (in the list Operands)
150 -- and replace node Cnode with the result of the contatenation. If there
151 -- are two operands, they can be string or character. If there are more
152 -- than two operands, then are always of type string (i.e. the caller has
153 -- already converted character operands to strings in this case).
156 -- N is either an N_Op_Divide or N_Op_Multiply node whose result is
157 -- universal fixed. We do not have such a type at runtime, so the
158 -- purpose of this routine is to find the real type by looking up
159 -- the tree. We also determine if the operation must be rounded.
161 function Get_Allocator_Final_List
165 -- If the designated type is controlled, build final_list expression
166 -- for created object. If context is an access parameter, create a
167 -- local access type to have a usable finalization list.
170 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
171 -- discriminants if it has a constrained nominal type, unless the object
172 -- is a component of an enclosing Unchecked_Union object that is subject
173 -- to a per-object constraint and the enclosing object lacks inferable
174 -- discriminants.
175 --
176 -- An expression of an Unchecked_Union type has inferable discriminants
177 -- if it is either a name of an object with inferable discriminants or a
178 -- qualified expression whose subtype mark denotes a constrained subtype.
181 -- N is an expression whose type is an access. When the type of the
182 -- associated storage pool is derived from Checked_Pool, generate a
183 -- call to the 'Dereference' primitive operation.
185 function Make_Array_Comparison_Op
188 -- Comparisons between arrays are expanded in line. This function
189 -- produces the body of the implementation of (a > b), where a and b
190 -- are one-dimensional arrays of some discrete type. The original
191 -- node is then expanded into the appropriate call to this function.
192 -- Nod provides the Sloc value for the generated code.
194 function Make_Boolean_Array_Op
197 -- Boolean operations on boolean arrays are expanded in line. This
198 -- function produce the body for the node N, which is (a and b),
199 -- (a or b), or (a xor b). It is used only the normal case and not
200 -- the packed case. The type involved, Typ, is the Boolean array type,
201 -- and the logical operations in the body are simple boolean operations.
202 -- Note that Typ is always a constrained type (the caller has ensured
203 -- this by using Convert_To_Actual_Subtype if necessary).
206 -- If N is the node for a comparison whose outcome can be determined at
207 -- compile time, then the node N can be rewritten with True or False. If
208 -- the outcome cannot be determined at compile time, the call has no
209 -- effect. If N is a type conversion, then this processing is applied to
210 -- its expression. If N is neither comparison nor a type conversion, the
211 -- call has no effect.
214 -- Construct the expression corresponding to the tagged membership test.
215 -- Deals with a second operand being (or not) a class-wide type.
217 function Safe_In_Place_Array_Op
221 -- In the context of an assignment, where the right-hand side is a
222 -- boolean operation on arrays, check whether operation can be performed
223 -- in place.
227 -- Performs validity checks for a unary operator
229 -------------------------------
230 -- Binary_Op_Validity_Checks --
231 -------------------------------
234 begin
241 ------------------------------------
242 -- Build_Boolean_Array_Proc_Call --
243 ------------------------------------
245 procedure Build_Boolean_Array_Proc_Call
249 is
262 begin
266 -- Use negated version of the binary operators
278 Call_Node :=
283 Target,
296 else
299 Call_Node :=
303 Target,
314 else
315 -- We use the following equivalences:
317 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
318 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
319 -- (not X) xor (not Y) = X xor Y
320 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
329 else
333 else
344 else
349 Call_Node :=
353 Target,
368 exception
373 --------------------------------
374 -- Displace_Allocator_Pointer --
375 --------------------------------
384 begin
394 then
395 -- If the type of the allocator expression is not an interface type
396 -- we can generate code to reference the record component containing
397 -- the pointer to the secondary dispatch table.
400 declare
403 begin
404 -- 1) Get access to the allocated object
412 -- 2) Add the conversion to displace the pointer to reference
413 -- the secondary dispatch table.
418 -- 3) The 'access to the secondary dispatch table will be used
419 -- as the value returned by the allocator.
429 -- If the type of the allocator expression is an interface type we
430 -- generate a run-time call to displace "this" to reference the
431 -- component containing the pointer to the secondary dispatch table
432 -- or else raise Constraint_Error if the actual object does not
433 -- implement the target interface. This case corresponds with the
434 -- following example:
436 -- function Op (Obj : Iface_1'Class) return access Ifac_2e'Class is
437 -- begin
438 -- return new Iface_2'Class'(Obj);
439 -- end Op;
441 else
450 New_Occurrence_Of
452 (First_Elmt
454 Loc)))));
460 ---------------------------------
461 -- Expand_Allocator_Expression --
462 ---------------------------------
470 procedure Apply_Accessibility_Check
473 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
474 -- type, generate an accessibility check to verify that the level of
475 -- the type of the created object is not deeper than the level of the
476 -- access type. If the type of the qualified expression is class-
477 -- wide, then always generate the check (except in the case where it
478 -- is known to be unnecessary, see comment below). Otherwise, only
479 -- generate the check if the level of the qualified expression type
480 -- is statically deeper than the access type. Although the static
481 -- accessibility will generally have been performed as a legality
482 -- check, it won't have been done in cases where the allocator
483 -- appears in generic body, so a run-time check is needed in general.
484 -- One special case is when the access type is declared in the same
485 -- scope as the class-wide allocator, in which case the check can
486 -- never fail, so it need not be generated. As an open issue, there
487 -- seem to be cases where the static level associated with the
488 -- class-wide object's underlying type is not sufficient to perform
489 -- the proper accessibility check, such as for allocators in nested
490 -- subprograms or accept statements initialized by class-wide formals
491 -- when the actual originates outside at a deeper static level. The
492 -- nested subprogram case might require passing accessibility levels
493 -- along with class-wide parameters, and the task case seems to be
494 -- an actual gap in the language rules that needs to be fixed by the
495 -- ARG. ???
497 -------------------------------
498 -- Apply_Accessibility_Check --
499 -------------------------------
501 procedure Apply_Accessibility_Check
504 is
507 begin
508 -- Note: we skip the accessibility check for the VM case, since
509 -- there does not seem to be any practical way of implementing it.
515 and then
517 or else
520 then
521 -- If the allocator was built in place Ref is already a reference
522 -- to the access object initialized to the result of the allocator
523 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise
524 -- it is the entity associated with the object containing the
525 -- address of the allocated object.
529 else
535 Condition =>
537 Left_Opnd =>
542 Right_Opnd =>
549 -- Local variables
558 -- Type used as source for tag assignment
561 -- Target reference for tag assignment
568 -- Start of processing for Expand_Allocator_Expression
570 begin
573 -- Ada 2005 (AI-318-02): If the initialization expression is a
574 -- call to a build-in-place function, then access to the allocated
575 -- object must be passed to the function. Currently we limit such
576 -- functions to those with constrained limited result subtypes,
577 -- but eventually we plan to expand the allowed forms of funtions
578 -- that are treated as build-in-place.
582 then
588 -- Actions inserted before:
589 -- Temp : constant ptr_T := new T'(Expression);
590 -- <no CW> Temp._tag := T'tag;
591 -- <CTRL> Adjust (Finalizable (Temp.all));
592 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
594 -- We analyze by hand the new internal allocator to avoid
595 -- any recursion and inappropriate call to Initialize
597 -- We don't want to remove side effects when the expression must be
598 -- built in place. In the case of a build-in-place function call,
599 -- that could lead to a duplication of the call, which was already
600 -- substituted for the allocator.
606 Temp :=
609 -- For a class wide allocation generate the following code:
611 -- type Equiv_Record is record ... end record;
612 -- implicit subtype CW is <Class_Wide_Subytpe>;
613 -- temp : PtrT := new CW'(CW!(expr));
618 -- Ada 2005 (AI-251): If the expression is a class-wide interface
619 -- object we generate code to move up "this" to reference the
620 -- base of the object before allocating the new object.
622 -- Note that Exp'Address is recursively expanded into a call
623 -- to Base_Address (Exp.Tag)
627 then
628 Set_Expression
637 else
638 Set_Expression
646 -- Keep separate the management of allocators returning interfaces
650 Tmp_Node :=
654 Expression =>
658 Set_Comes_From_Source
666 then
667 -- Create local finalization list for access parameter
673 else
684 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
685 -- interface type. In this case we use the type of the qualified
686 -- expression to allocate the object.
688 else
689 declare
695 begin
696 New_Decl :=
699 Type_Definition =>
704 Subtype_Indication =>
709 -- Inherit the final chain to ensure that the expansion of the
710 -- aggregate is correct in case of controlled types
717 -- Declare the object using the previous type declaration
720 Tmp_Node :=
724 Expression =>
728 Set_Comes_From_Source
736 then
737 -- Create local finalization list for access parameter
739 Flist :=
744 else
755 -- Generate an additional object containing the address of the
756 -- returned object. The type of this second object declaration
757 -- is the correct type required for the common proceessing
758 -- that is still performed by this subprogram. The displacement
759 -- of this pointer to reference the component associated with
760 -- the interface type will be done at the end of the common
761 -- processing.
763 New_Decl :=
780 -- Generate the tag assignment
782 -- Suppress the tag assignment when VM_Target because VM tags are
783 -- represented implicitly in objects.
788 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
789 -- interface objects because in this case the tag does not change.
802 then
804 TagR :=
811 Tag_Assign :=
813 Name =>
816 Selector_Name =>
819 Expression =>
821 New_Reference_To
823 Loc)));
825 -- The previous assignment has to be done in any case
833 then
834 declare
839 begin
840 -- If it is an allocation on the secondary stack
841 -- (i.e. a value returned from a function), the object
842 -- is attached on the caller side as soon as the call
843 -- is completed (see Expand_Ctrl_Function_Call)
846 declare
850 begin
861 -- Normal case, not a secondary stack allocation
863 else
866 then
867 -- Create local finalization list for access parameter
869 Flist :=
871 else
878 -- Generate an Adjust call if the object will be moved. In Ada
879 -- 2005, the object may be inherently limited, in which case
880 -- there is no Adjust procedure, and the object is built in
881 -- place. In Ada 95, the object can be limited but not
882 -- inherently limited if this allocator came from a return
883 -- statement (we're allocating the result on the secondary
884 -- stack). In that case, the object will be moved, so we _do_
885 -- want to Adjust.
887 if not Aggr_In_Place
889 then
891 Make_Adjust_Call (
892 Ref =>
894 -- An unchecked conversion is needed in the
895 -- classwide case because the designated type
896 -- can be an ancestor of the subtype mark of
897 -- the allocator.
914 -- Ada 2005 (AI-251): Displace the pointer to reference the
915 -- record component containing the secondary dispatch table
916 -- of the interface type.
923 Temp :=
925 Tmp_Node :=
932 Set_Comes_From_Source
944 then
945 -- Apply constraint to designated subtype indication
953 -- Propagate constraint_error to enclosing allocator
957 else
958 -- First check against the type of the qualified expression
959 --
960 -- NOTE: The commented call should be correct, but for
961 -- some reason causes the compiler to bomb (sigsegv) on
962 -- ACVC test c34007g, so for now we just perform the old
963 -- (incorrect) test against the designated subtype with
964 -- no sliding in the else part of the if statement below.
965 -- ???
966 --
967 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
969 -- A check is also needed in cases where the designated
970 -- subtype is constrained and differs from the subtype
971 -- given in the qualified expression. Note that the check
972 -- on the qualified expression does not allow sliding,
973 -- but this check does (a relaxation from Ada 83).
976 and then not Subtypes_Statically_Match
978 then
979 Apply_Constraint_Check
982 -- The nonsliding check should really be performed
983 -- (unconditionally) against the subtype of the
984 -- qualified expression, but that causes a problem
985 -- with c34007g (see above), so for now we retain this.
987 else
988 Apply_Constraint_Check
992 -- For an access to unconstrained packed array, GIGI needs
993 -- to see an expression with a constrained subtype in order
994 -- to compute the proper size for the allocator.
999 then
1000 declare
1005 begin
1009 Subtype_Indication =>
1016 -- Ada 2005 (AI-318-02): If the initialization expression is a
1017 -- call to a build-in-place function, then access to the allocated
1018 -- object must be passed to the function. Currently we limit such
1019 -- functions to those with constrained limited result subtypes,
1020 -- but eventually we plan to expand the allowed forms of funtions
1021 -- that are treated as build-in-place.
1025 then
1030 exception
1035 -----------------------------
1036 -- Expand_Array_Comparison --
1037 -----------------------------
1039 -- Expansion is only required in the case of array types. For the
1040 -- unpacked case, an appropriate runtime routine is called. For
1041 -- packed cases, and also in some other cases where a runtime
1042 -- routine cannot be called, the form of the expansion is:
1044 -- [body for greater_nn; boolean_expression]
1046 -- The body is built by Make_Array_Comparison_Op, and the form of the
1047 -- Boolean expression depends on the operator involved.
1063 -- True for byte addressable target
1066 -- Returns True if the length of the given operand is known to be
1067 -- less than 4. Returns False if this length is known to be four
1068 -- or greater or is not known at compile time.
1070 ------------------------
1071 -- Length_Less_Than_4 --
1072 ------------------------
1077 begin
1081 else
1082 declare
1089 begin
1092 else
1098 else
1107 -- Start of processing for Expand_Array_Comparison
1109 begin
1110 -- Deal first with unpacked case, where we can call a runtime routine
1111 -- except that we avoid this for targets for which are not addressable
1112 -- by bytes, and for the JVM/CIL, since they do not support direct
1113 -- addressing of array components.
1116 and then Byte_Addressable
1118 then
1119 -- The call we generate is:
1121 -- Compare_Array_xn[_Unaligned]
1122 -- (left'address, right'address, left'length, right'length) <op> 0
1124 -- x = U for unsigned, S for signed
1125 -- n = 8,16,32,64 for component size
1126 -- Add _Unaligned if length < 4 and component size is 8.
1127 -- <op> is the standard comparison operator
1131 or else
1133 then
1136 else
1140 else
1143 else
1151 else
1158 else
1165 else
1203 -- Cases where we cannot make runtime call
1205 -- For (a <= b) we convert to not (a > b)
1210 Right_Opnd =>
1217 -- For < the Boolean expression is
1218 -- greater__nn (op2, op1)
1223 -- Switch operands
1228 -- For (a >= b) we convert to not (a < b)
1233 Right_Opnd =>
1240 -- For > the Boolean expression is
1241 -- greater__nn (op1, op2)
1243 else
1249 Expr :=
1258 exception
1263 ---------------------------
1264 -- Expand_Array_Equality --
1265 ---------------------------
1267 -- Expand an equality function for multi-dimensional arrays. Here is
1268 -- an example of such a function for Nb_Dimension = 2
1270 -- function Enn (A : atyp; B : btyp) return boolean is
1271 -- begin
1272 -- if (A'length (1) = 0 or else A'length (2) = 0)
1273 -- and then
1274 -- (B'length (1) = 0 or else B'length (2) = 0)
1275 -- then
1276 -- return True; -- RM 4.5.2(22)
1277 -- end if;
1279 -- if A'length (1) /= B'length (1)
1280 -- or else
1281 -- A'length (2) /= B'length (2)
1282 -- then
1283 -- return False; -- RM 4.5.2(23)
1284 -- end if;
1286 -- declare
1287 -- A1 : Index_T1 := A'first (1);
1288 -- B1 : Index_T1 := B'first (1);
1289 -- begin
1290 -- loop
1291 -- declare
1292 -- A2 : Index_T2 := A'first (2);
1293 -- B2 : Index_T2 := B'first (2);
1294 -- begin
1295 -- loop
1296 -- if A (A1, A2) /= B (B1, B2) then
1297 -- return False;
1298 -- end if;
1300 -- exit when A2 = A'last (2);
1301 -- A2 := Index_T2'succ (A2);
1302 -- B2 := Index_T2'succ (B2);
1303 -- end loop;
1304 -- end;
1306 -- exit when A1 = A'last (1);
1307 -- A1 := Index_T1'succ (A1);
1308 -- B1 := Index_T1'succ (B1);
1309 -- end loop;
1310 -- end;
1312 -- return true;
1313 -- end Enn;
1315 -- Note on the formal types used (atyp and btyp). If either of the
1316 -- arrays is of a private type, we use the underlying type, and
1317 -- do an unchecked conversion of the actual. If either of the arrays
1318 -- has a bound depending on a discriminant, then we use the base type
1319 -- since otherwise we have an escaped discriminant in the function.
1321 -- If both arrays are constrained and have the same bounds, we can
1322 -- generate a loop with an explicit iteration scheme using a 'Range
1323 -- attribute over the first array.
1325 function Expand_Array_Equality
1331 is
1347 -- The parameter types to be used for the formals
1349 function Arr_Attr
1353 -- This builds the attribute reference Arr'Nam (Expr)
1356 -- Create one statement to compare corresponding components,
1357 -- designated by a full set of indices.
1360 -- Given one of the arguments, computes the appropriate type to
1361 -- be used for that argument in the corresponding function formal
1363 function Handle_One_Dimension
1366 -- This procedure returns the following code
1367 --
1368 -- declare
1369 -- Bn : Index_T := B'First (N);
1370 -- begin
1371 -- loop
1372 -- xxx
1373 -- exit when An = A'Last (N);
1374 -- An := Index_T'Succ (An)
1375 -- Bn := Index_T'Succ (Bn)
1376 -- end loop;
1377 -- end;
1378 --
1379 -- If both indices are constrained and identical, the procedure
1380 -- returns a simpler loop:
1381 --
1382 -- for An in A'Range (N) loop
1383 -- xxx
1384 -- end loop
1385 --
1386 -- N is the dimension for which we are generating a loop. Index is the
1387 -- N'th index node, whose Etype is Index_Type_n in the above code.
1388 -- The xxx statement is either the loop or declare for the next
1389 -- dimension or if this is the last dimension the comparison
1390 -- of corresponding components of the arrays.
1391 --
1392 -- The actual way the code works is to return the comparison
1393 -- of corresponding components for the N+1 call. That's neater!
1396 -- This function constructs the test for both arrays being empty
1397 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1398 -- and then
1399 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1402 -- This function constructs the test for arrays having different
1403 -- lengths in at least one index position, in which case resull
1405 -- A'length (1) /= B'length (1)
1406 -- or else
1407 -- A'length (2) /= B'length (2)
1408 -- or else
1409 -- ...
1411 --------------
1412 -- Arr_Attr --
1413 --------------
1415 function Arr_Attr
1419 is
1420 begin
1421 return
1428 ------------------------
1429 -- Component_Equality --
1430 ------------------------
1436 begin
1437 -- if a(i1...) /= b(j1...) then return false; end if;
1439 L :=
1444 R :=
1449 Test := Expand_Composite_Equality
1452 -- If some (sub)component is an unchecked_union, the whole operation
1453 -- will raise program error.
1457 -- This node is going to be inserted at a location where a
1458 -- statement is expected: clear its Etype so analysis will
1459 -- set it to the expected Standard_Void_Type.
1464 else
1465 return
1474 ------------------
1475 -- Get_Arg_Type --
1476 ------------------
1482 begin
1488 else
1494 or else
1496 then
1508 --------------------------
1509 -- Handle_One_Dimension --
1510 ---------------------------
1512 function Handle_One_Dimension
1515 is
1517 Ltyp /= Rtyp
1519 -- If the index types are identical, and we are working with
1520 -- constrained types, then we can use the same index for both of
1521 -- the arrays.
1531 begin
1536 -- Case where we generate a loop
1541 Bn :=
1544 else
1556 -- Generate guard for loop, followed by increments of indices
1560 Condition =>
1568 Expression =>
1577 Expression =>
1584 -- If separate indexes, we need a declare block for An and Bn, and a
1585 -- loop without an iteration scheme.
1588 Loop_Stm :=
1591 return
1604 Handled_Statement_Sequence =>
1608 -- If no separate indexes, return loop statement with explicit
1609 -- iteration scheme on its own
1611 else
1612 Loop_Stm :=
1615 Iteration_Scheme =>
1617 Loop_Parameter_Specification =>
1620 Discrete_Subtype_Definition =>
1626 -----------------------
1627 -- Test_Empty_Arrays --
1628 -----------------------
1637 begin
1641 Atest :=
1646 Btest :=
1655 else
1656 Alist :=
1661 Blist :=
1668 return
1674 -----------------------------
1675 -- Test_Lengths_Correspond --
1676 -----------------------------
1682 begin
1685 Rtest :=
1692 else
1693 Result :=
1703 -- Start of processing for Expand_Array_Equality
1705 begin
1709 -- For now, if the argument types are not the same, go to the
1710 -- base type, since the code assumes that the formals have the
1711 -- same type. This is fixable in future ???
1719 -- Build list of formals for function
1732 -- Build statement sequence for function
1734 Func_Body :=
1736 Specification =>
1744 Handled_Statement_Sequence =>
1752 Expression =>
1759 Expression =>
1770 -- If the array type is distinct from the type of the arguments,
1771 -- it is the full view of a private type. Apply an unchecked
1772 -- conversion to insure that analysis of the call succeeds.
1774 declare
1777 begin
1783 then
1789 then
1798 return
1804 -----------------------------
1805 -- Expand_Boolean_Operator --
1806 -----------------------------
1808 -- Note that we first get the actual subtypes of the operands,
1809 -- since we always want to deal with types that have bounds.
1814 begin
1815 -- Special case of bit packed array where both operands are known
1816 -- to be properly aligned. In this case we use an efficient run time
1817 -- routine to carry out the operation (see System.Bit_Ops).
1822 then
1827 -- For the normal non-packed case, the general expansion is to build
1828 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1829 -- and then inserting it into the tree. The original operator node is
1830 -- then rewritten as a call to this function. We also use this in the
1831 -- packed case if either operand is a possibly unaligned object.
1833 declare
1840 begin
1849 then
1854 and then
1856 then
1858 else
1864 -- Now rewrite the expression with a call
1869 Parameter_Associations =>
1870 New_List (
1871 L,
1872 Make_Type_Conversion
1880 -------------------------------
1881 -- Expand_Composite_Equality --
1882 -------------------------------
1884 -- This function is only called for comparing internal fields of composite
1885 -- types when these fields are themselves composites. This is a special
1886 -- case because it is not possible to respect normal Ada visibility rules.
1888 function Expand_Composite_Equality
1894 is
1900 begin
1903 else
1907 -- Defense against malformed private types with no completion
1908 -- the error will be diagnosed later by check_completion
1918 -- If the operand is an elementary type other than a floating-point
1919 -- type, then we can simply use the built-in block bitwise equality,
1920 -- since the predefined equality operators always apply and bitwise
1921 -- equality is fine for all these cases.
1925 then
1928 -- For composite component types, and floating-point types, use
1929 -- the expansion. This deals with tagged component types (where
1930 -- we use the applicable equality routine) and floating-point,
1931 -- (where we need to worry about negative zeroes), and also the
1932 -- case of any composite type recursively containing such fields.
1934 else
1940 -- Call the primitive operation "=" of this type
1946 -- If this is derived from an untagged private type completed
1947 -- with a tagged type, it does not have a full view, so we
1948 -- use the primitive operations of the private type.
1949 -- This check should no longer be necessary when these
1950 -- types receive their full views ???
1957 then
1959 else
1963 loop
1975 return
1978 Parameter_Associations =>
1979 New_List
1989 -- Inherited equality from parent type. Convert the actuals
1990 -- to match signature of operation.
1992 declare
1995 begin
1996 return
1999 Parameter_Associations =>
2004 else
2005 -- Comparison between Unchecked_Union components
2008 declare
2014 begin
2015 -- Lhs subtype
2021 -- Rhs subtype
2027 -- Lhs of the composite equality
2031 -- Since the enclosing record can never be an
2032 -- Unchecked_Union (this code is executed for records
2033 -- that do not have variants), we may reference its
2034 -- discriminant(s).
2039 then
2040 Lhs_Discr_Val :=
2043 Selector_Name =>
2044 New_Copy (
2045 Get_Discriminant_Value (
2047 Lhs_Type,
2050 else
2052 Get_Discriminant_Value (
2054 Lhs_Type,
2058 else
2059 -- It is not possible to infer the discriminant since
2060 -- the subtype is not constrained.
2062 return
2067 -- Rhs of the composite equality
2073 then
2074 Rhs_Discr_Val :=
2077 Selector_Name =>
2078 New_Copy (
2079 Get_Discriminant_Value (
2081 Rhs_Type,
2084 else
2086 Get_Discriminant_Value (
2088 Rhs_Type,
2092 else
2093 return
2098 -- Call the TSS equality function with the inferred
2099 -- discriminant values.
2101 return
2105 Lhs,
2106 Rhs,
2107 Lhs_Discr_Val,
2108 Rhs_Discr_Val));
2112 -- Shouldn't this be an else, we can't fall through
2113 -- the above IF, right???
2115 return
2121 else
2125 else
2126 -- It can be a simple record or the full view of a scalar private
2132 ------------------------------
2133 -- Expand_Concatenate_Other --
2134 ------------------------------
2136 -- Let n be the number of array operands to be concatenated, Base_Typ
2137 -- their base type, Ind_Typ their index type, and Arr_Typ the original
2138 -- array type to which the concatenantion operator applies, then the
2139 -- following subprogram is constructed:
2141 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
2142 -- L : Ind_Typ;
2143 -- begin
2144 -- if S1'Length /= 0 then
2145 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
2146 -- XXX = Arr_Typ'First otherwise
2147 -- elsif S2'Length /= 0 then
2148 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
2149 -- YYY = Arr_Typ'First otherwise
2150 -- ...
2151 -- elsif Sn-1'Length /= 0 then
2152 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
2153 -- ZZZ = Arr_Typ'First otherwise
2154 -- else
2155 -- return Sn;
2156 -- end if;
2158 -- declare
2159 -- P : Ind_Typ;
2160 -- H : Ind_Typ :=
2161 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
2162 -- + Ind_Typ'Pos (L));
2163 -- R : Base_Typ (L .. H);
2164 -- begin
2165 -- if S1'Length /= 0 then
2166 -- P := S1'First;
2167 -- loop
2168 -- R (L) := S1 (P);
2169 -- L := Ind_Typ'Succ (L);
2170 -- exit when P = S1'Last;
2171 -- P := Ind_Typ'Succ (P);
2172 -- end loop;
2173 -- end if;
2174 --
2175 -- if S2'Length /= 0 then
2176 -- L := Ind_Typ'Succ (L);
2177 -- loop
2178 -- R (L) := S2 (P);
2179 -- L := Ind_Typ'Succ (L);
2180 -- exit when P = S2'Last;
2181 -- P := Ind_Typ'Succ (P);
2182 -- end loop;
2183 -- end if;
2185 -- ...
2187 -- if Sn'Length /= 0 then
2188 -- P := Sn'First;
2189 -- loop
2190 -- R (L) := Sn (P);
2191 -- L := Ind_Typ'Succ (L);
2192 -- exit when P = Sn'Last;
2193 -- P := Ind_Typ'Succ (P);
2194 -- end loop;
2195 -- end if;
2197 -- return R;
2198 -- end;
2199 -- end Cnn;]
2237 -- Builds the sequence of statement:
2238 -- P := Si'First;
2239 -- loop
2240 -- R (L) := Si (P);
2241 -- L := Ind_Typ'Succ (L);
2242 -- exit when P = Si'Last;
2243 -- P := Ind_Typ'Succ (P);
2244 -- end loop;
2245 --
2246 -- where i is the input parameter I given.
2247 -- If the flag Last is true, the exit statement is emitted before
2248 -- incrementing the lower bound, to prevent the creation out of
2249 -- bound values.
2252 -- Builds the statement:
2253 -- L := Arr_Typ'First; If Arr_Typ is constrained
2254 -- L := Si'First; otherwise (where I is the input param given)
2257 -- Builds reference to identifier H
2260 -- Builds expression Ind_Typ'Val (E);
2263 -- Builds reference to identifier L
2266 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
2267 -- expression to avoid universal_integer computations whenever possible,
2268 -- in the expression for the upper bound H.
2271 -- Builds expression Ind_Typ'Succ (L)
2274 -- Builds integer literal one
2277 -- Builds reference to identifier P
2280 -- Builds expression Ind_Typ'Succ (P)
2283 -- Builds reference to identifier R
2286 -- Builds reference to identifier Si, where I is the value given
2289 -- Builds expression Si'First, where I is the value given
2292 -- Builds expression Si'Last, where I is the value given
2295 -- Builds expression Si'Length, where I is the value given
2298 -- Builds expression Si'Length /= 0, where I is the value given
2300 -------------------
2301 -- Copy_Into_R_S --
2302 -------------------
2313 begin
2314 -- First construct the initializations
2321 -- Then build the loop
2343 Loop_Stmt :=
2346 else
2347 Loop_Stmt :=
2357 -------
2358 -- H --
2359 -------
2362 begin
2366 -------------
2367 -- Ind_Val --
2368 -------------
2371 begin
2372 return
2379 ------------
2380 -- Init_L --
2381 ------------
2386 begin
2392 else
2399 -------
2400 -- L --
2401 -------
2404 begin
2408 -----------
2409 -- L_Pos --
2410 -----------
2415 begin
2416 -- If the index type is an enumeration type, the computation
2417 -- can be done in standard integer. Otherwise, choose a large
2418 -- enough integer type.
2424 then
2426 else
2430 return
2433 Expression =>
2440 ------------
2441 -- L_Succ --
2442 ------------
2445 begin
2446 return
2453 ---------
2454 -- One --
2455 ---------
2458 begin
2462 -------
2463 -- P --
2464 -------
2467 begin
2471 ------------
2472 -- P_Succ --
2473 ------------
2476 begin
2477 return
2484 -------
2485 -- R --
2486 -------
2489 begin
2493 -------
2494 -- S --
2495 -------
2498 begin
2502 -------------
2503 -- S_First --
2504 -------------
2507 begin
2513 ------------
2514 -- S_Last --
2515 ------------
2518 begin
2524 --------------
2525 -- S_Length --
2526 --------------
2529 begin
2535 -------------------
2536 -- S_Length_Test --
2537 -------------------
2540 begin
2541 return
2547 -- Start of processing for Expand_Concatenate_Other
2549 begin
2550 -- Construct the parameter specs and the overall function spec
2554 Append_To
2557 Defining_Identifier =>
2563 Func_Spec :=
2569 -- Construct L's object declaration
2571 L_Decl :=
2578 -- Construct the if-then-elsif statements
2587 If_Stmt :=
2595 -- Construct the declaration for H
2597 P_Decl :=
2608 H_Decl :=
2614 -- Construct the declaration for R
2617 R_Constr :=
2621 R_Decl :=
2624 Object_Definition =>
2629 -- Construct the declarations for the declare block
2633 -- Construct list of statements for the declare block
2643 Append_To
2646 -- Construct the declare block
2650 Handled_Statement_Sequence =>
2653 -- Construct the list of function statements
2657 -- Construct the function body
2659 Func_Body :=
2663 Handled_Statement_Sequence =>
2666 -- Insert the newly generated function in the code. This is analyzed
2667 -- with all checks off, since we have completed all the checks.
2669 -- Note that this does *not* fix the array concatenation bug when the
2670 -- low bound is Integer'first sibce that bug comes from the pointer
2671 -- dereferencing an unconstrained array. An there we need a constraint
2672 -- check to make sure the length of the concatenated array is ok. ???
2676 -- Construct list of arguments for the function call
2685 -- Insert the function call
2687 Rewrite
2695 -------------------------------
2696 -- Expand_Concatenate_String --
2697 -------------------------------
2707 -- RE_Id value for function to be called
2709 begin
2710 -- In all cases, we build a call to a routine giving the list of
2711 -- arguments as the parameter list to the routine.
2719 else
2728 else
2733 -- If we have anything other than Standard_Character or
2734 -- Standard_String, then we must have had a serious error
2735 -- earlier, so we just abandon the attempt at expansion.
2737 else
2756 -- Now generate the appropriate call
2765 exception
2770 ------------------------
2771 -- Expand_N_Allocator --
2772 ------------------------
2784 -- Generate finalization calls for all nested coextensions of N. This
2785 -- routine may allocate list controllers if necessary.
2788 -- Static coextensions have the same lifetime as the entity they
2789 -- constrain. Such occurences can be rewritten as aliased objects
2790 -- and their unrestricted access used instead of the coextension.
2792 ---------------------------------------
2793 -- Complete_Coextension_Finalization --
2794 ---------------------------------------
2803 -- Determine whether node N is part of a return statement
2806 -- Determine whether node N is a subtype indicator allocator which
2807 -- asts a coextension. Such coextensions need initialization.
2809 -------------------------------
2810 -- Inside_A_Return_Statement --
2811 -------------------------------
2816 begin
2821 then
2824 -- Stop the traversal when we reach a subprogram body
2836 -------------------------------
2837 -- Needs_Initialization_Call --
2838 -------------------------------
2843 begin
2847 N_Object_Declaration
2848 then
2851 return
2855 N_Qualified_Expression;
2861 -- Start of processing for Complete_Coextension_Finalization
2863 begin
2864 -- When a coextension root is inside a return statement, we need to
2865 -- use the finalization chain of the function's scope. This does not
2866 -- apply for controlled named access types because in those cases we
2867 -- can use the finalization chain of the type itself.
2870 and then
2872 or else
2875 then
2876 declare
2881 begin
2886 -- Retrieve the declaration of the body
2896 -- Push the scope of the function body since we are inserting
2897 -- the list before the body, but we are currently in the body
2898 -- itself. Override the finalization list of PtrT since the
2899 -- finalization context is now different.
2903 Pop_Scope;
2906 -- The root allocator may not be controlled, but it still needs a
2907 -- finalization list for all nested coextensions.
2913 Flist :=
2915 Prefix =>
2917 Selector_Name =>
2924 -- Generate:
2925 -- typ! (coext.all)
2929 Subtype_Mark =>
2931 Expression =>
2934 else
2938 -- Generate:
2939 -- initialize (Ref)
2940 -- attach_to_final_list (Ref, Flist, 2)
2944 Make_Init_Call (
2950 -- Generate:
2951 -- attach_to_final_list (Ref, Flist, 2)
2953 else
2955 Make_Attach_Call (
2965 -------------------------
2966 -- Rewrite_Coextension --
2967 -------------------------
2974 -- Generate:
2975 -- Cnn : aliased Etyp;
2981 Object_Definition =>
2985 begin
2990 -- Find the proper insertion node for the declaration
3011 -- Start of processing for Expand_N_Allocator
3013 begin
3014 -- RM E.2.3(22). We enforce that the expected type of an allocator
3015 -- shall not be a remote access-to-class-wide-limited-private type
3017 -- Why is this being done at expansion time, seems clearly wrong ???
3021 -- Set the Storage Pool
3034 else
3040 -- Under certain circumstances we can replace an allocator by an
3041 -- access to statically allocated storage. The conditions, as noted
3042 -- in AARM 3.10 (10c) are as follows:
3044 -- Size and initial value is known at compile time
3045 -- Access type is access-to-constant
3047 -- The allocator is not part of a constraint on a record component,
3048 -- because in that case the inserted actions are delayed until the
3049 -- record declaration is fully analyzed, which is too late for the
3050 -- analysis of the rewritten allocator.
3058 then
3059 -- Here we can do the optimization. For the allocator
3061 -- new x'(y)
3063 -- We insert an object declaration
3065 -- Tnn : aliased x := y;
3067 -- and replace the allocator by Tnn'Unrestricted_Access.
3068 -- Tnn is marked as requiring static allocation.
3070 Temp :=
3075 -- If context is constrained, use constrained subtype directly,
3076 -- so that the constant is not labelled as having a nomimally
3077 -- unconstrained subtype.
3098 -- We set the variable as statically allocated, since we don't
3099 -- want it going on the stack of the current procedure!
3105 -- Same if the allocator is an access discriminant for a local object:
3106 -- instead of an allocator we create a local value and constrain the
3107 -- the enclosing object with the corresponding access attribute.
3114 -- The current allocator creates an object which may contain nested
3115 -- coextensions. Use the current allocator's finalization list to
3116 -- generate finalization call for all nested coextensions.
3119 Complete_Coextension_Finalization;
3122 -- Handle case of qualified expression (other than optimization above)
3129 -- If the allocator is for a type which requires initialization, and
3130 -- there is no initial value (i.e. operand is a subtype indication
3131 -- rather than a qualifed expression), then we must generate a call
3132 -- to the initialization routine. This is done using an expression
3133 -- actions node:
3135 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3137 -- Here ptr_T is the pointer type for the allocator, and T is the
3138 -- subtype of the allocator. A special case arises if the designated
3139 -- type of the access type is a task or contains tasks. In this case
3140 -- the call to Init (Temp.all ...) is replaced by code that ensures
3141 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3142 -- for details). In addition, if the type T is a task T, then the
3143 -- first argument to Init must be converted to the task record type.
3145 declare
3158 begin
3162 -- Case of no initialization procedure present
3166 -- Case of simple initialization required
3179 -- No initialization required
3181 else
3185 -- Case of initialization procedure present, must be called
3187 else
3192 -- Construct argument list for the initialization routine call.
3193 -- The CPP constructor needs the address directly
3199 else
3205 -- The initialization procedure expects a specific type. if
3206 -- the context is access to class wide, indicate that the
3207 -- object being allocated has the right specific type.
3214 -- If designated type is a concurrent type or if it is private
3215 -- type whose definition is a concurrent type, the first argument
3216 -- in the Init routine has to be unchecked conversion to the
3217 -- corresponding record type. If the designated type is a derived
3218 -- type, we also convert the argument to its root type.
3221 Arg1 :=
3227 then
3228 Arg1 :=
3229 Unchecked_Convert_To
3233 declare
3236 begin
3244 -- For the task case, pass the Master_Id of the access type as
3245 -- the value of the _Master parameter, and _Chain as the value
3246 -- of the _Chain parameter (_Chain will be defined as part of
3247 -- the generated code for the allocator).
3249 -- In Ada 2005, the context may be a function that returns an
3250 -- anonymous access type. In that case the Master_Id has been
3251 -- created when expanding the function declaration.
3256 -- If we have a non-library level task with the restriction
3257 -- No_Task_Hierarchy set, then no point in expanding.
3261 then
3265 -- The designated type was an incomplete type, and the
3266 -- access type did not get expanded. Salvage it now.
3272 -- If the context of the allocator is a declaration or an
3273 -- assignment, we can generate a meaningful image for it,
3274 -- even though subsequent assignments might remove the
3275 -- connection between task and entity. We build this image
3276 -- when the left-hand side is a simple variable, a simple
3277 -- indexed assignment or a simple selected component.
3280 declare
3283 begin
3285 Decls :=
3286 Build_Task_Image_Decls (
3287 Loc,
3288 New_Occurrence_Of
3294 then
3295 Decls :=
3296 Build_Task_Image_Decls
3298 else
3304 Decls :=
3305 Build_Task_Image_Decls (
3308 else
3313 New_Reference_To
3321 -- Has_Task is false, Decls not used
3323 else
3327 -- Add discriminants if discriminated type
3329 declare
3333 begin
3341 then
3347 -- If the allocated object will be constrained by the
3348 -- default values for discriminants, then build a
3349 -- subtype with those defaults, and change the allocated
3350 -- subtype to that. Note that this happens in fewer
3351 -- cases in Ada 2005 (AI-363).
3358 then
3368 -- AI-416: when the discriminant constraint is an
3369 -- anonymous access type make sure an accessibility
3370 -- check is inserted if necessary (3.10.2(22.q/2))
3374 then
3383 -- We set the allocator as analyzed so that when we analyze the
3384 -- expression actions node, we do not get an unwanted recursive
3385 -- expansion of the allocator expression.
3390 -- Here is the transformation:
3391 -- input: new T
3392 -- output: Temp : constant ptr_T := new T;
3393 -- Init (Temp.all, ...);
3394 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
3395 -- <CTRL> Initialize (Finalizable (Temp.all));
3397 -- Here ptr_T is the pointer type for the allocator, and is the
3398 -- subtype of the allocator.
3400 Temp_Decl :=
3415 -- If the designated type is a task type or contains tasks,
3416 -- create block to activate created tasks, and insert
3417 -- declaration for Task_Image variable ahead of call.
3420 declare
3424 begin
3432 else
3441 -- Postpone the generation of a finalization call for the
3442 -- current allocator if it acts as a coextension.
3451 else
3454 -- Anonymous access types created for access parameters
3455 -- are attached to an explicitly constructed controller,
3456 -- which ensures that they can be finalized properly, even
3457 -- if their deallocation might not happen. The list
3458 -- associated with the controller is doubly-linked. For
3459 -- other anonymous access types, the object may end up
3460 -- on the global final list which is singly-linked.
3461 -- Work needed for access discriminants in Ada 2005 ???
3464 and then
3466 not in N_Subprogram_Specification
3467 then
3469 else
3474 Make_Init_Call (
3478 With_Attach => Make_Integer_Literal
3488 else
3496 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
3497 -- object that has been rewritten as a reference, we displace "this"
3498 -- to reference properly its secondary dispatch table.
3502 then
3506 exception
3511 -----------------------
3512 -- Expand_N_And_Then --
3513 -----------------------
3515 -- Expand into conditional expression if Actions present, and also deal
3516 -- with optimizing case of arguments being True or False.
3525 begin
3526 -- Deal with non-standard booleans
3534 -- Check for cases of left argument is True or False
3538 -- If left argument is True, change (True and then Right) to Right.
3539 -- Any actions associated with Right will be executed unconditionally
3540 -- and can thus be inserted into the tree unconditionally.
3551 -- If left argument is False, change (False and then Right) to False.
3552 -- In this case we can forget the actions associated with Right,
3553 -- since they will never be executed.
3564 -- If Actions are present, we expand
3566 -- left and then right
3568 -- into
3570 -- if left then right else false end
3572 -- with the actions becoming the Then_Actions of the conditional
3573 -- expression. This conditional expression is then further expanded
3574 -- (and will eventually disappear)
3581 Left,
3582 Right,
3591 -- No actions present, check for cases of right argument True/False
3595 -- Change (Left and then True) to Left. Note that we know there
3596 -- are no actions associated with the True operand, since we
3597 -- just checked for this case above.
3602 -- Change (Left and then False) to False, making sure to preserve
3603 -- any side effects associated with the Left operand.
3607 Rewrite
3615 -------------------------------------
3616 -- Expand_N_Conditional_Expression --
3617 -------------------------------------
3619 -- Expand into expression actions if then/else actions present
3630 begin
3631 -- If either then or else actions are present, then given:
3633 -- if cond then then-expr else else-expr end
3635 -- we insert the following sequence of actions (using Insert_Actions):
3637 -- Cnn : typ;
3638 -- if cond then
3639 -- <<then actions>>
3640 -- Cnn := then-expr;
3641 -- else
3642 -- <<else actions>>
3643 -- Cnn := else-expr
3644 -- end if;
3646 -- and replace the conditional expression by a reference to Cnn
3651 New_If :=
3669 Insert_List_Before
3674 Insert_List_Before
3690 -----------------------------------
3691 -- Expand_N_Explicit_Dereference --
3692 -----------------------------------
3695 begin
3696 -- Insert explicit dereference call for the checked storage pool case
3701 -----------------
3702 -- Expand_N_In --
3703 -----------------
3713 -- Replaces node N by Lop'Valid. This is done when we have an explicit
3714 -- test for the left operand being in range of its subtype.
3716 ----------------------------
3717 -- Substitute_Valid_Check --
3718 ----------------------------
3721 begin
3734 -- Start of processing for Expand_N_In
3736 begin
3737 -- Check case of explicit test for an expression in range of its
3738 -- subtype. This is suspicious usage and we replace it with a 'Valid
3739 -- test and give a warning.
3746 then
3747 Substitute_Valid_Check;
3751 -- Do validity check on operands
3758 -- Case of explicit range
3761 declare
3774 Constant_Condition_Warnings
3776 -- This must be true for any of the optimization warnings, we
3777 -- clearly want to give them only for source with the flag on.
3780 Warn1
3783 -- For the case where only one bound warning is elided, we also
3784 -- insist on an explicit range and an integer type. The reason is
3785 -- that the use of enumeration ranges including an end point is
3786 -- common, as is the use of a subtype name, one of whose bounds
3787 -- is the same as the type of the expression.
3789 begin
3790 -- If test is explicit x'first .. x'last, replace by valid check
3803 then
3804 Substitute_Valid_Check;
3808 -- If bounds of type are known at compile time, and the end points
3809 -- are known at compile time and identical, this is another case
3810 -- for substituting a valid test. We only do this for discrete
3811 -- types, since it won't arise in practice for float types.
3821 then
3822 Substitute_Valid_Check;
3826 -- If we have an explicit range, do a bit of optimization based
3827 -- on range analysis (we may be able to kill one or both checks).
3829 -- If either check is known to fail, replace result by False since
3830 -- the other check does not matter. Preserve the static flag for
3831 -- legality checks, because we are constant-folding beyond RM 4.9.
3846 -- If both checks are known to succeed, replace result
3847 -- by True, since we know we are in range.
3862 -- If lower bound check succeeds and upper bound check is not
3863 -- known to succeed or fail, then replace the range check with
3864 -- a comparison against the upper bound.
3880 -- If upper bound check succeeds and lower bound check is not
3881 -- known to succeed or fail, then replace the range check with
3882 -- a comparison against the lower bound.
3900 -- For all other cases of an explicit range, nothing to be done
3904 -- Here right operand is a subtype mark
3906 else
3907 declare
3913 begin
3916 -- For tagged type, do tagged membership operation
3920 -- No expansion will be performed when VM_Target, as the VM
3921 -- back-ends will handle the membership tests directly (tags
3922 -- are not explicitly represented in Java objects, so the
3923 -- normal tagged membership expansion is not what we want).
3932 -- If type is scalar type, rewrite as x in t'first .. t'last.
3933 -- This reason we do this is that the bounds may have the wrong
3934 -- type if they come from the original type definition.
3939 Low_Bound =>
3944 High_Bound =>
3951 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
3952 -- a membership test if the subtype mark denotes a constrained
3953 -- Unchecked_Union subtype and the expression lacks inferable
3954 -- discriminants.
3959 then
3964 -- Prevent Gigi from generating incorrect code by rewriting
3965 -- the test as a standard False.
3973 -- Here we have a non-scalar type
3984 -- For the constrained array case, we have to check the
3985 -- subscripts for an exact match if the lengths are
3986 -- non-zero (the lengths must match in any case).
3991 function Construct_Attribute_Reference
3995 -- Build attribute reference E'Nam(Dim)
3997 -----------------------------------
3998 -- Construct_Attribute_Reference --
3999 -----------------------------------
4001 function Construct_Attribute_Reference
4005 is
4006 begin
4007 return
4015 -- Start processing for Check_Subscripts
4017 begin
4021 Left_Opnd =>
4022 Construct_Attribute_Reference
4025 Right_Opnd =>
4026 Construct_Attribute_Reference
4031 Left_Opnd =>
4032 Construct_Attribute_Reference
4035 Right_Opnd =>
4036 Construct_Attribute_Reference
4041 Cond :=
4043 Left_Opnd =>
4054 -- These are the cases where constraint checks may be
4055 -- required, e.g. records with possible discriminants
4057 else
4058 -- Expand the test into a series of discriminant comparisons.
4059 -- The expression that is built is the negation of the one
4060 -- that is used for checking discriminant constraints.
4070 Left_Opnd =>
4077 else
4088 --------------------------------
4089 -- Expand_N_Indexed_Component --
4090 --------------------------------
4098 begin
4099 -- A special optimization, if we have an indexed component that
4100 -- is selecting from a slice, then we can eliminate the slice,
4101 -- since, for example, x (i .. j)(k) is identical to x(k). The
4102 -- only difference is the range check required by the slice. The
4103 -- range check for the slice itself has already been generated.
4104 -- The range check for the subscripting operation is ensured
4105 -- by converting the subject to the subtype of the slice.
4107 -- This optimization not only generates better code, avoiding
4108 -- slice messing especially in the packed case, but more importantly
4109 -- bypasses some problems in handling this peculiar case, for
4110 -- example, the issue of dealing specially with object renamings.
4117 Convert_To
4124 -- If the prefix is an access type, then we unconditionally rewrite
4125 -- if as an explicit deference. This simplifies processing for several
4126 -- cases, including packed array cases and certain cases in which
4127 -- checks must be generated. We used to try to do this only when it
4128 -- was necessary, but it cleans up the code to do it all the time.
4135 -- Generate index and validity checks
4143 -- All done for the non-packed case
4149 -- For packed arrays that are not bit-packed (i.e. the case of an array
4150 -- with one or more index types with a non-coniguous enumeration type),
4151 -- we can always use the normal packed element get circuit.
4158 -- For a reference to a component of a bit packed array, we have to
4159 -- convert it to a reference to the corresponding Packed_Array_Type.
4160 -- We only want to do this for simple references, and not for:
4162 -- Left side of assignment, or prefix of left side of assignment,
4163 -- or prefix of the prefix, to handle packed arrays of packed arrays,
4164 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4166 -- Renaming objects in renaming associations
4167 -- This case is handled when a use of the renamed variable occurs
4169 -- Actual parameters for a procedure call
4170 -- This case is handled in Exp_Ch6.Expand_Actuals
4172 -- The second expression in a 'Read attribute reference
4174 -- The prefix of an address or size attribute reference
4176 -- The following circuit detects these exceptions
4178 declare
4182 begin
4183 loop
4190 and then
4192 then
4197 or else
4200 then
4205 then
4208 -- If the expression is an index of an indexed component,
4209 -- it must be expanded regardless of context.
4213 then
4219 then
4225 then
4231 then
4234 else
4239 -- Keep looking up tree for unchecked expression, or if we are
4240 -- the prefix of a possible assignment left side.
4248 ---------------------
4249 -- Expand_N_Not_In --
4250 ---------------------
4252 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
4253 -- can be done. This avoids needing to duplicate this expansion code.
4260 begin
4263 Right_Opnd =>
4268 -- We want this to appear as coming from source if original does (see
4269 -- tranformations in Expand_N_In).
4274 -- Now analyze tranformed node
4279 -------------------
4280 -- Expand_N_Null --
4281 -------------------
4283 -- The only replacement required is for the case of a null of type
4284 -- that is an access to protected subprogram. We represent such
4285 -- access values as a record, and so we must replace the occurrence
4286 -- of null by the equivalent record (with a null address and a null
4287 -- pointer in it), so that the backend creates the proper value.
4294 begin
4296 Agg :=
4305 -- For subsequent semantic analysis, the node must retain its
4306 -- type. Gigi in any case replaces this type by the corresponding
4307 -- record type before processing the node.
4312 exception
4317 ---------------------
4318 -- Expand_N_Op_Abs --
4319 ---------------------
4325 begin
4328 -- Deal with software overflow checking
4330 if not Backend_Overflow_Checks_On_Target
4333 then
4334 -- The only case to worry about is when the argument is
4335 -- equal to the largest negative number, so what we do is
4336 -- to insert the check:
4338 -- [constraint_error when Expr = typ'Base'First]
4340 -- with the usual Duplicate_Subexpr use coding for expr
4344 Condition =>
4347 Right_Opnd =>
4349 Prefix =>
4355 -- Vax floating-point types case
4362 ---------------------
4363 -- Expand_N_Op_Add --
4364 ---------------------
4369 begin
4372 -- N + 0 = 0 + N = N for integer types
4377 then
4383 then
4389 -- Arithmetic overflow checks for signed integer/fixed point types
4393 then
4397 -- Vax floating-point types case
4404 ---------------------
4405 -- Expand_N_Op_And --
4406 ---------------------
4411 begin
4425 ------------------------
4426 -- Expand_N_Op_Concat --
4427 ------------------------
4430 -- This is initialized the first time this routine is called. It records
4431 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
4432 -- available in the run-time:
4433 --
4434 -- 0 None available
4435 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
4436 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
4437 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
4438 -- 5 All routines including RE_Str_Concat_5 available
4441 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
4442 -- all three are available, False if any one of these is unavailable.
4446 -- List of operands to be concatenated
4449 -- Single operand for concatenation
4452 -- Node which is to be replaced by the result of concatenating
4453 -- the nodes in the list Opnds.
4456 -- Array type of concatenation result type
4459 -- Component type of concatenation represented by Cnode
4461 begin
4462 -- Initialize global variables showing run-time status
4466 -- In No_Run_Time mode, consider that no entities are available
4468 -- This seems wrong, RTE_Available should return False for any entity
4469 -- that is not in the special No_Run_Time list of allowed entities???
4474 -- Otherwise see what routines are available and set max operand
4475 -- count according to the highest count available in the run-time.
4489 else
4493 Char_Concat_Available :=
4494 not No_Run_Time_Mode
4495 and then
4497 and then
4499 and then
4503 -- Ensure validity of both operands
4507 -- If we are the left operand of a concatenation higher up the
4508 -- tree, then do nothing for now, since we want to deal with a
4509 -- series of concatenations as a unit.
4513 then
4517 -- We get here with a concatenation whose left operand may be a
4518 -- concatenation itself with a consistent type. We need to process
4519 -- these concatenation operands from left to right, which means
4520 -- from the deepest node in the tree to the highest node.
4527 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
4528 -- nodes above, so now we process bottom up, doing the operations. We
4529 -- gather a string that is as long as possible up to five operands
4531 -- The outer loop runs more than once if there are more than five
4532 -- concatenations of type Standard.String, the most we handle for
4533 -- this case, or if more than one concatenation type is involved.
4539 -- The inner loop gathers concatenation operands. We gather any
4540 -- number of these in the non-string case, or if no concatenation
4541 -- routines are available for string (since in that case we will
4542 -- treat string like any other non-string case). Otherwise we only
4543 -- gather as many operands as can be handled by the available
4544 -- procedures in the run-time library (normally 5, but may be
4545 -- less for the configurable run-time case).
4549 or else
4551 or else
4553 Max_Available_String_Operands)
4556 loop
4561 -- Here we process the collected operands. First we convert
4562 -- singleton operands to singleton aggregates. This is skipped
4563 -- however for the case of two operands of type String, since
4564 -- we have special routines for these cases.
4570 or else not Char_Concat_Available
4571 then
4573 loop
4586 -- Now call appropriate continuation routine
4590 then
4592 else
4601 ------------------------
4602 -- Expand_N_Op_Divide --
4603 ------------------------
4613 and then
4617 begin
4624 -- N / 1 = N for integer types
4631 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
4632 -- Is_Power_Of_2_For_Shift is set means that we know that our left
4633 -- operand is an unsigned integer, as required for this to work.
4638 -- We cannot do this transformation in configurable run time mode if we
4639 -- have 64-bit -- integers and long shifts are not available.
4641 and then
4644 then
4648 Right_Opnd =>
4654 -- Do required fixup of universal fixed operation
4661 -- Divisions with fixed-point results
4665 -- No special processing if Treat_Fixed_As_Integer is set,
4666 -- since from a semantic point of view such operations are
4667 -- simply integer operations and will be treated that way.
4672 else
4677 -- Other cases of division of fixed-point operands. Again we
4678 -- exclude the case where Treat_Fixed_As_Integer is set.
4683 then
4686 else
4691 -- Mixed-mode operations can appear in a non-static universal
4692 -- context, in which case the integer argument must be converted
4693 -- explicitly.
4697 then
4705 then
4711 -- Non-fixed point cases, do integer zero divide and overflow checks
4716 -- Check for 64-bit division available, or long shifts if the divisor
4717 -- is a small power of 2 (since such divides will be converted into
4718 -- long shifts.
4721 and then not Support_64_Bit_Divides_On_Target
4722 and then
4724 or else not Support_Long_Shifts_On_Target
4731 then
4735 -- Deal with Vax_Float
4743 --------------------
4744 -- Expand_N_Op_Eq --
4745 --------------------
4760 -- If a constructed equality exists for the type or for its parent,
4761 -- build and analyze call, adding conversions if the operation is
4762 -- inherited.
4765 -- Determines whether a type has a subcompoment of an unconstrained
4766 -- Unchecked_Union subtype. Typ is a record type.
4768 -------------------------
4769 -- Build_Equality_Call --
4770 -------------------------
4777 begin
4780 then
4785 -- If we have an Unchecked_Union, we need to add the inferred
4786 -- discriminant values as actuals in the function call. At this
4787 -- point, the expansion has determined that both operands have
4788 -- inferable discriminants.
4791 declare
4797 begin
4798 -- Per-object constrained selected components require special
4799 -- attention. If the enclosing scope of the component is an
4800 -- Unchecked_Union, we cannot reference its discriminants
4801 -- directly. This is why we use the two extra parameters of
4802 -- the equality function of the enclosing Unchecked_Union.
4804 -- type UU_Type (Discr : Integer := 0) is
4805 -- . . .
4806 -- end record;
4807 -- pragma Unchecked_Union (UU_Type);
4809 -- 1. Unchecked_Union enclosing record:
4811 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
4812 -- . . .
4813 -- Comp : UU_Type (Discr);
4814 -- . . .
4815 -- end Enclosing_UU_Type;
4816 -- pragma Unchecked_Union (Enclosing_UU_Type);
4818 -- Obj1 : Enclosing_UU_Type;
4819 -- Obj2 : Enclosing_UU_Type (1);
4821 -- [. . .] Obj1 = Obj2 [. . .]
4823 -- Generated code:
4825 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4827 -- A and B are the formal parameters of the equality function
4828 -- of Enclosing_UU_Type. The function always has two extra
4829 -- formals to capture the inferred discriminant values.
4831 -- 2. Non-Unchecked_Union enclosing record:
4833 -- type
4834 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
4835 -- is record
4836 -- . . .
4837 -- Comp : UU_Type (Discr);
4838 -- . . .
4839 -- end Enclosing_Non_UU_Type;
4841 -- Obj1 : Enclosing_Non_UU_Type;
4842 -- Obj2 : Enclosing_Non_UU_Type (1);
4844 -- ... Obj1 = Obj2 ...
4846 -- Generated code:
4848 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
4849 -- obj1.discr, obj2.discr)) then
4851 -- In this case we can directly reference the discriminants of
4852 -- the enclosing record.
4854 -- Lhs of equality
4857 and then Has_Per_Object_Constraint
4859 then
4860 -- Enclosing record is an Unchecked_Union, use formal A
4864 then
4865 Lhs_Discr_Val :=
4869 -- Enclosing record is of a non-Unchecked_Union type, it is
4870 -- possible to reference the discriminant.
4872 else
4873 Lhs_Discr_Val :=
4876 Selector_Name =>
4877 New_Copy
4878 (Get_Discriminant_Value
4880 Lhs_Type,
4884 -- Comment needed here ???
4886 else
4887 -- Infer the discriminant value
4889 Lhs_Discr_Val :=
4890 New_Copy
4891 (Get_Discriminant_Value
4893 Lhs_Type,
4897 -- Rhs of equality
4900 and then Has_Per_Object_Constraint
4902 then
4903 if Is_Unchecked_Union
4905 then
4906 Rhs_Discr_Val :=
4910 else
4911 Rhs_Discr_Val :=
4914 Selector_Name =>
4917 Rhs_Type,
4921 else
4922 Rhs_Discr_Val :=
4925 Rhs_Type,
4934 L_Exp,
4935 R_Exp,
4936 Lhs_Discr_Val,
4937 Rhs_Discr_Val)));
4940 -- Normal case, not an unchecked union
4942 else
4952 ------------------------------------
4953 -- Has_Unconstrained_UU_Component --
4954 ------------------------------------
4956 function Has_Unconstrained_UU_Component
4958 is
4964 function Component_Is_Unconstrained_UU
4966 -- Determines whether the subtype of the component is an
4967 -- unconstrained Unchecked_Union.
4969 function Variant_Is_Unconstrained_UU
4971 -- Determines whether a component of the variant has an unconstrained
4972 -- Unchecked_Union subtype.
4974 -----------------------------------
4975 -- Component_Is_Unconstrained_UU --
4976 -----------------------------------
4978 function Component_Is_Unconstrained_UU
4980 is
4981 begin
4986 declare
4990 begin
4991 -- Unconstrained nominal type. In the case of a constraint
4992 -- present, the node kind would have been N_Subtype_Indication.
5002 ---------------------------------
5003 -- Variant_Is_Unconstrained_UU --
5004 ---------------------------------
5006 function Variant_Is_Unconstrained_UU
5008 is
5011 begin
5016 -- We only need to test one component
5018 declare
5021 begin
5031 -- None of the components withing the variant were of
5032 -- unconstrained Unchecked_Union type.
5037 -- Start of processing for Has_Unconstrained_UU_Component
5039 begin
5047 -- Inspect available components
5050 declare
5053 begin
5056 -- One component is sufficent
5067 -- Inspect available components withing variants
5070 declare
5073 begin
5076 -- One component within a variant is sufficent
5087 -- Neither the available components, nor the components inside the
5088 -- variant parts were of an unconstrained Unchecked_Union subtype.
5093 -- Start of processing for Expand_N_Op_Eq
5095 begin
5102 else
5106 -- It may happen in error situations that the underlying type is not
5107 -- set. The error will be detected later, here we just defend the
5108 -- expander code.
5116 -- Boolean types (requiring handling of non-standard case)
5124 -- Array types
5128 -- If we are doing full validity checking, then expand out array
5129 -- comparisons to make sure that we check the array elements.
5132 declare
5134 Force_Validity_Checks;
5135 begin
5138 Expand_Array_Equality
5142 Bodies,
5143 Typl));
5149 -- Packed case where both operands are known aligned
5154 then
5157 -- Where the component type is elementary we can use a block bit
5158 -- comparison (if supported on the target) exception in the case
5159 -- of floating-point (negative zero issues require element by
5160 -- element comparison), and atomic types (where we must be sure
5161 -- to load elements independently) and possibly unaligned arrays.
5168 and then Support_Composite_Compare_On_Target
5169 then
5172 -- For composite and floating-point cases, expand equality loop
5173 -- to make sure of using proper comparisons for tagged types,
5174 -- and correctly handling the floating-point case.
5176 else
5178 Expand_Array_Equality
5182 Bodies,
5183 Typl));
5188 -- Record Types
5192 -- For tagged types, use the primitive "="
5196 -- No need to do anything else compiling under restriction
5197 -- No_Dispatching_Calls. During the semantic analysis we
5198 -- already notified such violation.
5204 -- If this is derived from an untagged private type completed
5205 -- with a tagged type, it does not have a full view, so we
5206 -- use the primitive operations of the private type.
5207 -- This check should no longer be necessary when these
5208 -- types receive their full views ???
5214 then
5215 -- Search for equality operation, checking that the
5216 -- operands have the same type. Note that we must find
5217 -- a matching entry, or something is very wrong!
5225 and then
5234 -- Find the type's predefined equality or an overriding
5235 -- user-defined equality. The reason for not simply calling
5236 -- Find_Prim_Op here is that there may be a user-defined
5237 -- overloaded equality op that precedes the equality that
5238 -- we want, so we have to explicitly search (e.g., there
5239 -- could be an equality with two different parameter types).
5241 else
5251 and then
5263 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
5264 -- predefined equality operator for a type which has a subcomponent
5265 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
5272 -- Prevent Gigi from generating incorrect code by rewriting the
5273 -- equality as a standard False.
5280 -- If we can infer the discriminants of the operands, we make a
5281 -- call to the TSS equality function.
5284 and then
5286 then
5287 Build_Equality_Call
5290 else
5291 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5292 -- the predefined equality operator for an Unchecked_Union type
5293 -- if either of the operands lack inferable discriminants.
5299 -- Prevent Gigi from generating incorrect code by rewriting
5300 -- the equality as a standard False.
5307 -- If a type support function is present (for complex cases), use it
5310 Build_Equality_Call
5313 -- Otherwise expand the component by component equality. Note that
5314 -- we never use block-bit coparisons for records, because of the
5315 -- problems with gaps. The backend will often be able to recombine
5316 -- the separate comparisons that we generate here.
5318 else
5329 -- Test if result is known at compile time
5333 -- If we still have comparison for Vax_Float, process it
5341 -----------------------
5342 -- Expand_N_Op_Expon --
5343 -----------------------
5361 begin
5364 -- If either operand is of a private type, then we have the use of
5365 -- an intrinsic operator, and we get rid of the privateness, by using
5366 -- root types of underlying types for the actual operation. Otherwise
5367 -- the private types will cause trouble if we expand multiplications
5368 -- or shifts etc. We also do this transformation if the result type
5369 -- is different from the base type.
5372 or else
5374 or else
5376 or else
5378 then
5379 declare
5383 begin
5394 -- Test for case of known right argument
5399 -- We only fold small non-negative exponents. You might think we
5400 -- could fold small negative exponents for the real case, but we
5401 -- can't because we are required to raise Constraint_Error for
5402 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
5403 -- See ACVC test C4A012B.
5407 -- X ** 0 = 1 (or 1.0)
5412 else
5416 -- X ** 1 = X
5421 -- X ** 2 = X * X
5424 Xnode :=
5429 -- X ** 3 = X * X * X
5432 Xnode :=
5434 Left_Opnd =>
5440 -- X ** 4 ->
5441 -- En : constant base'type := base * base;
5442 -- ...
5443 -- En * En
5446 Temp :=
5454 Expression =>
5459 Xnode :=
5471 -- Case of (2 ** expression) appearing as an argument of an integer
5472 -- multiplication, or as the right argument of a division of a non-
5473 -- negative integer. In such cases we leave the node untouched, setting
5474 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
5475 -- of the higher level node converts it into a shift.
5482 and then not Ovflo
5484 then
5485 declare
5490 begin
5492 and then
5494 or else
5498 or else
5504 then
5511 -- Fall through if exponentiation must be done using a runtime routine
5513 -- First deal with modular case
5517 -- Non-binary case, we call the special exponentiation routine for
5518 -- the non-binary case, converting the argument to Long_Long_Integer
5519 -- and passing the modulus value. Then the result is converted back
5520 -- to the base type.
5530 Exp))));
5532 -- Binary case, in this case, we call one of two routines, either
5533 -- the unsigned integer case, or the unsigned long long integer
5534 -- case, with a final "and" operation to do the required mod.
5536 else
5539 else
5546 Left_Opnd =>
5551 Exp)),
5552 Right_Opnd =>
5557 -- Common exit point for modular type case
5562 -- Signed integer cases, done using either Integer or Long_Long_Integer.
5563 -- It is not worth having routines for Short_[Short_]Integer, since for
5564 -- most machines it would not help, and it would generate more code that
5565 -- might need certification when a certified run time is required.
5567 -- In the integer cases, we have two routines, one for when overflow
5568 -- checks are required, and one when they are not required, since there
5569 -- is a real gain in omitting checks on many machines.
5573 and then
5576 then
5581 else
5590 else
5594 -- Floating-point cases, always done using Long_Long_Float. We do not
5595 -- need separate routines for the overflow case here, since in the case
5596 -- of floating-point, we generate infinities anyway as a rule (either
5597 -- that or we automatically trap overflow), and if there is an infinity
5598 -- generated and a range check is required, the check will fail anyway.
5600 else
5606 -- Common processing for integer cases and floating-point cases.
5607 -- If we are in the right type, we can call runtime routine directly
5612 then
5618 -- Otherwise we have to introduce conversions (conversions are also
5619 -- required in the universal cases, since the runtime routine is
5620 -- typed using one of the standard types.
5622 else
5629 Exp))));
5635 exception
5640 --------------------
5641 -- Expand_N_Op_Ge --
5642 --------------------
5650 begin
5667 -- If we still have comparison, and Vax_Float type, process it
5675 --------------------
5676 -- Expand_N_Op_Gt --
5677 --------------------
5685 begin
5702 -- If we still have comparison, and Vax_Float type, process it
5710 --------------------
5711 -- Expand_N_Op_Le --
5712 --------------------
5720 begin
5737 -- If we still have comparison, and Vax_Float type, process it
5745 --------------------
5746 -- Expand_N_Op_Lt --
5747 --------------------
5755 begin
5772 -- If we still have comparison, and Vax_Float type, process it
5780 -----------------------
5781 -- Expand_N_Op_Minus --
5782 -----------------------
5788 begin
5791 if not Backend_Overflow_Checks_On_Target
5794 then
5795 -- Software overflow checking expands -expr into (0 - expr)
5804 -- Vax floating-point types case
5811 ---------------------
5812 -- Expand_N_Op_Mod --
5813 ---------------------
5831 begin
5837 -- Convert mod to rem if operands are known non-negative. We do this
5838 -- since it is quite likely that this will improve the quality of code,
5839 -- (the operation now corresponds to the hardware remainder), and it
5840 -- does not seem likely that it could be harmful.
5843 and then
5845 then
5851 -- Instead of reanalyzing the node we do the analysis manually.
5852 -- This avoids anomalies when the replacement is done in an
5853 -- instance and is epsilon more efficient.
5862 -- Otherwise, normal mod processing
5864 else
5869 -- Apply optimization x mod 1 = 0. We don't really need that with
5870 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5871 -- certainly harmless.
5876 then
5882 -- Deal with annoying case of largest negative number remainder
5883 -- minus one. Gigi does not handle this case correctly, because
5884 -- it generates a divide instruction which may trap in this case.
5886 -- In fact the check is quite easy, if the right operand is -1,
5887 -- then the mod value is always 0, and we can just ignore the
5888 -- left operand completely in this case.
5890 -- The operand type may be private (e.g. in the expansion of an
5891 -- an intrinsic operation) so we must use the underlying type to
5892 -- get the bounds, and convert the literals explicitly.
5894 LLB :=
5895 Expr_Value
5899 and then
5901 then
5907 Right_Opnd =>
5920 --------------------------
5921 -- Expand_N_Op_Multiply --
5922 --------------------------
5941 begin
5944 -- Special optimizations for integer types
5948 -- N * 0 = 0 * N = 0 for integer types
5952 or else
5955 then
5961 -- N * 1 = 1 * N = N for integer types
5963 -- This optimisation is not done if we are going to
5964 -- rewrite the product 1 * 2 ** N to a shift.
5968 and then not Lp2
5969 then
5975 and then not Rp2
5976 then
5982 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5983 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5984 -- operand is an integer, as required for this to work.
5989 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
5994 Right_Opnd =>
6001 else
6005 Right_Opnd =>
6011 -- Same processing for the operands the other way round
6017 Right_Opnd =>
6023 -- Do required fixup of universal fixed operation
6030 -- Multiplications with fixed-point results
6034 -- No special processing if Treat_Fixed_As_Integer is set,
6035 -- since from a semantic point of view such operations are
6036 -- simply integer operations and will be treated that way.
6040 -- Case of fixed * integer => fixed
6045 -- Case of integer * fixed => fixed
6050 -- Case of fixed * fixed => fixed
6052 else
6057 -- Other cases of multiplication of fixed-point operands. Again
6058 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
6062 then
6065 else
6070 -- Mixed-mode operations can appear in a non-static universal
6071 -- context, in which case the integer argument must be converted
6072 -- explicitly.
6076 then
6083 then
6088 -- Non-fixed point cases, check software overflow checking required
6093 -- Deal with VAX float case
6101 --------------------
6102 -- Expand_N_Op_Ne --
6103 --------------------
6108 begin
6109 -- Case of elementary type with standard operator
6113 then
6116 -- Boolean types (requiring handling of non-standard case)
6127 -- If we still have comparison for Vax_Float, process it
6134 -- For all cases other than elementary types, we rewrite node as the
6135 -- negation of an equality operation, and reanalyze. The equality to be
6136 -- used is defined in the same scope and has the same signature. This
6137 -- signature must be set explicitly since in an instance it may not have
6138 -- the same visibility as in the generic unit. This avoids duplicating
6139 -- or factoring the complex code for record/array equality tests etc.
6141 else
6142 declare
6147 begin
6150 Neg :=
6152 Right_Opnd =>
6162 -- For navigation purposes, the inequality is treated as an
6163 -- implicit reference to the corresponding equality. Preserve the
6164 -- Comes_From_ source flag so that the proper Xref entry is
6165 -- generated.
6175 ---------------------
6176 -- Expand_N_Op_Not --
6177 ---------------------
6179 -- If the argument is other than a Boolean array type, there is no
6180 -- special expansion required.
6182 -- For the packed case, we call the special routine in Exp_Pakd, except
6183 -- that if the component size is greater than one, we use the standard
6184 -- routine generating a gruesome loop (it is so peculiar to have packed
6185 -- arrays with non-standard Boolean representations anyway, so it does
6186 -- not matter that we do not handle this case efficiently).
6188 -- For the unpacked case (and for the special packed case where we have
6189 -- non standard Booleans, as discussed above), we generate and insert
6190 -- into the tree the following function definition:
6192 -- function Nnnn (A : arr) is
6193 -- B : arr;
6194 -- begin
6195 -- for J in a'range loop
6196 -- B (J) := not A (J);
6197 -- end loop;
6198 -- return B;
6199 -- end Nnnn;
6201 -- Here arr is the actual subtype of the parameter (and hence always
6202 -- constrained). Then we replace the not with a call to this function.
6218 begin
6221 -- For boolean operand, deal with non-standard booleans
6230 -- Only array types need any other processing
6236 -- Case of array operand. If bit packed with a component size of 1,
6237 -- handle it in Exp_Pakd if the operand is known to be aligned.
6242 then
6247 -- Case of array operand which is not bit-packed. If the context is
6248 -- a safe assignment, call in-place operation, If context is a larger
6249 -- boolean expression in the context of a safe assignment, expansion is
6250 -- done by enclosing operation.
6262 -- Special case the negation of a binary operation
6267 and then Safe_In_Place_Array_Op
6269 then
6276 then
6277 declare
6282 begin
6286 then
6287 -- (not A) op (not B) can be reduced to a single call
6293 then
6294 -- A xor (not B) can also be special-cased
6306 A_J :=
6311 B_J :=
6316 Loop_Statement :=
6320 Iteration_Scheme =>
6322 Loop_Parameter_Specification =>
6325 Discrete_Subtype_Definition =>
6340 Specification =>
6354 Handled_Statement_Sequence =>
6357 Loop_Statement,
6359 Expression =>
6370 --------------------
6371 -- Expand_N_Op_Or --
6372 --------------------
6377 begin
6391 ----------------------
6392 -- Expand_N_Op_Plus --
6393 ----------------------
6396 begin
6400 ---------------------
6401 -- Expand_N_Op_Rem --
6402 ---------------------
6419 begin
6426 -- Apply optimization x rem 1 = 0. We don't really need that with
6427 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
6428 -- certainly harmless.
6433 then
6439 -- Deal with annoying case of largest negative number remainder
6440 -- minus one. Gigi does not handle this case correctly, because
6441 -- it generates a divide instruction which may trap in this case.
6443 -- In fact the check is quite easy, if the right operand is -1,
6444 -- then the remainder is always 0, and we can just ignore the
6445 -- left operand completely in this case.
6450 -- The operand type may be private (e.g. in the expansion of an
6451 -- an intrinsic operation) so we must use the underlying type to
6452 -- get the bounds, and convert the literals explicitly.
6454 LLB :=
6455 Expr_Value
6458 -- Now perform the test, generating code only if needed
6461 and then
6463 then
6469 Right_Opnd =>
6483 -----------------------------
6484 -- Expand_N_Op_Rotate_Left --
6485 -----------------------------
6488 begin
6492 ------------------------------
6493 -- Expand_N_Op_Rotate_Right --
6494 ------------------------------
6497 begin
6501 ----------------------------
6502 -- Expand_N_Op_Shift_Left --
6503 ----------------------------
6506 begin
6510 -----------------------------
6511 -- Expand_N_Op_Shift_Right --
6512 -----------------------------
6515 begin
6519 ----------------------------------------
6520 -- Expand_N_Op_Shift_Right_Arithmetic --
6521 ----------------------------------------
6524 begin
6528 --------------------------
6529 -- Expand_N_Op_Subtract --
6530 --------------------------
6535 begin
6538 -- N - 0 = N for integer types
6543 then
6548 -- Arithemtic overflow checks for signed integer/fixed point types
6552 then
6555 -- Vax floating-point types case
6562 ---------------------
6563 -- Expand_N_Op_Xor --
6564 ---------------------
6569 begin
6583 ----------------------
6584 -- Expand_N_Or_Else --
6585 ----------------------
6587 -- Expand into conditional expression if Actions present, and also
6588 -- deal with optimizing case of arguments being True or False.
6597 begin
6598 -- Deal with non-standard booleans
6606 -- Check for cases of left argument is True or False
6610 -- If left argument is False, change (False or else Right) to Right.
6611 -- Any actions associated with Right will be executed unconditionally
6612 -- and can thus be inserted into the tree unconditionally.
6623 -- If left argument is True, change (True and then Right) to
6624 -- True. In this case we can forget the actions associated with
6625 -- Right, since they will never be executed.
6636 -- If Actions are present, we expand
6638 -- left or else right
6640 -- into
6642 -- if left then True else right end
6644 -- with the actions becoming the Else_Actions of the conditional
6645 -- expression. This conditional expression is then further expanded
6646 -- (and will eventually disappear)
6653 Left,
6655 Right)));
6663 -- No actions present, check for cases of right argument True/False
6667 -- Change (Left or else False) to Left. Note that we know there
6668 -- are no actions associated with the True operand, since we
6669 -- just checked for this case above.
6674 -- Change (Left or else True) to True, making sure to preserve
6675 -- any side effects associated with the Left operand.
6679 Rewrite
6687 -----------------------------------
6688 -- Expand_N_Qualified_Expression --
6689 -----------------------------------
6695 begin
6696 -- Do validity check if validity checking operands
6698 if Validity_Checks_On
6699 and then Validity_Check_Operands
6700 then
6704 -- Apply possible constraint check
6709 ---------------------------------
6710 -- Expand_N_Selected_Component --
6711 ---------------------------------
6713 -- If the selector is a discriminant of a concurrent object, rewrite the
6714 -- prefix to denote the corresponding record type.
6726 -- Gigi needs a temporary for prefixes that depend on a discriminant,
6727 -- unless the context of an assignment can provide size information.
6728 -- Don't we have a general routine that does this???
6730 -----------------------
6731 -- In_Left_Hand_Side --
6732 -----------------------
6735 begin
6743 -- Start of processing for Expand_N_Selected_Component
6745 begin
6746 -- Insert explicit dereference if required
6754 then
6761 -- Deal with discriminant check required
6765 -- Present the discrminant checking function to the backend,
6766 -- so that it can inline the call to the function.
6768 Add_Inlined_Body
6769 (Discriminant_Checking_Func
6772 -- Now reset the flag and generate the call
6778 -- Gigi cannot handle unchecked conversions that are the prefix of a
6779 -- selected component with discriminants. This must be checked during
6780 -- expansion, because during analysis the type of the selector is not
6781 -- known at the point the prefix is analyzed. If the conversion is the
6782 -- target of an assignment, then we cannot force the evaluation.
6787 then
6791 -- Remaining processing applies only if selector is a discriminant
6795 -- If the selector is a discriminant of a constrained record type,
6796 -- we may be able to rewrite the expression with the actual value
6797 -- of the discriminant, a useful optimization in some cases.
6802 then
6803 -- Do this optimization for discrete types only, and not for
6804 -- access types (access discriminants get us into trouble!)
6809 -- Don't do this on the left hand of an assignment statement.
6810 -- Normally one would think that references like this would
6811 -- not occur, but they do in generated code, and mean that
6812 -- we really do want to assign the discriminant!
6816 then
6819 -- Don't do this optimization for the prefix of an attribute
6820 -- or the operand of an object renaming declaration since these
6821 -- are contexts where we do not want the value anyway.
6826 then
6829 -- Don't do this optimization if we are within the code for a
6830 -- discriminant check, since the whole point of such a check may
6831 -- be to verify the condition on which the code below depends!
6836 -- Green light to see if we can do the optimization. There is
6837 -- still one condition that inhibits the optimization below
6838 -- but now is the time to check the particular discriminant.
6840 else
6841 -- Loop through discriminants to find the matching
6842 -- discriminant constraint to see if we can copy it.
6848 -- Check if this is the matching discriminant
6852 -- Here we have the matching discriminant. Check for
6853 -- the case of a discriminant of a component that is
6854 -- constrained by an outer discriminant, which cannot
6855 -- be optimized away.
6857 if
6858 Denotes_Discriminant
6860 then
6863 -- In the context of a case statement, the expression
6864 -- may have the base type of the discriminant, and we
6865 -- need to preserve the constraint to avoid spurious
6866 -- errors on missing cases.
6870 then
6873 Subtype_Mark =>
6875 Expression =>
6879 -- In case that comes out as a static expression,
6880 -- reset it (a selected component is never static).
6885 -- Otherwise we can just copy the constraint, but the
6886 -- result is certainly not static! In some cases the
6887 -- discriminant constraint has been analyzed in the
6888 -- context of the original subtype indication, but for
6889 -- itypes the constraint might not have been analyzed
6890 -- yet, and this must be done now.
6892 else
6904 -- Note: the above loop should always find a matching
6905 -- discriminant, but if it does not, we just missed an
6906 -- optimization due to some glitch (perhaps a previous
6907 -- error), so ignore.
6912 -- The only remaining processing is in the case of a discriminant of
6913 -- a concurrent object, where we rewrite the prefix to denote the
6914 -- corresponding record type. If the type is derived and has renamed
6915 -- discriminants, use corresponding discriminant, which is the one
6916 -- that appears in the corresponding record.
6926 then
6930 New_N :=
6932 Prefix =>
6942 --------------------
6943 -- Expand_N_Slice --
6944 --------------------
6953 -- Check whether the argument is an actual for a procedure call,
6954 -- in which case the expansion of a bit-packed slice is deferred
6955 -- until the call itself is expanded. The reason this is required
6956 -- is that we might have an IN OUT or OUT parameter, and the copy out
6957 -- is essential, and that copy out would be missed if we created a
6958 -- temporary here in Expand_N_Slice. Note that we don't bother
6959 -- to test specifically for an IN OUT or OUT mode parameter, since it
6960 -- is a bit tricky to do, and it is harmless to defer expansion
6961 -- in the IN case, since the call processing will still generate the
6962 -- appropriate copy in operation, which will take care of the slice.
6965 -- Create a named variable for the value of the slice, in
6966 -- cases where the back-end cannot handle it properly, e.g.
6967 -- when packed types or unaligned slices are involved.
6969 -------------------------
6970 -- Is_Procedure_Actual --
6971 -------------------------
6976 begin
6977 loop
6978 -- If our parent is a procedure call we can return
6983 -- If our parent is a type conversion, keep climbing the
6984 -- tree, since a type conversion can be a procedure actual.
6985 -- Also keep climbing if parameter association or a qualified
6986 -- expression, since these are additional cases that do can
6987 -- appear on procedure actuals.
6992 then
6995 -- Any other case is not what we are looking for
6997 else
7003 --------------------
7004 -- Make_Temporary --
7005 --------------------
7011 begin
7012 Decl :=
7020 Decl,
7029 -- Start of processing for Expand_N_Slice
7031 begin
7032 -- Special handling for access types
7045 -- Range checks are potentially also needed for cases involving
7046 -- a slice indexed by a subtype indication, but Do_Range_Check
7047 -- can currently only be set for expressions ???
7054 -- Do not enable range check to nodes associated with the frontend
7055 -- expansion of the dispatch table. We first check if Ada.Tags is
7056 -- already loaded to avoid the addition of an undesired dependence
7057 -- on such run-time unit.
7059 and then
7061 or else not
7067 then
7071 -- The remaining case to be handled is packed slices. We can leave
7072 -- packed slices as they are in the following situations:
7074 -- 1. Right or left side of an assignment (we can handle this
7075 -- situation correctly in the assignment statement expansion).
7077 -- 2. Prefix of indexed component (the slide is optimized away
7078 -- in this case, see the start of Expand_N_Slice.)
7080 -- 3. Object renaming declaration, since we want the name of
7081 -- the slice, not the value.
7083 -- 4. Argument to procedure call, since copy-in/copy-out handling
7084 -- may be required, and this is handled in the expansion of
7085 -- call itself.
7087 -- 5. Prefix of an address attribute (this is an error which
7088 -- is caught elsewhere, and the expansion would intefere
7089 -- with generating the error message).
7093 -- Apply transformation for actuals of a function call,
7094 -- where Expand_Actuals is not used.
7098 then
7099 Make_Temporary;
7105 then
7111 then
7116 then
7119 else
7120 Make_Temporary;
7124 ------------------------------
7125 -- Expand_N_Type_Conversion --
7126 ------------------------------
7135 -- This is called in the case of record and array type conversions
7136 -- to see if there is a change of representation to be handled.
7137 -- Change of representation is actually handled at the assignment
7138 -- statement level, and what this procedure does is rewrite node N
7139 -- conversion as an assignment to temporary. If there is no change
7140 -- of representation, then the conversion node is unchanged.
7143 -- Handles generation of range check for real target value
7145 -----------------------------------
7146 -- Handle_Changed_Representation --
7147 -----------------------------------
7157 begin
7158 -- Nothing else to do if no change of representation
7163 -- The real change of representation work is done by the assignment
7164 -- statement processing. So if this type conversion is appearing as
7165 -- the expression of an assignment statement, nothing needs to be
7166 -- done to the conversion.
7171 -- Otherwise we need to generate a temporary variable, and do the
7172 -- change of representation assignment into that temporary variable.
7173 -- The conversion is then replaced by a reference to this variable.
7175 else
7178 -- If type is unconstrained we have to add a constraint,
7179 -- copied from the actual value of the left hand side.
7194 Selector_Name =>
7205 -- We convert the bounds explicitly. We use an unchecked
7206 -- conversion because bounds checks are done elsewhere.
7210 Low_Bound =>
7213 Prefix =>
7214 Duplicate_Subexpr_No_Checks
7220 High_Bound =>
7223 Prefix =>
7224 Duplicate_Subexpr_No_Checks
7238 Odef :=
7241 Constraint =>
7247 Decl :=
7254 -- Insert required actions. It is essential to suppress checks
7255 -- since we have suppressed default initialization, which means
7256 -- that the variable we create may have no discriminants.
7259 New_List (
7260 Decl,
7271 ----------------------
7272 -- Real_Range_Check --
7273 ----------------------
7275 -- Case of conversions to floating-point or fixed-point. If range
7276 -- checks are enabled and the target type has a range constraint,
7277 -- we convert:
7279 -- typ (x)
7281 -- to
7283 -- Tnn : typ'Base := typ'Base (x);
7284 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7285 -- Tnn
7287 -- This is necessary when there is a conversion of integer to float
7288 -- or to fixed-point to ensure that the correct checks are made. It
7289 -- is not necessary for float to float where it is enough to simply
7290 -- set the Do_Range_Check flag.
7300 begin
7301 -- Nothing to do if conversion was rewritten
7307 -- Nothing to do if range checks suppressed, or target has the
7308 -- same range as the base type (or is the base type).
7312 and then
7314 then
7318 -- Nothing to do if expression is an entity on which checks
7319 -- have been suppressed.
7323 then
7327 -- Nothing to do if bounds are all static and we can tell that
7328 -- the expression is within the bounds of the target. Note that
7329 -- if the operand is of an unconstrained floating-point type,
7330 -- then we do not trust it to be in range (might be infinite)
7332 declare
7336 begin
7343 then
7344 declare
7350 begin
7354 else
7362 then
7370 -- For float to float conversions, we are done
7373 and then
7375 then
7379 -- Otherwise rewrite the conversion as described above
7382 Rewrite
7386 -- Enable overflow except for case of integer to float conversions,
7387 -- where it is never required, since we can never have overflow in
7388 -- this case.
7394 Tnn :=
7405 Condition =>
7407 Left_Opnd =>
7410 Right_Opnd =>
7413 Prefix =>
7416 Right_Opnd =>
7419 Right_Opnd =>
7422 Prefix =>
7430 -- Start of processing for Expand_N_Type_Conversion
7432 begin
7433 -- Nothing at all to do if conversion is to the identical type
7434 -- so remove the conversion completely, it is useless.
7441 -- Nothing to do if this is the second argument of read. This
7442 -- is a "backwards" conversion that will be handled by the
7443 -- specialized code in attribute processing.
7448 then
7452 -- Here if we may need to expand conversion
7454 -- Do validity check if validity checking operands
7456 if Validity_Checks_On
7457 and then Validity_Check_Operands
7458 then
7462 -- Special case of converting from non-standard boolean type
7466 then
7472 -- Case of converting to an access type
7476 -- Apply an accessibility check when the conversion operand is an
7477 -- access parameter (or a renaming thereof), unless conversion was
7478 -- expanded from an unchecked or unrestricted access attribute. Note
7479 -- that other checks may still need to be applied below (such as
7480 -- tagged type checks).
7483 and then
7485 or else
7488 and then Is_Formal
7493 then
7496 -- If the level of the operand type is statically deeper
7497 -- then the level of the target type, then force Program_Error.
7498 -- Note that this can only occur for cases where the attribute
7499 -- is within the body of an instantiation (otherwise the
7500 -- conversion will already have been rejected as illegal).
7501 -- Note: warnings are issued by the analyzer for the instance
7502 -- cases.
7504 elsif In_Instance_Body
7507 then
7513 -- When the operand is a selected access discriminant
7514 -- the check needs to be made against the level of the
7515 -- object denoted by the prefix of the selected name.
7516 -- Force Program_Error for this case as well (this
7517 -- accessibility violation can only happen if within
7518 -- the body of an instantiation).
7520 elsif In_Instance_Body
7525 then
7533 -- Case of conversions of tagged types and access to tagged types
7535 -- When needed, that is to say when the expression is class-wide,
7536 -- Add runtime a tag check for (strict) downward conversion by using
7537 -- the membership test, generating:
7539 -- [constraint_error when Operand not in Target_Type'Class]
7541 -- or in the access type case
7543 -- [constraint_error
7544 -- when Operand /= null
7545 -- and then Operand.all not in
7546 -- Designated_Type (Target_Type)'Class]
7551 then
7552 -- Do not do any expansion in the access type case if the
7553 -- parent is a renaming, since this is an error situation
7554 -- which will be caught by Sem_Ch8, and the expansion can
7555 -- intefere with this error check.
7559 then
7563 -- Otherwise, proceed with processing tagged conversion
7565 declare
7571 begin
7576 else
7581 -- Ada 2005 (AI-251): Handle interface type conversion
7590 and then Is_Ancestor
7592 Actual_Target_Type)
7594 then
7595 -- The conversion is valid for any descendant of the
7596 -- target type
7601 Cond :=
7603 Left_Opnd =>
7608 Right_Opnd =>
7610 Left_Opnd =>
7612 Prefix =>
7614 Right_Opnd =>
7617 else
7618 Cond :=
7621 Right_Opnd =>
7630 declare
7632 begin
7633 Conv :=
7643 -- Case of other access type conversions
7648 -- Case of conversions from a fixed-point type
7650 -- These conversions require special expansion and processing, found
7651 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
7652 -- set, since from a semantic point of view, these are simple integer
7653 -- conversions, which do not need further processing.
7657 then
7658 -- We should never see universal fixed at this case, since the
7659 -- expansion of the constituent divide or multiply should have
7660 -- eliminated the explicit mention of universal fixed.
7664 -- Check for special case of the conversion to universal real
7665 -- that occurs as a result of the use of a round attribute.
7666 -- In this case, the real type for the conversion is taken
7667 -- from the target type of the Round attribute and the
7668 -- result must be marked as rounded.
7673 then
7678 -- Otherwise do correct fixed-conversion, but skip these if the
7679 -- Conversion_OK flag is set, because from a semantic point of
7680 -- view these are simple integer conversions needing no further
7681 -- processing (the backend will simply treat them as integers)
7686 Real_Range_Check;
7691 else
7694 Real_Range_Check;
7698 -- Case of conversions to a fixed-point type
7700 -- These conversions require special expansion and processing, found
7701 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
7702 -- is set, since from a semantic point of view, these are simple
7703 -- integer conversions, which do not need further processing.
7707 then
7710 Real_Range_Check;
7711 else
7714 Real_Range_Check;
7717 -- Case of float-to-integer conversions
7719 -- We also handle float-to-fixed conversions with Conversion_OK set
7720 -- since semantically the fixed-point target is treated as though it
7721 -- were an integer in such cases.
7724 and then
7726 or else
7728 then
7729 -- One more check here, gcc is still not able to do conversions of
7730 -- this type with proper overflow checking, and so gigi is doing an
7731 -- approximation of what is required by doing floating-point compares
7732 -- with the end-point. But that can lose precision in some cases, and
7733 -- give a wrong result. Converting the operand to Universal_Real is
7734 -- helpful, but still does not catch all cases with 64-bit integers
7735 -- on targets with only 64-bit floats
7737 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
7738 -- Can this code be removed ???
7743 Subtype_Mark =>
7745 Expression =>
7753 -- Case of array conversions
7755 -- Expansion of array conversions, add required length/range checks
7756 -- but only do this if there is no change of representation. For
7757 -- handling of this case, see Handle_Changed_Representation.
7763 else
7767 Handle_Changed_Representation;
7769 -- Case of conversions of discriminated types
7771 -- Add required discriminant checks if target is constrained. Again
7772 -- this change is skipped if we have a change of representation.
7776 then
7778 Handle_Changed_Representation;
7780 -- Case of all other record conversions. The only processing required
7781 -- is to check for a change of representation requiring the special
7782 -- assignment processing.
7786 -- Ada 2005 (AI-216): Program_Error is raised when converting from
7787 -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
7788 -- Union type if the operand lacks inferable discriminants.
7795 then
7796 -- To prevent Gigi from generating illegal code, we make a
7797 -- Program_Error node, but we give it the target type of the
7798 -- conversion.
7800 declare
7804 begin
7809 else
7810 Handle_Changed_Representation;
7813 -- Case of conversions of enumeration types
7817 -- Special processing is required if there is a change of
7818 -- representation (from enumeration representation clauses)
7822 -- Convert: x(y) to x'val (ytyp'val (y))
7837 -- Case of conversions to floating-point
7840 Real_Range_Check;
7843 -- At this stage, either the conversion node has been transformed
7844 -- into some other equivalent expression, or left as a conversion
7845 -- that can be handled by Gigi. The conversions that Gigi can handle
7846 -- are the following:
7848 -- Conversions with no change of representation or type
7850 -- Numeric conversions involving integer values, floating-point
7851 -- values, and fixed-point values. Fixed-point values are allowed
7852 -- only if Conversion_OK is set, i.e. if the fixed-point values
7853 -- are to be treated as integers.
7855 -- No other conversions should be passed to Gigi
7857 -- Check: are these rules stated in sinfo??? if so, why restate here???
7859 -- The only remaining step is to generate a range check if we still
7860 -- have a type conversion at this stage and Do_Range_Check is set.
7861 -- For now we do this only for conversions of discrete types.
7865 then
7866 declare
7871 begin
7874 then
7877 -- Before we do a range check, we have to deal with treating
7878 -- a fixed-point operand as an integer. The way we do this
7879 -- is simply to do an unchecked conversion to an appropriate
7880 -- integer type large enough to hold the result.
7882 -- This code is not active yet, because we are only dealing
7883 -- with discrete types so far ???
7887 then
7892 else
7899 -- Reset overflow flag, since the range check will include
7900 -- dealing with possible overflow, and generate the check
7901 -- If Address is either source or target type, suppress
7902 -- range check to avoid typing anomalies when it is a visible
7903 -- integer type.
7908 then
7909 Generate_Range_Check
7916 -- Final step, if the result is a type conversion involving Vax_Float
7917 -- types, then it is subject for further special processing.
7921 then
7927 -----------------------------------
7928 -- Expand_N_Unchecked_Expression --
7929 -----------------------------------
7931 -- Remove the unchecked expression node from the tree. It's job was simply
7932 -- to make sure that its constituent expression was handled with checks
7933 -- off, and now that that is done, we can remove it from the tree, and
7934 -- indeed must, since gigi does not expect to see these nodes.
7939 begin
7944 ----------------------------------------
7945 -- Expand_N_Unchecked_Type_Conversion --
7946 ----------------------------------------
7948 -- If this cannot be handled by Gigi and we haven't already made
7949 -- a temporary for it, do it now.
7956 begin
7957 -- If we have a conversion of a compile time known value to a target
7958 -- type and the value is in range of the target type, then we can simply
7959 -- replace the construct by an integer literal of the correct type. We
7960 -- only apply this to integer types being converted. Possibly it may
7961 -- apply in other cases, but it is too much trouble to worry about.
7963 -- Note that we do not do this transformation if the Kill_Range_Check
7964 -- flag is set, since then the value may be outside the expected range.
7965 -- This happens in the Normalize_Scalars case.
7967 -- We also skip this if either the target or operand type is biased
7968 -- because in this case, the unchecked conversion is supposed to
7969 -- preserve the bit pattern, not the integer value.
7977 then
7978 declare
7981 begin
7983 and then
7985 and then
7987 and then
7989 then
7992 -- If Address is the target type, just set the type
7993 -- to avoid a spurious type error on the literal when
7994 -- Address is a visible integer type.
7998 else
8007 -- Nothing to do if conversion is safe
8013 -- Otherwise force evaluation unless Assignment_OK flag is set (this
8014 -- flag indicates ??? -- more comments needed here)
8018 else
8023 ----------------------------
8024 -- Expand_Record_Equality --
8025 ----------------------------
8027 -- For non-variant records, Equality is expanded when needed into:
8029 -- and then Lhs.Discr1 = Rhs.Discr1
8030 -- and then ...
8031 -- and then Lhs.Discrn = Rhs.Discrn
8032 -- and then Lhs.Cmp1 = Rhs.Cmp1
8033 -- and then ...
8034 -- and then Lhs.Cmpn = Rhs.Cmpn
8036 -- The expression is folded by the back-end for adjacent fields. This
8037 -- function is called for tagged record in only one occasion: for imple-
8038 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
8039 -- otherwise the primitive "=" is used directly.
8041 function Expand_Record_Equality
8047 is
8056 -- Return the first field to compare beginning with C, skipping the
8057 -- inherited components.
8059 ----------------------
8060 -- Suitable_Element --
8061 ----------------------
8064 begin
8070 then
8075 then
8080 then
8086 else
8091 -- Start of processing for Expand_Record_Equality
8093 begin
8094 -- Generates the following code: (assuming that Typ has one Discr and
8095 -- component C2 is also a record)
8097 -- True
8098 -- and then Lhs.Discr1 = Rhs.Discr1
8099 -- and then Lhs.C1 = Rhs.C1
8100 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8101 -- and then ...
8102 -- and then Lhs.Cmpn = Rhs.Cmpn
8108 declare
8113 begin
8118 else
8123 Check :=
8125 Lhs =>
8129 Rhs =>
8135 -- If some (sub)component is an unchecked_union, the whole
8136 -- operation will raise program error.
8142 else
8143 Result :=
8156 -------------------------------------
8157 -- Fixup_Universal_Fixed_Operation --
8158 -------------------------------------
8163 begin
8164 -- We must have a type conversion immediately above us
8168 -- Normally the type conversion gives our target type. The exception
8169 -- occurs in the case of the Round attribute, where the conversion
8170 -- will be to universal real, and our real type comes from the Round
8171 -- attribute (as well as an indication that we must round the result)
8175 then
8179 -- Normal case where type comes from conversion above us
8181 else
8186 ------------------------------
8187 -- Get_Allocator_Final_List --
8188 ------------------------------
8190 function Get_Allocator_Final_List
8194 is
8198 -- The entity whose finalization list must be used to attach the
8199 -- allocated object.
8201 begin
8204 -- If the context is an access parameter, we need to create a
8205 -- non-anonymous access type in order to have a usable final list,
8206 -- because there is otherwise no pool to which the allocated object
8207 -- can belong. We create both the type and the finalization chain
8208 -- here, because freezing an internal type does not create such a
8209 -- chain. The Final_Chain that is thus created is shared by the
8210 -- access parameter. The access type is tested against the result
8211 -- type of the function to exclude allocators whose type is an
8212 -- anonymous access result type.
8215 in N_Subprogram_Specification
8216 and then
8217 PtrT /=
8219 then
8224 Type_Definition =>
8226 Subtype_Indication =>
8232 -- Ada 2005 (AI-318-02): If the context is a return object
8233 -- declaration, then the anonymous return subtype is defined to have
8234 -- the same accessibility level as that of the function's result
8235 -- subtype, which means that we want the scope where the function is
8236 -- declared.
8240 then
8243 -- Case of an access discriminant, or (Ada 2005), of an anonymous
8244 -- access component or anonymous access function result: find the
8245 -- final list associated with the scope of the type. (In the
8246 -- anonymous access component kind, a list controller will have
8247 -- been allocated when freezing the record type, and PtrT has an
8248 -- Associated_Final_Chain attribute designating it.)
8258 ---------------------------------
8259 -- Has_Inferable_Discriminants --
8260 ---------------------------------
8265 -- Determines whether the left-most prefix of a selected component is a
8266 -- formal parameter in a subprogram. Assumes N is a selected component.
8268 --------------------------------
8269 -- Prefix_Is_Formal_Parameter --
8270 --------------------------------
8275 begin
8276 -- Move to the left-most prefix by climbing up the tree
8280 loop
8287 -- Start of processing for Has_Inferable_Discriminants
8289 begin
8290 -- For identifiers and indexed components, it is sufficent to have a
8291 -- constrained Unchecked_Union nominal subtype.
8294 or else
8296 then
8298 and then
8301 -- For selected components, the subtype of the selector must be a
8302 -- constrained Unchecked_Union. If the component is subject to a
8303 -- per-object constraint, then the enclosing object must have inferable
8304 -- discriminants.
8309 -- A small hack. If we have a per-object constrained selected
8310 -- component of a formal parameter, return True since we do not
8311 -- know the actual parameter association yet.
8317 -- Otherwise, check the enclosing object and the selector
8320 and then
8324 -- The call to Has_Inferable_Discriminants will determine whether
8325 -- the selector has a constrained Unchecked_Union nominal type.
8329 -- A qualified expression has inferable discriminants if its subtype
8330 -- mark is a constrained Unchecked_Union subtype.
8334 and then
8342 -------------------------------
8343 -- Insert_Dereference_Action --
8344 -------------------------------
8353 -- Return true if type of P is derived from Checked_Pool;
8355 -----------------------------
8356 -- Is_Checked_Storage_Pool --
8357 -----------------------------
8362 begin
8371 else
8379 -- Start of processing for Insert_Dereference_Action
8381 begin
8386 then
8397 -- Pool
8401 -- Storage_Address. We use the attribute Pool_Address,
8402 -- which uses the pointer itself to find the address of
8403 -- the object, and which handles unconstrained arrays
8404 -- properly by computing the address of the template.
8405 -- i.e. the correct address of the corresponding allocation.
8411 -- Size_In_Storage_Elements
8414 Left_Opnd =>
8416 Prefix =>
8420 Right_Opnd =>
8423 -- Alignment
8426 Prefix =>
8431 exception
8436 ------------------------------
8437 -- Make_Array_Comparison_Op --
8438 ------------------------------
8440 -- This is a hand-coded expansion of the following generic function:
8442 -- generic
8443 -- type elem is (<>);
8444 -- type index is (<>);
8445 -- type a is array (index range <>) of elem;
8447 -- function Gnnn (X : a; Y: a) return boolean is
8448 -- J : index := Y'first;
8450 -- begin
8451 -- if X'length = 0 then
8452 -- return false;
8454 -- elsif Y'length = 0 then
8455 -- return true;
8457 -- else
8458 -- for I in X'range loop
8459 -- if X (I) = Y (J) then
8460 -- if J = Y'last then
8461 -- exit;
8462 -- else
8463 -- J := index'succ (J);
8464 -- end if;
8466 -- else
8467 -- return X (I) > Y (J);
8468 -- end if;
8469 -- end loop;
8471 -- return X'length > Y'length;
8472 -- end if;
8473 -- end Gnnn;
8475 -- Note that since we are essentially doing this expansion by hand, we
8476 -- do not need to generate an actual or formal generic part, just the
8477 -- instantiated function itself.
8479 function Make_Array_Comparison_Op
8482 is
8503 begin
8504 -- if J = Y'last then
8505 -- exit;
8506 -- else
8507 -- J := index'succ (J);
8508 -- end if;
8510 Inner_If :=
8512 Condition =>
8515 Right_Opnd =>
8523 Else_Statements =>
8524 New_List (
8527 Expression =>
8533 -- if X (I) = Y (J) then
8534 -- if ... end if;
8535 -- else
8536 -- return X (I) > Y (J);
8537 -- end if;
8539 Loop_Body :=
8541 Condition =>
8543 Left_Opnd =>
8548 Right_Opnd =>
8557 Expression =>
8559 Left_Opnd =>
8564 Right_Opnd =>
8570 -- for I in X'range loop
8571 -- if ... end if;
8572 -- end loop;
8574 Loop_Statement :=
8578 Iteration_Scheme =>
8580 Loop_Parameter_Specification =>
8583 Discrete_Subtype_Definition =>
8590 -- if X'length = 0 then
8591 -- return false;
8592 -- elsif Y'length = 0 then
8593 -- return true;
8594 -- else
8595 -- for ... loop ... end loop;
8596 -- return X'length > Y'length;
8597 -- end if;
8599 Length1 :=
8604 Length2 :=
8609 Final_Expr :=
8614 If_Stat :=
8616 Condition =>
8618 Left_Opnd =>
8622 Right_Opnd =>
8625 Then_Statements =>
8626 New_List (
8632 Condition =>
8634 Left_Opnd =>
8638 Right_Opnd =>
8641 Then_Statements =>
8642 New_List (
8647 Loop_Statement,
8651 -- (X : a; Y: a)
8662 -- function Gnnn (...) return boolean is
8663 -- J : index := Y'first;
8664 -- begin
8665 -- if ... end if;
8666 -- end Gnnn;
8670 Func_Body :=
8672 Specification =>
8682 Expression =>
8687 Handled_Statement_Sequence =>
8694 ---------------------------
8695 -- Make_Boolean_Array_Op --
8696 ---------------------------
8698 -- For logical operations on boolean arrays, expand in line the
8699 -- following, replacing 'and' with 'or' or 'xor' where needed:
8701 -- function Annn (A : typ; B: typ) return typ is
8702 -- C : typ;
8703 -- begin
8704 -- for J in A'range loop
8705 -- C (J) := A (J) op B (J);
8706 -- end loop;
8707 -- return C;
8708 -- end Annn;
8710 -- Here typ is the boolean array type
8712 function Make_Boolean_Array_Op
8715 is
8733 begin
8734 A_J :=
8739 B_J :=
8744 C_J :=
8750 Op :=
8756 Op :=
8761 else
8762 Op :=
8768 Loop_Statement :=
8772 Iteration_Scheme =>
8774 Loop_Parameter_Specification =>
8777 Discrete_Subtype_Definition =>
8796 Func_Name :=
8800 Func_Body :=
8802 Specification =>
8813 Handled_Statement_Sequence =>
8816 Loop_Statement,
8823 ------------------------
8824 -- Rewrite_Comparison --
8825 ------------------------
8828 begin
8837 declare
8843 -- Res indicates if compare outcome can be compile time determined
8848 begin
8859 and then Constant_Condition_Warnings
8862 and then not In_Instance
8865 then
8866 Error_Msg_N
8883 and then Constant_Condition_Warnings
8886 and then not In_Instance
8889 then
8890 Error_Msg_N
8916 ----------------------------
8917 -- Safe_In_Place_Array_Op --
8918 ----------------------------
8920 function Safe_In_Place_Array_Op
8924 is
8928 -- Operand is safe if it cannot overlap part of the target of the
8929 -- operation. If the operand and the target are identical, the operand
8930 -- is safe. The operand can be empty in the case of negation.
8933 -- Check that N is a stand-alone entity
8935 ------------------
8936 -- Is_Unaliased --
8937 ------------------
8940 begin
8941 return
8947 ---------------------
8948 -- Is_Safe_Operand --
8949 ---------------------
8952 begin
8961 then
8965 return
8972 else
8977 -- Start of processing for Is_Safe_In_Place_Array_Op
8979 begin
8980 -- We skip this processing if the component size is not the
8981 -- same as a system storage unit (since at least for NOT
8982 -- this would cause problems).
8987 -- Cannot do in place stuff on VM_Target since cannot pass addresses
8992 -- Cannot do in place stuff if non-standard Boolean representation
8999 else
9002 return
9008 -----------------------
9009 -- Tagged_Membership --
9010 -----------------------
9012 -- There are two different cases to consider depending on whether
9013 -- the right operand is a class-wide type or not. If not we just
9014 -- compare the actual tag of the left expr to the target type tag:
9015 --
9016 -- Left_Expr.Tag = Right_Type'Tag;
9017 --
9018 -- If it is a class-wide type we use the RT function CW_Membership which
9019 -- is usually implemented by looking in the ancestor tables contained in
9020 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9022 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
9023 -- function IW_Membership which is usually implemented by looking in the
9024 -- table of abstract interface types plus the ancestor table contained in
9025 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9036 begin
9044 Obj_Tag :=
9047 Selector_Name =>
9052 -- No need to issue a run-time check if we statically know that the
9053 -- result of this membership test is always true. For example,
9054 -- considering the following declarations:
9056 -- type Iface is interface;
9057 -- type T is tagged null record;
9058 -- type DT is new T and Iface with null record;
9060 -- Obj1 : T;
9061 -- Obj2 : DT;
9063 -- These membership tests are always true:
9065 -- Obj1 in T'Class
9066 -- Obj2 in T'Class;
9067 -- Obj2 in Iface'Class;
9069 -- We do not need to handle cases where the membership is illegal.
9070 -- For example:
9072 -- Obj1 in DT'Class; -- Compile time error
9073 -- Obj1 in Iface'Class; -- Compile time error
9078 and then Interface_Present_In_Ancestor
9081 then
9085 -- Ada 2005 (AI-251): Class-wide applied to interfaces
9089 -- Support to: "Iface_CW_Typ in Typ'Class"
9092 then
9093 -- Issue error if IW_Membership operation not available in a
9094 -- configurable run time setting.
9101 return
9108 New_Reference_To (
9109 Node (First_Elmt
9111 Loc)));
9113 -- Ada 95: Normal case
9115 else
9116 return
9119 Typ_Tag_Node =>
9120 New_Reference_To (
9121 Node (First_Elmt
9123 Loc));
9126 -- Right_Type is not a class-wide type
9128 else
9129 -- No need to check the tag of the object if Right_Typ is abstract
9134 else
9135 return
9138 Right_Opnd =>
9139 New_Reference_To
9145 ------------------------------
9146 -- Unary_Op_Validity_Checks --
9147 ------------------------------
9150 begin