| blob | 6da8ff90e444ec1682ea17ab722f04c69c020ed0 |
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-2009, 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 ------------------------------------------------------------------------------
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
82 -- Performs validity checks for a binary operator
84 procedure Build_Boolean_Array_Proc_Call
88 -- If a boolean array assignment can be done in place, build call to
89 -- corresponding library procedure.
92 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
93 -- Expand_Allocator_Expression. Allocating class-wide interface objects
94 -- this routine displaces the pointer to the allocated object to reference
95 -- the component referencing the corresponding secondary dispatch table.
98 -- Subsidiary to Expand_N_Allocator, for the case when the expression
99 -- is a qualified expression or an aggregate.
102 -- This routine handles expansion of the comparison operators (N_Op_Lt,
103 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
104 -- code for these operators is similar, differing only in the details of
105 -- the actual comparison call that is made. Special processing (call a
106 -- run-time routine)
108 function Expand_Array_Equality
114 -- Expand an array equality into a call to a function implementing this
115 -- equality, and a call to it. Loc is the location for the generated nodes.
116 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
117 -- on which to attach bodies of local functions that are created in the
118 -- process. It is the responsibility of the caller to insert those bodies
119 -- at the right place. Nod provides the Sloc value for the generated code.
120 -- Normally the types used for the generated equality routine are taken
121 -- from Lhs and Rhs. However, in some situations of generated code, the
122 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
123 -- the type to be used for the formal parameters.
126 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
127 -- case of array type arguments.
129 function Expand_Composite_Equality
135 -- Local recursive function used to expand equality for nested composite
136 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
137 -- to attach bodies of local functions that are created in the process.
138 -- This is the responsibility of the caller to insert those bodies at the
139 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
140 -- are the left and right sides for the comparison, and Typ is the type of
141 -- the arrays to compare.
144 -- Routine to expand concatenation of a sequence of two or more operands
145 -- (in the list Operands) and replace node Cnode with the result of the
146 -- concatenation. The operands can be of any appropriate type, and can
147 -- include both arrays and singleton elements.
150 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
151 -- fixed. We do not have such a type at runtime, so the purpose of this
152 -- routine is to find the real type by looking up the tree. We also
153 -- determine if the operation must be rounded.
155 function Get_Allocator_Final_List
159 -- If the designated type is controlled, build final_list expression for
160 -- created object. If context is an access parameter, create a local access
161 -- type to have a usable finalization list.
164 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
165 -- discriminants if it has a constrained nominal type, unless the object
166 -- is a component of an enclosing Unchecked_Union object that is subject
167 -- to a per-object constraint and the enclosing object lacks inferable
168 -- discriminants.
169 --
170 -- An expression of an Unchecked_Union type has inferable discriminants
171 -- if it is either a name of an object with inferable discriminants or a
172 -- qualified expression whose subtype mark denotes a constrained subtype.
175 -- N is an expression whose type is an access. When the type of the
176 -- associated storage pool is derived from Checked_Pool, generate a
177 -- call to the 'Dereference' primitive operation.
179 function Make_Array_Comparison_Op
182 -- Comparisons between arrays are expanded in line. This function produces
183 -- the body of the implementation of (a > b), where a and b are one-
184 -- dimensional arrays of some discrete type. The original node is then
185 -- expanded into the appropriate call to this function. Nod provides the
186 -- Sloc value for the generated code.
188 function Make_Boolean_Array_Op
191 -- Boolean operations on boolean arrays are expanded in line. This function
192 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
193 -- b). It is used only the normal case and not the packed case. The type
194 -- involved, Typ, is the Boolean array type, and the logical operations in
195 -- the body are simple boolean operations. Note that Typ is always a
196 -- constrained type (the caller has ensured this by using
197 -- Convert_To_Actual_Subtype if necessary).
200 -- If N is the node for a comparison whose outcome can be determined at
201 -- compile time, then the node N can be rewritten with True or False. If
202 -- the outcome cannot be determined at compile time, the call has no
203 -- effect. If N is a type conversion, then this processing is applied to
204 -- its expression. If N is neither comparison nor a type conversion, the
205 -- call has no effect.
208 -- Construct the expression corresponding to the tagged membership test.
209 -- Deals with a second operand being (or not) a class-wide type.
211 function Safe_In_Place_Array_Op
215 -- In the context of an assignment, where the right-hand side is a boolean
216 -- operation on arrays, check whether operation can be performed in place.
220 -- Performs validity checks for a unary operator
222 -------------------------------
223 -- Binary_Op_Validity_Checks --
224 -------------------------------
227 begin
234 ------------------------------------
235 -- Build_Boolean_Array_Proc_Call --
236 ------------------------------------
238 procedure Build_Boolean_Array_Proc_Call
242 is
255 begin
259 -- Use negated version of the binary operators
271 Call_Node :=
276 Target,
289 else
292 Call_Node :=
296 Target,
307 else
308 -- We use the following equivalences:
310 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
311 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
312 -- (not X) xor (not Y) = X xor Y
313 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
322 else
326 else
337 else
342 Call_Node :=
346 Target,
361 exception
366 --------------------------------
367 -- Displace_Allocator_Pointer --
368 --------------------------------
377 begin
378 -- Do nothing in case of VM targets: the virtual machine will handle
379 -- interfaces directly.
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 Iface_2'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 the
475 -- type of the created object is not deeper than the level of the access
476 -- type. If the type of the qualified expression is class- wide, then
477 -- always generate the check (except in the case where it is known to be
478 -- unnecessary, see comment below). Otherwise, only generate the check
479 -- if the level of the qualified expression type is statically deeper
480 -- than the access type.
481 --
482 -- Although the static accessibility will generally have been performed
483 -- as a legality check, it won't have been done in cases where the
484 -- allocator appears in generic body, so a run-time check is needed in
485 -- general. One special case is when the access type is declared in the
486 -- same scope as the class-wide allocator, in which case the check can
487 -- never fail, so it need not be generated.
488 --
489 -- As an open issue, there seem to be cases where the static level
490 -- associated with the class-wide object's underlying type is not
491 -- sufficient to perform the proper accessibility check, such as for
492 -- allocators in nested subprograms or accept statements initialized by
493 -- class-wide formals when the actual originates outside at a deeper
494 -- static level. The nested subprogram case might require passing
495 -- accessibility levels along with class-wide parameters, and the task
496 -- case seems to be an actual gap in the language rules that needs to
497 -- be fixed by the ARG. ???
499 -------------------------------
500 -- Apply_Accessibility_Check --
501 -------------------------------
503 procedure Apply_Accessibility_Check
506 is
509 begin
510 -- Note: we skip the accessibility check for the VM case, since
511 -- there does not seem to be any practical way of implementing it.
514 and then Tagged_Type_Expansion
517 and then
519 or else
522 then
523 -- If the allocator was built in place Ref is already a reference
524 -- to the access object initialized to the result of the allocator
525 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise
526 -- it is the entity associated with the object containing the
527 -- address of the allocated object.
531 else
537 Condition =>
539 Left_Opnd =>
544 Right_Opnd =>
551 -- Local variables
560 -- Type used as source for tag assignment
563 -- Target reference for tag assignment
570 -- Start of processing for Expand_Allocator_Expression
572 begin
575 -- Ada 2005 (AI-318-02): If the initialization expression is a call
576 -- to a build-in-place function, then access to the allocated object
577 -- must be passed to the function. Currently we limit such functions
578 -- to those with constrained limited result subtypes, but eventually
579 -- we plan to expand the allowed forms of functions that are treated
580 -- as build-in-place.
584 then
590 -- Actions inserted before:
591 -- Temp : constant ptr_T := new T'(Expression);
592 -- <no CW> Temp._tag := T'tag;
593 -- <CTRL> Adjust (Finalizable (Temp.all));
594 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
596 -- We analyze by hand the new internal allocator to avoid
597 -- any recursion and inappropriate call to Initialize
599 -- We don't want to remove side effects when the expression must be
600 -- built in place. In the case of a build-in-place function call,
601 -- that could lead to a duplication of the call, which was already
602 -- substituted for the allocator.
608 Temp :=
611 -- For a class wide allocation generate the following code:
613 -- type Equiv_Record is record ... end record;
614 -- implicit subtype CW is <Class_Wide_Subytpe>;
615 -- temp : PtrT := new CW'(CW!(expr));
620 -- Ada 2005 (AI-251): If the expression is a class-wide interface
621 -- object we generate code to move up "this" to reference the
622 -- base of the object before allocating the new object.
624 -- Note that Exp'Address is recursively expanded into a call
625 -- to Base_Address (Exp.Tag)
629 and then Tagged_Type_Expansion
630 then
631 Set_Expression
640 else
641 Set_Expression
649 -- Keep separate the management of allocators returning interfaces
653 Tmp_Node :=
657 Expression =>
661 -- Copy the Comes_From_Source flag for the allocator we just
662 -- built, since logically this allocator is a replacement of
663 -- the original allocator node. This is for proper handling of
664 -- restriction No_Implicit_Heap_Allocations.
666 Set_Comes_From_Source
674 then
675 -- Create local finalization list for access parameter
682 else
693 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
694 -- interface type. In this case we use the type of the qualified
695 -- expression to allocate the object.
697 else
698 declare
704 begin
705 New_Decl :=
708 Type_Definition =>
713 Subtype_Indication =>
718 -- Inherit the final chain to ensure that the expansion of the
719 -- aggregate is correct in case of controlled types
726 -- Declare the object using the previous type declaration
729 Tmp_Node :=
733 Expression =>
737 -- Copy the Comes_From_Source flag for the allocator we just
738 -- built, since logically this allocator is a replacement of
739 -- the original allocator node. This is for proper handling
740 -- of restriction No_Implicit_Heap_Allocations.
742 Set_Comes_From_Source
750 then
751 -- Create local finalization list for access parameter
753 Flist :=
758 else
769 -- Generate an additional object containing the address of the
770 -- returned object. The type of this second object declaration
771 -- is the correct type required for the common processing that
772 -- is still performed by this subprogram. The displacement of
773 -- this pointer to reference the component associated with the
774 -- interface type will be done at the end of common processing.
776 New_Decl :=
793 -- Generate the tag assignment
795 -- Suppress the tag assignment when VM_Target because VM tags are
796 -- represented implicitly in objects.
801 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
802 -- interface objects because in this case the tag does not change.
815 then
817 TagR :=
824 Tag_Assign :=
826 Name =>
829 Selector_Name =>
832 Expression =>
834 New_Reference_To
836 Loc)));
838 -- The previous assignment has to be done in any case
846 then
847 declare
852 begin
853 -- If it is an allocation on the secondary stack (i.e. a value
854 -- returned from a function), the object is attached on the
855 -- caller side as soon as the call is completed (see
856 -- Expand_Ctrl_Function_Call)
859 declare
863 begin
874 -- Normal case, not a secondary stack allocation
876 else
879 then
880 -- Create local finalization list for access parameter
882 Flist :=
884 else
891 -- Generate an Adjust call if the object will be moved. In Ada
892 -- 2005, the object may be inherently limited, in which case
893 -- there is no Adjust procedure, and the object is built in
894 -- place. In Ada 95, the object can be limited but not
895 -- inherently limited if this allocator came from a return
896 -- statement (we're allocating the result on the secondary
897 -- stack). In that case, the object will be moved, so we _do_
898 -- want to Adjust.
900 if not Aggr_In_Place
902 then
904 Make_Adjust_Call (
905 Ref =>
907 -- An unchecked conversion is needed in the classwide
908 -- case because the designated type can be an ancestor of
909 -- the subtype mark of the allocator.
926 -- Ada 2005 (AI-251): Displace the pointer to reference the record
927 -- component containing the secondary dispatch table of the interface
928 -- type.
935 Temp :=
937 Tmp_Node :=
944 -- Copy the Comes_From_Source flag for the allocator we just built,
945 -- since logically this allocator is a replacement of the original
946 -- allocator node. This is for proper handling of restriction
947 -- No_Implicit_Heap_Allocations.
949 Set_Comes_From_Source
960 then
966 then
967 -- Apply constraint to designated subtype indication
975 -- Propagate constraint_error to enclosing allocator
979 else
980 -- If we have:
981 -- type A is access T1;
982 -- X : A := new T2'(...);
983 -- T1 and T2 can be different subtypes, and we might need to check
984 -- both constraints. First check against the type of the qualified
985 -- expression.
989 -- A check is also needed in cases where the designated subtype is
990 -- constrained and differs from the subtype given in the qualified
991 -- expression. Note that the check on the qualified expression does
992 -- not allow sliding, but this check does (a relaxation from Ada 83).
996 then
997 Apply_Constraint_Check
1001 -- For an access to unconstrained packed array, GIGI needs to see an
1002 -- expression with a constrained subtype in order to compute the
1003 -- proper size for the allocator.
1008 then
1009 declare
1014 begin
1018 Subtype_Indication =>
1025 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1026 -- to a build-in-place function, then access to the allocated object
1027 -- must be passed to the function. Currently we limit such functions
1028 -- to those with constrained limited result subtypes, but eventually
1029 -- we plan to expand the allowed forms of functions that are treated
1030 -- as build-in-place.
1034 then
1039 exception
1044 -----------------------------
1045 -- Expand_Array_Comparison --
1046 -----------------------------
1048 -- Expansion is only required in the case of array types. For the unpacked
1049 -- case, an appropriate runtime routine is called. For packed cases, and
1050 -- also in some other cases where a runtime routine cannot be called, the
1051 -- form of the expansion is:
1053 -- [body for greater_nn; boolean_expression]
1055 -- The body is built by Make_Array_Comparison_Op, and the form of the
1056 -- Boolean expression depends on the operator involved.
1072 -- True for byte addressable target
1075 -- Returns True if the length of the given operand is known to be less
1076 -- than 4. Returns False if this length is known to be four or greater
1077 -- or is not known at compile time.
1079 ------------------------
1080 -- Length_Less_Than_4 --
1081 ------------------------
1086 begin
1090 else
1091 declare
1098 begin
1101 else
1107 else
1116 -- Start of processing for Expand_Array_Comparison
1118 begin
1119 -- Deal first with unpacked case, where we can call a runtime routine
1120 -- except that we avoid this for targets for which are not addressable
1121 -- by bytes, and for the JVM/CIL, since they do not support direct
1122 -- addressing of array components.
1125 and then Byte_Addressable
1127 then
1128 -- The call we generate is:
1130 -- Compare_Array_xn[_Unaligned]
1131 -- (left'address, right'address, left'length, right'length) <op> 0
1133 -- x = U for unsigned, S for signed
1134 -- n = 8,16,32,64 for component size
1135 -- Add _Unaligned if length < 4 and component size is 8.
1136 -- <op> is the standard comparison operator
1140 or else
1142 then
1145 else
1149 else
1152 else
1160 else
1167 else
1174 else
1212 -- Cases where we cannot make runtime call
1214 -- For (a <= b) we convert to not (a > b)
1219 Right_Opnd =>
1226 -- For < the Boolean expression is
1227 -- greater__nn (op2, op1)
1232 -- Switch operands
1237 -- For (a >= b) we convert to not (a < b)
1242 Right_Opnd =>
1249 -- For > the Boolean expression is
1250 -- greater__nn (op1, op2)
1252 else
1258 Expr :=
1267 exception
1272 ---------------------------
1273 -- Expand_Array_Equality --
1274 ---------------------------
1276 -- Expand an equality function for multi-dimensional arrays. Here is an
1277 -- example of such a function for Nb_Dimension = 2
1279 -- function Enn (A : atyp; B : btyp) return boolean is
1280 -- begin
1281 -- if (A'length (1) = 0 or else A'length (2) = 0)
1282 -- and then
1283 -- (B'length (1) = 0 or else B'length (2) = 0)
1284 -- then
1285 -- return True; -- RM 4.5.2(22)
1286 -- end if;
1288 -- if A'length (1) /= B'length (1)
1289 -- or else
1290 -- A'length (2) /= B'length (2)
1291 -- then
1292 -- return False; -- RM 4.5.2(23)
1293 -- end if;
1295 -- declare
1296 -- A1 : Index_T1 := A'first (1);
1297 -- B1 : Index_T1 := B'first (1);
1298 -- begin
1299 -- loop
1300 -- declare
1301 -- A2 : Index_T2 := A'first (2);
1302 -- B2 : Index_T2 := B'first (2);
1303 -- begin
1304 -- loop
1305 -- if A (A1, A2) /= B (B1, B2) then
1306 -- return False;
1307 -- end if;
1309 -- exit when A2 = A'last (2);
1310 -- A2 := Index_T2'succ (A2);
1311 -- B2 := Index_T2'succ (B2);
1312 -- end loop;
1313 -- end;
1315 -- exit when A1 = A'last (1);
1316 -- A1 := Index_T1'succ (A1);
1317 -- B1 := Index_T1'succ (B1);
1318 -- end loop;
1319 -- end;
1321 -- return true;
1322 -- end Enn;
1324 -- Note on the formal types used (atyp and btyp). If either of the arrays
1325 -- is of a private type, we use the underlying type, and do an unchecked
1326 -- conversion of the actual. If either of the arrays has a bound depending
1327 -- on a discriminant, then we use the base type since otherwise we have an
1328 -- escaped discriminant in the function.
1330 -- If both arrays are constrained and have the same bounds, we can generate
1331 -- a loop with an explicit iteration scheme using a 'Range attribute over
1332 -- the first array.
1334 function Expand_Array_Equality
1340 is
1356 -- The parameter types to be used for the formals
1358 function Arr_Attr
1362 -- This builds the attribute reference Arr'Nam (Expr)
1365 -- Create one statement to compare corresponding components, designated
1366 -- by a full set of indices.
1369 -- Given one of the arguments, computes the appropriate type to be used
1370 -- for that argument in the corresponding function formal
1372 function Handle_One_Dimension
1375 -- This procedure returns the following code
1376 --
1377 -- declare
1378 -- Bn : Index_T := B'First (N);
1379 -- begin
1380 -- loop
1381 -- xxx
1382 -- exit when An = A'Last (N);
1383 -- An := Index_T'Succ (An)
1384 -- Bn := Index_T'Succ (Bn)
1385 -- end loop;
1386 -- end;
1387 --
1388 -- If both indices are constrained and identical, the procedure
1389 -- returns a simpler loop:
1390 --
1391 -- for An in A'Range (N) loop
1392 -- xxx
1393 -- end loop
1394 --
1395 -- N is the dimension for which we are generating a loop. Index is the
1396 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1397 -- xxx statement is either the loop or declare for the next dimension
1398 -- or if this is the last dimension the comparison of corresponding
1399 -- components of the arrays.
1400 --
1401 -- The actual way the code works is to return the comparison of
1402 -- corresponding components for the N+1 call. That's neater!
1405 -- This function constructs the test for both arrays being empty
1406 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1407 -- and then
1408 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1411 -- This function constructs the test for arrays having different lengths
1412 -- in at least one index position, in which case the resulting code is:
1414 -- A'length (1) /= B'length (1)
1415 -- or else
1416 -- A'length (2) /= B'length (2)
1417 -- or else
1418 -- ...
1420 --------------
1421 -- Arr_Attr --
1422 --------------
1424 function Arr_Attr
1428 is
1429 begin
1430 return
1437 ------------------------
1438 -- Component_Equality --
1439 ------------------------
1445 begin
1446 -- if a(i1...) /= b(j1...) then return false; end if;
1448 L :=
1453 R :=
1458 Test := Expand_Composite_Equality
1461 -- If some (sub)component is an unchecked_union, the whole operation
1462 -- will raise program error.
1466 -- This node is going to be inserted at a location where a
1467 -- statement is expected: clear its Etype so analysis will set
1468 -- it to the expected Standard_Void_Type.
1473 else
1474 return
1483 ------------------
1484 -- Get_Arg_Type --
1485 ------------------
1491 begin
1497 else
1503 or else
1505 then
1517 --------------------------
1518 -- Handle_One_Dimension --
1519 ---------------------------
1521 function Handle_One_Dimension
1524 is
1526 Ltyp /= Rtyp
1528 -- If the index types are identical, and we are working with
1529 -- constrained types, then we can use the same index for both
1530 -- of the arrays.
1540 begin
1545 -- Case where we generate a loop
1550 Bn :=
1553 else
1565 -- Generate guard for loop, followed by increments of indices
1569 Condition =>
1577 Expression =>
1586 Expression =>
1593 -- If separate indexes, we need a declare block for An and Bn, and a
1594 -- loop without an iteration scheme.
1597 Loop_Stm :=
1600 return
1613 Handled_Statement_Sequence =>
1617 -- If no separate indexes, return loop statement with explicit
1618 -- iteration scheme on its own
1620 else
1621 Loop_Stm :=
1624 Iteration_Scheme =>
1626 Loop_Parameter_Specification =>
1629 Discrete_Subtype_Definition =>
1635 -----------------------
1636 -- Test_Empty_Arrays --
1637 -----------------------
1646 begin
1650 Atest :=
1655 Btest :=
1664 else
1665 Alist :=
1670 Blist :=
1677 return
1683 -----------------------------
1684 -- Test_Lengths_Correspond --
1685 -----------------------------
1691 begin
1694 Rtest :=
1701 else
1702 Result :=
1712 -- Start of processing for Expand_Array_Equality
1714 begin
1718 -- For now, if the argument types are not the same, go to the base type,
1719 -- since the code assumes that the formals have the same type. This is
1720 -- fixable in future ???
1728 -- Build list of formals for function
1741 -- Build statement sequence for function
1743 Func_Body :=
1745 Specification =>
1753 Handled_Statement_Sequence =>
1761 Expression =>
1768 Expression =>
1779 -- If the array type is distinct from the type of the arguments, it
1780 -- is the full view of a private type. Apply an unchecked conversion
1781 -- to insure that analysis of the call succeeds.
1783 declare
1786 begin
1792 then
1798 then
1807 return
1813 -----------------------------
1814 -- Expand_Boolean_Operator --
1815 -----------------------------
1817 -- Note that we first get the actual subtypes of the operands, since we
1818 -- always want to deal with types that have bounds.
1823 begin
1824 -- Special case of bit packed array where both operands are known to be
1825 -- properly aligned. In this case we use an efficient run time routine
1826 -- to carry out the operation (see System.Bit_Ops).
1831 then
1836 -- For the normal non-packed case, the general expansion is to build
1837 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1838 -- and then inserting it into the tree. The original operator node is
1839 -- then rewritten as a call to this function. We also use this in the
1840 -- packed case if either operand is a possibly unaligned object.
1842 declare
1849 begin
1862 then
1867 and then
1869 then
1871 else
1877 -- Now rewrite the expression with a call
1882 Parameter_Associations =>
1883 New_List (
1884 L,
1885 Make_Type_Conversion
1893 -------------------------------
1894 -- Expand_Composite_Equality --
1895 -------------------------------
1897 -- This function is only called for comparing internal fields of composite
1898 -- types when these fields are themselves composites. This is a special
1899 -- case because it is not possible to respect normal Ada visibility rules.
1901 function Expand_Composite_Equality
1907 is
1913 begin
1916 else
1920 -- Defense against malformed private types with no completion the error
1921 -- will be diagnosed later by check_completion
1931 -- If the operand is an elementary type other than a floating-point
1932 -- type, then we can simply use the built-in block bitwise equality,
1933 -- since the predefined equality operators always apply and bitwise
1934 -- equality is fine for all these cases.
1938 then
1941 -- For composite component types, and floating-point types, use the
1942 -- expansion. This deals with tagged component types (where we use
1943 -- the applicable equality routine) and floating-point, (where we
1944 -- need to worry about negative zeroes), and also the case of any
1945 -- composite type recursively containing such fields.
1947 else
1953 -- Call the primitive operation "=" of this type
1959 -- If this is derived from an untagged private type completed with a
1960 -- tagged type, it does not have a full view, so we use the primitive
1961 -- operations of the private type. This check should no longer be
1962 -- necessary when these types receive their full views ???
1969 then
1971 else
1975 loop
1987 return
1990 Parameter_Associations =>
1991 New_List
2001 -- Inherited equality from parent type. Convert the actuals to
2002 -- match signature of operation.
2004 declare
2007 begin
2008 return
2011 Parameter_Associations =>
2016 else
2017 -- Comparison between Unchecked_Union components
2020 declare
2026 begin
2027 -- Lhs subtype
2033 -- Rhs subtype
2039 -- Lhs of the composite equality
2043 -- Since the enclosing record type can never be an
2044 -- Unchecked_Union (this code is executed for records
2045 -- that do not have variants), we may reference its
2046 -- discriminant(s).
2051 then
2052 Lhs_Discr_Val :=
2055 Selector_Name =>
2056 New_Copy (
2057 Get_Discriminant_Value (
2059 Lhs_Type,
2062 else
2064 Get_Discriminant_Value (
2066 Lhs_Type,
2070 else
2071 -- It is not possible to infer the discriminant since
2072 -- the subtype is not constrained.
2074 return
2079 -- Rhs of the composite equality
2085 then
2086 Rhs_Discr_Val :=
2089 Selector_Name =>
2090 New_Copy (
2091 Get_Discriminant_Value (
2093 Rhs_Type,
2096 else
2098 Get_Discriminant_Value (
2100 Rhs_Type,
2104 else
2105 return
2110 -- Call the TSS equality function with the inferred
2111 -- discriminant values.
2113 return
2117 Lhs,
2118 Rhs,
2119 Lhs_Discr_Val,
2120 Rhs_Discr_Val));
2124 -- Shouldn't this be an else, we can't fall through the above
2125 -- IF, right???
2127 return
2133 else
2137 else
2138 -- It can be a simple record or the full view of a scalar private
2144 ------------------------
2145 -- Expand_Concatenate --
2146 ------------------------
2152 -- Result type of concatenation
2155 -- Component type. Elements of this component type can appear as one
2156 -- of the operands of concatenation as well as arrays.
2159 -- Index subtype
2162 -- Index type. This is the base type of the index subtype, and is used
2163 -- for all computed bounds (which may be out of range of Istyp in the
2164 -- case of null ranges).
2167 -- This is the type we use to do arithmetic to compute the bounds and
2168 -- lengths of operands. The choice of this type is a little subtle and
2169 -- is discussed in a separate section at the start of the body code.
2172 -- Raised if concatenation is sure to raise a CE
2175 -- Reset to False if at least one operand is encountered which is known
2176 -- at compile time to be non-null. Used for handling the special case
2177 -- of setting the high bound to the last operand high bound for a null
2178 -- result, thus ensuring a proper high bound in the super-flat case.
2181 -- Number of concatenation operands including possibly null operands
2184 -- Number of operands excluding any known to be null, except that the
2185 -- last operand is always retained, in case it provides the bounds for
2186 -- a null result.
2189 -- Current operand being processed in the loop through operands. After
2190 -- this loop is complete, always contains the last operand (which is not
2191 -- the same as Operands (NN), since null operands are skipped).
2193 -- Arrays describing the operands, only the first NN entries of each
2194 -- array are set (NN < N when we exclude known null operands).
2197 -- True if length of corresponding operand known at compile time
2200 -- Set to the corresponding entry in the Opnds list (but note that null
2201 -- operands are excluded, so not all entries in the list are stored).
2204 -- Set to length of operand. Entries in this array are set only if the
2205 -- corresponding entry in Is_Fixed_Length is True.
2208 -- Set to lower bound of operand. Either an integer literal in the case
2209 -- where the bound is known at compile time, else actual lower bound.
2210 -- The operand low bound is of type Ityp.
2213 -- Set to an entity of type Natural that contains the length of an
2214 -- operand whose length is not known at compile time. Entries in this
2215 -- array are set only if the corresponding entry in Is_Fixed_Length
2216 -- is False. The entity is of type Artyp.
2219 -- The J'th entry in an expression node that represents the total length
2220 -- of operands 1 through J. It is either an integer literal node, or a
2221 -- reference to a constant entity with the right value, so it is fine
2222 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2223 -- entry always is set to zero. The length is of type Artyp.
2226 -- A tree node representing the low bound of the result (of type Ityp).
2227 -- This is either an integer literal node, or an identifier reference to
2228 -- a constant entity initialized to the appropriate value.
2231 -- A tree node representing the high bound of the last operand. This
2232 -- need only be set if the result could be null. It is used for the
2233 -- special case of setting the right high bound for a null result.
2234 -- This is of type Ityp.
2237 -- A tree node representing the high bound of the result (of type Ityp)
2240 -- Result of the concatenation (of type Ityp)
2243 -- Collect actions to be inserted if Save_Space is False
2247 -- Set to True if we are saving generated code space by calling routines
2248 -- in packages System.Concat_n.
2251 -- Set True during generation of the assignements of operands into
2252 -- result once an operand known to be non-null has been seen.
2255 -- This function makes an N_Integer_Literal node that is returned in
2256 -- analyzed form with the type set to Artyp. Importantly this literal
2257 -- is not flagged as static, so that if we do computations with it that
2258 -- result in statically detected out of range conditions, we will not
2259 -- generate error messages but instead warning messages.
2262 -- Given a node of type Ityp, returns the corresponding value of type
2263 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2264 -- For enum types, the Pos of the value is returned.
2267 -- The inverse function (uses Val in the case of enumeration types)
2269 ------------------------
2270 -- Make_Artyp_Literal --
2271 ------------------------
2275 begin
2282 --------------
2283 -- To_Artyp --
2284 --------------
2287 begin
2292 return
2298 else
2303 -------------
2304 -- To_Ityp --
2305 -------------
2308 begin
2310 return
2316 -- Case where we will do a type conversion
2318 else
2321 else
2327 -- Local Declarations
2336 begin
2337 -- Choose an appropriate computational type
2339 -- We will be doing calculations of lengths and bounds in this routine
2340 -- and computing one from the other in some cases, e.g. getting the high
2341 -- bound by adding the length-1 to the low bound.
2343 -- We can't just use the index type, or even its base type for this
2344 -- purpose for two reasons. First it might be an enumeration type which
2345 -- is not suitable fo computations of any kind, and second it may simply
2346 -- not have enough range. For example if the index type is -128..+127
2347 -- then lengths can be up to 256, which is out of range of the type.
2349 -- For enumeration types, we can simply use Standard_Integer, this is
2350 -- sufficient since the actual number of enumeration literals cannot
2351 -- possibly exceed the range of integer (remember we will be doing the
2352 -- arithmetic with POS values, not representation values).
2357 -- If index type is Positive, we use the standard unsigned type, to give
2358 -- more room on the top of the range, obviating the need for an overflow
2359 -- check when creating the upper bound. This is needed to avoid junk
2360 -- overflow checks in the common case of String types.
2362 -- ??? Disabled for now
2364 -- elsif Istyp = Standard_Positive then
2365 -- Artyp := Standard_Unsigned;
2367 -- For modular types, we use a 32-bit modular type for types whose size
2368 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2369 -- identity type, and for larger unsigned types we use 64-bits.
2376 else
2380 -- Similar treatment for signed types
2382 else
2387 else
2392 -- Supply dummy entry at start of length array
2396 -- Go through operands setting up the above arrays
2403 -- The parent got messed up when we put the operands in a list,
2404 -- so now put back the proper parent for the saved operand.
2408 -- Set will be True when we have setup one entry in the array
2412 -- Singleton element (or character literal) case
2421 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2422 -- since we know that the result cannot be null).
2431 -- String literal case (can only occur for strings of course)
2440 -- Capture last operand high bound if result could be null
2443 Last_Opnd_High_Bound :=
2445 Left_Opnd =>
2450 -- Skip null string literal
2460 -- Set length and bounds
2469 -- All other cases
2471 else
2472 -- Check constrained case with known bounds
2475 declare
2481 begin
2482 -- Fixed length constrained array type with known at compile
2483 -- time bounds is last case of fixed length operand.
2486 and then
2488 then
2489 declare
2495 begin
2500 -- Capture last operand bound if result could be null
2503 Last_Opnd_High_Bound :=
2509 -- Exclude null length case unless last operand
2530 -- All cases where the length is not known at compile time, or the
2531 -- special case of an operand which is known to be null but has a
2532 -- lower bound other than 1 or is other than a string type.
2537 -- Capture operand bounds
2541 Prefix =>
2546 Last_Opnd_High_Bound :=
2549 Prefix =>
2554 -- Capture length of operand in entity
2568 Object_Definition =>
2571 Expression =>
2573 Prefix =>
2579 -- Set next entry in aggregate length array
2581 -- For first entry, make either integer literal for fixed length
2582 -- or a reference to the saved length for variable length.
2589 else
2594 -- If entry is fixed length and only fixed lengths so far, make
2595 -- appropriate new integer literal adding new length.
2599 then
2604 -- All other cases, construct an addition node for the length and
2605 -- create an entity initialized to this length.
2607 else
2608 Ent :=
2614 else
2623 Object_Definition =>
2626 Expression =>
2638 -- If we have only skipped null operands, return the last operand
2645 -- If we have only one non-null operand, return it and we are done.
2646 -- There is one case in which this cannot be done, and that is when
2647 -- the sole operand is of the element type, in which case it must be
2648 -- converted to an array, and the easiest way of doing that is to go
2649 -- through the normal general circuit.
2653 then
2658 -- Cases where we have a real concatenation
2660 -- Next step is to find the low bound for the result array that we
2661 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
2663 -- If the ultimate ancestor of the index subtype is a constrained array
2664 -- definition, then the lower bound is that of the index subtype as
2665 -- specified by (RM 4.5.3(6)).
2667 -- The right test here is to go to the root type, and then the ultimate
2668 -- ancestor is the first subtype of this root type.
2671 Low_Bound :=
2673 Prefix =>
2677 -- If the first operand in the list has known length we know that
2678 -- the lower bound of the result is the lower bound of this operand.
2683 -- OK, we don't know the lower bound, we have to build a horrible
2684 -- expression actions node of the form
2686 -- if Cond1'Length /= 0 then
2687 -- Opnd1 low bound
2688 -- else
2689 -- if Opnd2'Length /= 0 then
2690 -- Opnd2 low bound
2691 -- else
2692 -- ...
2694 -- The nesting ends either when we hit an operand whose length is known
2695 -- at compile time, or on reaching the last operand, whose low bound we
2696 -- take unconditionally whether or not it is null. It's easiest to do
2697 -- this with a recursive procedure:
2699 else
2700 declare
2702 -- Returns the lower bound determined by operands J .. NN
2704 ---------------------
2705 -- Get_Known_Bound --
2706 ---------------------
2709 begin
2713 else
2714 return
2727 begin
2728 Ent :=
2742 -- Now we can safely compute the upper bound, normally
2743 -- Low_Bound + Length - 1.
2745 High_Bound :=
2746 To_Ityp (
2749 Right_Opnd =>
2754 -- Note that calculation of the high bound may cause overflow in some
2755 -- very weird cases, so in the general case we need an overflow check on
2756 -- the high bound. We can avoid this for the common case of string types
2757 -- and other types whose index is Positive, since we chose a wider range
2758 -- for the arithmetic type.
2764 -- Handle the exceptional case where the result is null, in which case
2765 -- case the bounds come from the last operand (so that we get the proper
2766 -- bounds if the last operand is super-flat).
2769 High_Bound :=
2775 Last_Opnd_High_Bound,
2776 High_Bound));
2779 -- Here is where we insert the saved up actions
2783 -- Now we construct an array object with appropriate bounds
2785 Ent :=
2789 -- If the bound is statically known to be out of range, we do not want
2790 -- to abort, we want a warning and a runtime constraint error. Note that
2791 -- we have arranged that the result will not be treated as a static
2792 -- constant, so we won't get an illegality during this insertion.
2797 Object_Definition =>
2800 Constraint =>
2808 -- If the result of the concatenation appears as the initializing
2809 -- expression of an object declaration, we can just rename the
2810 -- result, rather than copying it.
2814 -- Catch the static out of range case now
2820 -- Now we will generate the assignments to do the actual concatenation
2822 -- There is one case in which we will not do this, namely when all the
2823 -- following conditions are met:
2825 -- The result type is Standard.String
2827 -- There are nine or fewer retained (non-null) operands
2829 -- The optimization level is -O0
2831 -- The corresponding System.Concat_n.Str_Concat_n routine is
2832 -- available in the run time.
2834 -- The debug flag gnatd.c is not set
2836 -- If all these conditions are met then we generate a call to the
2837 -- relevant concatenation routine. The purpose of this is to avoid
2838 -- undesirable code bloat at -O0.
2843 and then not Debug_Flag_Dot_C
2844 then
2845 declare
2848 RE_Str_Concat_3,
2849 RE_Str_Concat_4,
2850 RE_Str_Concat_5,
2851 RE_Str_Concat_6,
2852 RE_Str_Concat_7,
2853 RE_Str_Concat_8,
2854 RE_Str_Concat_9);
2856 begin
2858 declare
2862 begin
2877 else
2894 -- Not special case so generate the assignments
2899 declare
2908 Right_Opnd =>
2913 begin
2914 -- Singleton case, simple assignment
2920 Name =>
2927 -- Array case, slice assignment, skipped when argument is fixed
2928 -- length and known to be null.
2931 declare
2934 Name =>
2936 Prefix =>
2938 Discrete_Range =>
2943 begin
2949 -- Here if operand length is not statically known and no
2950 -- operand known to be non-null has been processed yet.
2951 -- If operand length is 0, we do not need to perform the
2952 -- assignment, and we must avoid the evaluation of the
2953 -- high bound of the slice, since it may underflow if the
2954 -- low bound is Ityp'First.
2956 Assign :=
2958 Condition =>
2960 Left_Opnd =>
2963 Then_Statements =>
2973 -- Finally we build the result, which is a reference to the array object
2981 exception
2984 -- Kill warning generated for the declaration of the static out of
2985 -- range high bound, and instead generate a Constraint_Error with
2986 -- an appropriate specific message.
2989 Apply_Compile_Time_Constraint_Error
2993 -- Set_Etype (Cnode, Atyp);
2996 ------------------------
2997 -- Expand_N_Allocator --
2998 ------------------------
3010 -- Generate finalization calls for all nested coextensions of N. This
3011 -- routine may allocate list controllers if necessary.
3014 -- Static coextensions have the same lifetime as the entity they
3015 -- constrain. Such occurrences can be rewritten as aliased objects
3016 -- and their unrestricted access used instead of the coextension.
3019 -- Given a constrained array type E, returns a node representing the
3020 -- code to compute the size in storage elements for the given type.
3021 -- This is done without using the attribute (which malfunctions for
3022 -- large sizes ???)
3024 ---------------------------------------
3025 -- Complete_Coextension_Finalization --
3026 ---------------------------------------
3035 -- Determine whether node N is part of a return statement
3038 -- Determine whether node N is a subtype indicator allocator which
3039 -- acts a coextension. Such coextensions need initialization.
3041 -------------------------------
3042 -- Inside_A_Return_Statement --
3043 -------------------------------
3048 begin
3051 if Nkind_In
3053 then
3056 -- Stop the traversal when we reach a subprogram body
3068 -------------------------------
3069 -- Needs_Initialization_Call --
3070 -------------------------------
3075 begin
3079 N_Object_Declaration
3080 then
3083 return
3087 N_Qualified_Expression;
3093 -- Start of processing for Complete_Coextension_Finalization
3095 begin
3096 -- When a coextension root is inside a return statement, we need to
3097 -- use the finalization chain of the function's scope. This does not
3098 -- apply for controlled named access types because in those cases we
3099 -- can use the finalization chain of the type itself.
3102 and then
3104 or else
3107 then
3108 declare
3113 begin
3118 -- Retrieve the declaration of the body
3120 Decl :=
3121 Parent
3122 (Parent
3130 -- Push the scope of the function body since we are inserting
3131 -- the list before the body, but we are currently in the body
3132 -- itself. Override the finalization list of PtrT since the
3133 -- finalization context is now different.
3137 Pop_Scope;
3140 -- The root allocator may not be controlled, but it still needs a
3141 -- finalization list for all nested coextensions.
3147 Flist :=
3149 Prefix =>
3151 Selector_Name =>
3158 -- Generate:
3159 -- typ! (coext.all)
3162 Ref :=
3165 Expression =>
3168 else
3172 -- No initialization call if not allowed
3178 -- Generate:
3179 -- initialize (Ref)
3180 -- attach_to_final_list (Ref, Flist, 2)
3184 Make_Init_Call (
3190 -- Generate:
3191 -- attach_to_final_list (Ref, Flist, 2)
3193 else
3195 Make_Attach_Call (
3206 -------------------------
3207 -- Rewrite_Coextension --
3208 -------------------------
3215 -- Generate:
3216 -- Cnn : aliased Etyp;
3222 Object_Definition =>
3226 begin
3231 -- Find the proper insertion node for the declaration
3252 ------------------------------
3253 -- Size_In_Storage_Elements --
3254 ------------------------------
3257 begin
3258 -- Logically this just returns E'Max_Size_In_Storage_Elements.
3259 -- However, the reason for the existence of this function is
3260 -- to construct a test for sizes too large, which means near the
3261 -- 32-bit limit on a 32-bit machine, and precisely the trouble
3262 -- is that we get overflows when sizes are greater than 2**31.
3264 -- So what we end up doing for array types is to use the expression:
3266 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
3268 -- which avoids this problem. All this is a big bogus, but it does
3269 -- mean we catch common cases of trying to allocate arrays that
3270 -- are too large, and which in the absence of a check results in
3271 -- undetected chaos ???
3273 declare
3277 begin
3279 Len :=
3289 else
3290 Res :=
3297 return
3300 Right_Opnd =>
3307 -- Start of processing for Expand_N_Allocator
3309 begin
3310 -- RM E.2.3(22). We enforce that the expected type of an allocator
3311 -- shall not be a remote access-to-class-wide-limited-private type
3313 -- Why is this being done at expansion time, seems clearly wrong ???
3317 -- Set the Storage Pool
3330 else
3336 -- Under certain circumstances we can replace an allocator by an access
3337 -- to statically allocated storage. The conditions, as noted in AARM
3338 -- 3.10 (10c) are as follows:
3340 -- Size and initial value is known at compile time
3341 -- Access type is access-to-constant
3343 -- The allocator is not part of a constraint on a record component,
3344 -- because in that case the inserted actions are delayed until the
3345 -- record declaration is fully analyzed, which is too late for the
3346 -- analysis of the rewritten allocator.
3354 then
3355 -- Here we can do the optimization. For the allocator
3357 -- new x'(y)
3359 -- We insert an object declaration
3361 -- Tnn : aliased x := y;
3363 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
3364 -- marked as requiring static allocation.
3366 Temp :=
3371 -- If context is constrained, use constrained subtype directly,
3372 -- so that the constant is not labelled as having a nominally
3373 -- unconstrained subtype.
3394 -- We set the variable as statically allocated, since we don't want
3395 -- it going on the stack of the current procedure!
3401 -- Same if the allocator is an access discriminant for a local object:
3402 -- instead of an allocator we create a local value and constrain the
3403 -- the enclosing object with the corresponding access attribute.
3410 -- The current allocator creates an object which may contain nested
3411 -- coextensions. Use the current allocator's finalization list to
3412 -- generate finalization call for all nested coextensions.
3415 Complete_Coextension_Finalization;
3418 -- Check for size too large, we do this because the back end misses
3419 -- proper checks here and can generate rubbish allocation calls when
3420 -- we are near the limit. We only do this for the 32-bit address case
3421 -- since that is from a practical point of view where we see a problem.
3427 then
3428 -- The check we want to generate should look like
3430 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
3431 -- raise Storage_Error;
3432 -- end if;
3434 -- where 3.5 gigabytes is a constant large enough to accomodate any
3435 -- reasonable request for. But we can't do it this way because at
3436 -- least at the moment we don't compute this attribute right, and
3437 -- can silently give wrong results when the result gets large. Since
3438 -- this is all about large results, that's bad, so instead we only
3439 -- apply the check for constrained arrays, and manually compute the
3440 -- value of the attribute ???
3445 Condition =>
3448 Right_Opnd =>
3455 -- Handle case of qualified expression (other than optimization above)
3456 -- First apply constraint checks, because the bounds or discriminants
3457 -- in the aggregate might not match the subtype mark in the allocator.
3460 Apply_Constraint_Check
3467 -- If the allocator is for a type which requires initialization, and
3468 -- there is no initial value (i.e. operand is a subtype indication
3469 -- rather than a qualified expression), then we must generate a call to
3470 -- the initialization routine using an expressions action node:
3472 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3474 -- Here ptr_T is the pointer type for the allocator, and T is the
3475 -- subtype of the allocator. A special case arises if the designated
3476 -- type of the access type is a task or contains tasks. In this case
3477 -- the call to Init (Temp.all ...) is replaced by code that ensures
3478 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3479 -- for details). In addition, if the type T is a task T, then the
3480 -- first argument to Init must be converted to the task record type.
3482 declare
3495 begin
3499 -- Case of no initialization procedure present
3503 -- Case of simple initialization required
3517 -- No initialization required
3519 else
3523 -- Case of initialization procedure present, must be called
3525 else
3533 -- Construct argument list for the initialization routine call
3535 Arg1 :=
3541 -- The initialization procedure expects a specific type. if the
3542 -- context is access to class wide, indicate that the object
3543 -- being allocated has the right specific type.
3549 -- If designated type is a concurrent type or if it is private
3550 -- type whose definition is a concurrent type, the first
3551 -- argument in the Init routine has to be unchecked conversion
3552 -- to the corresponding record type. If the designated type is
3553 -- a derived type, we also convert the argument to its root
3554 -- type.
3557 Arg1 :=
3563 then
3564 Arg1 :=
3565 Unchecked_Convert_To
3569 declare
3571 begin
3579 -- For the task case, pass the Master_Id of the access type as
3580 -- the value of the _Master parameter, and _Chain as the value
3581 -- of the _Chain parameter (_Chain will be defined as part of
3582 -- the generated code for the allocator).
3584 -- In Ada 2005, the context may be a function that returns an
3585 -- anonymous access type. In that case the Master_Id has been
3586 -- created when expanding the function declaration.
3591 -- If we have a non-library level task with restriction
3592 -- No_Task_Hierarchy set, then no point in expanding.
3596 then
3600 -- The designated type was an incomplete type, and the
3601 -- access type did not get expanded. Salvage it now.
3604 Expand_N_Full_Type_Declaration
3608 -- If the context of the allocator is a declaration or an
3609 -- assignment, we can generate a meaningful image for it,
3610 -- even though subsequent assignments might remove the
3611 -- connection between task and entity. We build this image
3612 -- when the left-hand side is a simple variable, a simple
3613 -- indexed assignment or a simple selected component.
3616 declare
3619 begin
3621 Decls :=
3622 Build_Task_Image_Decls
3624 New_Occurrence_Of
3627 elsif Nkind_In
3630 then
3631 Decls :=
3632 Build_Task_Image_Decls
3634 else
3640 Decls :=
3641 Build_Task_Image_Decls
3644 else
3649 New_Reference_To
3657 -- Has_Task is false, Decls not used
3659 else
3663 -- Add discriminants if discriminated type
3665 declare
3669 begin
3677 then
3684 -- If the allocated object will be constrained by the
3685 -- default values for discriminants, then build a subtype
3686 -- with those defaults, and change the allocated subtype
3687 -- to that. Note that this happens in fewer cases in Ada
3688 -- 2005 (AI-363).
3694 or else
3696 then
3706 -- AI-416: when the discriminant constraint is an
3707 -- anonymous access type make sure an accessibility
3708 -- check is inserted if necessary (3.10.2(22.q/2))
3711 and then
3713 then
3714 Apply_Accessibility_Check
3723 -- We set the allocator as analyzed so that when we analyze the
3724 -- expression actions node, we do not get an unwanted recursive
3725 -- expansion of the allocator expression.
3730 -- Here is the transformation:
3731 -- input: new T
3732 -- output: Temp : constant ptr_T := new T;
3733 -- Init (Temp.all, ...);
3734 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
3735 -- <CTRL> Initialize (Finalizable (Temp.all));
3737 -- Here ptr_T is the pointer type for the allocator, and is the
3738 -- subtype of the allocator.
3740 Temp_Decl :=
3750 -- If the designated type is a task type or contains tasks,
3751 -- create block to activate created tasks, and insert
3752 -- declaration for Task_Image variable ahead of call.
3755 declare
3758 begin
3765 else
3774 -- Postpone the generation of a finalization call for the
3775 -- current allocator if it acts as a coextension.
3784 else
3785 Flist :=
3788 -- Anonymous access types created for access parameters
3789 -- are attached to an explicitly constructed controller,
3790 -- which ensures that they can be finalized properly,
3791 -- even if their deallocation might not happen. The list
3792 -- associated with the controller is doubly-linked. For
3793 -- other anonymous access types, the object may end up
3794 -- on the global final list which is singly-linked.
3795 -- Work needed for access discriminants in Ada 2005 ???
3799 else
3804 Make_Init_Call (
3819 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
3820 -- object that has been rewritten as a reference, we displace "this"
3821 -- to reference properly its secondary dispatch table.
3825 then
3829 exception
3834 -----------------------
3835 -- Expand_N_And_Then --
3836 -----------------------
3838 -- Expand into conditional expression if Actions present, and also deal
3839 -- with optimizing case of arguments being True or False.
3848 begin
3849 -- Deal with non-standard booleans
3857 -- Check for cases where left argument is known to be True or False
3861 -- If left argument is True, change (True and then Right) to Right.
3862 -- Any actions associated with Right will be executed unconditionally
3863 -- and can thus be inserted into the tree unconditionally.
3872 -- If left argument is False, change (False and then Right) to False.
3873 -- In this case we can forget the actions associated with Right,
3874 -- since they will never be executed.
3886 -- If Actions are present, we expand
3888 -- left and then right
3890 -- into
3892 -- if left then right else false end
3894 -- with the actions becoming the Then_Actions of the conditional
3895 -- expression. This conditional expression is then further expanded
3896 -- (and will eventually disappear)
3903 Left,
3904 Right,
3913 -- No actions present, check for cases of right argument True/False
3917 -- Change (Left and then True) to Left. Note that we know there are
3918 -- no actions associated with the True operand, since we just checked
3919 -- for this case above.
3924 -- Change (Left and then False) to False, making sure to preserve any
3925 -- side effects associated with the Left operand.
3929 Rewrite
3937 -------------------------------------
3938 -- Expand_N_Conditional_Expression --
3939 -------------------------------------
3941 -- Expand into expression actions if then/else actions present
3952 begin
3953 -- If either then or else actions are present, then given:
3955 -- if cond then then-expr else else-expr end
3957 -- we insert the following sequence of actions (using Insert_Actions):
3959 -- Cnn : typ;
3960 -- if cond then
3961 -- <<then actions>>
3962 -- Cnn := then-expr;
3963 -- else
3964 -- <<else actions>>
3965 -- Cnn := else-expr
3966 -- end if;
3968 -- and replace the conditional expression by a reference to Cnn
3973 New_If :=
3987 -- Move the SLOC of the parent If statement to the newly created
3988 -- one and change it to the SLOC of the expression which, after
3989 -- expansion, will correspond to what is being evaluated.
3993 then
4002 Insert_List_Before
4007 Insert_List_Before
4023 -----------------------------------
4024 -- Expand_N_Explicit_Dereference --
4025 -----------------------------------
4028 begin
4029 -- Insert explicit dereference call for the checked storage pool case
4034 -----------------
4035 -- Expand_N_In --
4036 -----------------
4046 -- Replaces node N by Lop'Valid. This is done when we have an explicit
4047 -- test for the left operand being in range of its subtype.
4049 ----------------------------
4050 -- Substitute_Valid_Check --
4051 ----------------------------
4054 begin
4067 -- Start of processing for Expand_N_In
4069 begin
4070 -- Check case of explicit test for an expression in range of its
4071 -- subtype. This is suspicious usage and we replace it with a 'Valid
4072 -- test and give a warning.
4079 then
4080 Substitute_Valid_Check;
4084 -- Do validity check on operands
4091 -- Case of explicit range
4094 declare
4107 Constant_Condition_Warnings
4110 -- This must be true for any of the optimization warnings, we
4111 -- clearly want to give them only for source with the flag on.
4112 -- We also skip these warnings in an instance since it may be
4113 -- the case that different instantiations have different ranges.
4116 Warn1
4119 -- For the case where only one bound warning is elided, we also
4120 -- insist on an explicit range and an integer type. The reason is
4121 -- that the use of enumeration ranges including an end point is
4122 -- common, as is the use of a subtype name, one of whose bounds
4123 -- is the same as the type of the expression.
4125 begin
4126 -- If test is explicit x'first .. x'last, replace by valid check
4139 then
4140 Substitute_Valid_Check;
4144 -- If bounds of type are known at compile time, and the end points
4145 -- are known at compile time and identical, this is another case
4146 -- for substituting a valid test. We only do this for discrete
4147 -- types, since it won't arise in practice for float types.
4158 -- Kill warnings in instances, since they may be cases where we
4159 -- have a test in the generic that makes sense with some types
4160 -- and not with other types.
4162 and then not In_Instance
4163 then
4164 Substitute_Valid_Check;
4168 -- If we have an explicit range, do a bit of optimization based
4169 -- on range analysis (we may be able to kill one or both checks).
4174 -- If either check is known to fail, replace result by False since
4175 -- the other check does not matter. Preserve the static flag for
4176 -- legality checks, because we are constant-folding beyond RM 4.9.
4191 -- If both checks are known to succeed, replace result by True,
4192 -- since we know we are in range.
4207 -- If lower bound check succeeds and upper bound check is not
4208 -- known to succeed or fail, then replace the range check with
4209 -- a comparison against the upper bound.
4225 -- If upper bound check succeeds and lower bound check is not
4226 -- known to succeed or fail, then replace the range check with
4227 -- a comparison against the lower bound.
4244 -- We couldn't optimize away the range check, but there is one
4245 -- more issue. If we are checking constant conditionals, then we
4246 -- see if we can determine the outcome assuming everything is
4247 -- valid, and if so give an appropriate warning.
4253 -- Result is out of range for valid value
4256 Error_Msg_N
4259 -- Result is in range for valid value
4262 Error_Msg_N
4265 -- Lower bound check succeeds if value is valid
4268 Error_Msg_N
4271 -- Upper bound check succeeds if value is valid
4274 Error_Msg_N
4280 -- For all other cases of an explicit range, nothing to be done
4284 -- Here right operand is a subtype mark
4286 else
4287 declare
4293 begin
4296 -- For tagged type, do tagged membership operation
4300 -- No expansion will be performed when VM_Target, as the VM
4301 -- back-ends will handle the membership tests directly (tags
4302 -- are not explicitly represented in Java objects, so the
4303 -- normal tagged membership expansion is not what we want).
4312 -- If type is scalar type, rewrite as x in t'first .. t'last.
4313 -- This reason we do this is that the bounds may have the wrong
4314 -- type if they come from the original type definition. Also this
4315 -- way we get all the processing above for an explicit range.
4320 Low_Bound =>
4325 High_Bound =>
4332 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4333 -- a membership test if the subtype mark denotes a constrained
4334 -- Unchecked_Union subtype and the expression lacks inferable
4335 -- discriminants.
4340 then
4345 -- Prevent Gigi from generating incorrect code by rewriting
4346 -- the test as a standard False.
4354 -- Here we have a non-scalar type
4365 -- For the constrained array case, we have to check the subscripts
4366 -- for an exact match if the lengths are non-zero (the lengths
4367 -- must match in any case).
4372 function Construct_Attribute_Reference
4376 -- Build attribute reference E'Nam(Dim)
4378 -----------------------------------
4379 -- Construct_Attribute_Reference --
4380 -----------------------------------
4382 function Construct_Attribute_Reference
4386 is
4387 begin
4388 return
4396 -- Start of processing for Check_Subscripts
4398 begin
4402 Left_Opnd =>
4403 Construct_Attribute_Reference
4406 Right_Opnd =>
4407 Construct_Attribute_Reference
4412 Left_Opnd =>
4413 Construct_Attribute_Reference
4416 Right_Opnd =>
4417 Construct_Attribute_Reference
4422 Cond :=
4424 Left_Opnd =>
4435 -- These are the cases where constraint checks may be required,
4436 -- e.g. records with possible discriminants
4438 else
4439 -- Expand the test into a series of discriminant comparisons.
4440 -- The expression that is built is the negation of the one that
4441 -- is used for checking discriminant constraints.
4451 Left_Opnd =>
4458 else
4469 --------------------------------
4470 -- Expand_N_Indexed_Component --
4471 --------------------------------
4479 begin
4480 -- A special optimization, if we have an indexed component that is
4481 -- selecting from a slice, then we can eliminate the slice, since, for
4482 -- example, x (i .. j)(k) is identical to x(k). The only difference is
4483 -- the range check required by the slice. The range check for the slice
4484 -- itself has already been generated. The range check for the
4485 -- subscripting operation is ensured by converting the subject to
4486 -- the subtype of the slice.
4488 -- This optimization not only generates better code, avoiding slice
4489 -- messing especially in the packed case, but more importantly bypasses
4490 -- some problems in handling this peculiar case, for example, the issue
4491 -- of dealing specially with object renamings.
4498 Convert_To
4505 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
4506 -- function, then additional actuals must be passed.
4510 then
4514 -- If the prefix is an access type, then we unconditionally rewrite if
4515 -- as an explicit deference. This simplifies processing for several
4516 -- cases, including packed array cases and certain cases in which checks
4517 -- must be generated. We used to try to do this only when it was
4518 -- necessary, but it cleans up the code to do it all the time.
4525 -- Generate index and validity checks
4533 -- All done for the non-packed case
4539 -- For packed arrays that are not bit-packed (i.e. the case of an array
4540 -- with one or more index types with a non-contiguous enumeration type),
4541 -- we can always use the normal packed element get circuit.
4548 -- For a reference to a component of a bit packed array, we have to
4549 -- convert it to a reference to the corresponding Packed_Array_Type.
4550 -- We only want to do this for simple references, and not for:
4552 -- Left side of assignment, or prefix of left side of assignment, or
4553 -- prefix of the prefix, to handle packed arrays of packed arrays,
4554 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4556 -- Renaming objects in renaming associations
4557 -- This case is handled when a use of the renamed variable occurs
4559 -- Actual parameters for a procedure call
4560 -- This case is handled in Exp_Ch6.Expand_Actuals
4562 -- The second expression in a 'Read attribute reference
4564 -- The prefix of an address or size attribute reference
4566 -- The following circuit detects these exceptions
4568 declare
4572 begin
4573 loop
4578 N_Procedure_Call_Statement)
4580 and then
4582 then
4587 or else
4590 then
4595 then
4598 -- If the expression is an index of an indexed component, it must
4599 -- be expanded regardless of context.
4603 then
4609 then
4615 then
4620 then
4623 else
4628 -- Keep looking up tree for unchecked expression, or if we are the
4629 -- prefix of a possible assignment left side.
4637 ---------------------
4638 -- Expand_N_Not_In --
4639 ---------------------
4641 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
4642 -- can be done. This avoids needing to duplicate this expansion code.
4649 begin
4652 Right_Opnd =>
4657 -- We want this to appear as coming from source if original does (see
4658 -- transformations in Expand_N_In).
4663 -- Now analyze transformed node
4668 -------------------
4669 -- Expand_N_Null --
4670 -------------------
4672 -- The only replacement required is for the case of a null of type that is
4673 -- an access to protected subprogram. We represent such access values as a
4674 -- record, and so we must replace the occurrence of null by the equivalent
4675 -- record (with a null address and a null pointer in it), so that the
4676 -- backend creates the proper value.
4683 begin
4685 Agg :=
4694 -- For subsequent semantic analysis, the node must retain its type.
4695 -- Gigi in any case replaces this type by the corresponding record
4696 -- type before processing the node.
4701 exception
4706 ---------------------
4707 -- Expand_N_Op_Abs --
4708 ---------------------
4714 begin
4717 -- Deal with software overflow checking
4719 if not Backend_Overflow_Checks_On_Target
4722 then
4723 -- The only case to worry about is when the argument is equal to the
4724 -- largest negative number, so what we do is to insert the check:
4726 -- [constraint_error when Expr = typ'Base'First]
4728 -- with the usual Duplicate_Subexpr use coding for expr
4732 Condition =>
4735 Right_Opnd =>
4737 Prefix =>
4743 -- Vax floating-point types case
4750 ---------------------
4751 -- Expand_N_Op_Add --
4752 ---------------------
4757 begin
4760 -- N + 0 = 0 + N = N for integer types
4765 then
4771 then
4777 -- Arithmetic overflow checks for signed integer/fixed point types
4781 then
4785 -- Vax floating-point types case
4792 ---------------------
4793 -- Expand_N_Op_And --
4794 ---------------------
4799 begin
4813 ------------------------
4814 -- Expand_N_Op_Concat --
4815 ------------------------
4819 -- List of operands to be concatenated
4822 -- Node which is to be replaced by the result of concatenating the nodes
4823 -- in the list Opnds.
4825 begin
4826 -- Ensure validity of both operands
4830 -- If we are the left operand of a concatenation higher up the tree,
4831 -- then do nothing for now, since we want to deal with a series of
4832 -- concatenations as a unit.
4836 then
4840 -- We get here with a concatenation whose left operand may be a
4841 -- concatenation itself with a consistent type. We need to process
4842 -- these concatenation operands from left to right, which means
4843 -- from the deepest node in the tree to the highest node.
4850 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
4851 -- nodes above, so now we process bottom up, doing the operations. We
4852 -- gather a string that is as long as possible up to five operands
4854 -- The outer loop runs more than once if more than one concatenation
4855 -- type is involved.
4861 -- The inner loop gathers concatenation operands
4866 loop
4878 ------------------------
4879 -- Expand_N_Op_Divide --
4880 ------------------------
4890 and then
4894 begin
4901 -- N / 1 = N for integer types
4908 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
4909 -- Is_Power_Of_2_For_Shift is set means that we know that our left
4910 -- operand is an unsigned integer, as required for this to work.
4915 -- We cannot do this transformation in configurable run time mode if we
4916 -- have 64-bit -- integers and long shifts are not available.
4918 and then
4921 then
4925 Right_Opnd =>
4931 -- Do required fixup of universal fixed operation
4938 -- Divisions with fixed-point results
4942 -- No special processing if Treat_Fixed_As_Integer is set, since
4943 -- from a semantic point of view such operations are simply integer
4944 -- operations and will be treated that way.
4949 else
4954 -- Other cases of division of fixed-point operands. Again we exclude the
4955 -- case where Treat_Fixed_As_Integer is set.
4960 then
4963 else
4968 -- Mixed-mode operations can appear in a non-static universal context,
4969 -- in which case the integer argument must be converted explicitly.
4973 then
4981 then
4987 -- Non-fixed point cases, do integer zero divide and overflow checks
4992 -- Check for 64-bit division available, or long shifts if the divisor
4993 -- is a small power of 2 (since such divides will be converted into
4994 -- long shifts).
4997 and then not Support_64_Bit_Divides_On_Target
4998 and then
5000 or else not Support_Long_Shifts_On_Target
5007 then
5011 -- Deal with Vax_Float
5019 --------------------
5020 -- Expand_N_Op_Eq --
5021 --------------------
5036 -- If a constructed equality exists for the type or for its parent,
5037 -- build and analyze call, adding conversions if the operation is
5038 -- inherited.
5041 -- Determines whether a type has a subcomponent of an unconstrained
5042 -- Unchecked_Union subtype. Typ is a record type.
5044 -------------------------
5045 -- Build_Equality_Call --
5046 -------------------------
5053 begin
5056 then
5061 -- If we have an Unchecked_Union, we need to add the inferred
5062 -- discriminant values as actuals in the function call. At this
5063 -- point, the expansion has determined that both operands have
5064 -- inferable discriminants.
5067 declare
5073 begin
5074 -- Per-object constrained selected components require special
5075 -- attention. If the enclosing scope of the component is an
5076 -- Unchecked_Union, we cannot reference its discriminants
5077 -- directly. This is why we use the two extra parameters of
5078 -- the equality function of the enclosing Unchecked_Union.
5080 -- type UU_Type (Discr : Integer := 0) is
5081 -- . . .
5082 -- end record;
5083 -- pragma Unchecked_Union (UU_Type);
5085 -- 1. Unchecked_Union enclosing record:
5087 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
5088 -- . . .
5089 -- Comp : UU_Type (Discr);
5090 -- . . .
5091 -- end Enclosing_UU_Type;
5092 -- pragma Unchecked_Union (Enclosing_UU_Type);
5094 -- Obj1 : Enclosing_UU_Type;
5095 -- Obj2 : Enclosing_UU_Type (1);
5097 -- [. . .] Obj1 = Obj2 [. . .]
5099 -- Generated code:
5101 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
5103 -- A and B are the formal parameters of the equality function
5104 -- of Enclosing_UU_Type. The function always has two extra
5105 -- formals to capture the inferred discriminant values.
5107 -- 2. Non-Unchecked_Union enclosing record:
5109 -- type
5110 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
5111 -- is record
5112 -- . . .
5113 -- Comp : UU_Type (Discr);
5114 -- . . .
5115 -- end Enclosing_Non_UU_Type;
5117 -- Obj1 : Enclosing_Non_UU_Type;
5118 -- Obj2 : Enclosing_Non_UU_Type (1);
5120 -- ... Obj1 = Obj2 ...
5122 -- Generated code:
5124 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
5125 -- obj1.discr, obj2.discr)) then
5127 -- In this case we can directly reference the discriminants of
5128 -- the enclosing record.
5130 -- Lhs of equality
5133 and then Has_Per_Object_Constraint
5135 then
5136 -- Enclosing record is an Unchecked_Union, use formal A
5140 then
5141 Lhs_Discr_Val :=
5145 -- Enclosing record is of a non-Unchecked_Union type, it is
5146 -- possible to reference the discriminant.
5148 else
5149 Lhs_Discr_Val :=
5152 Selector_Name =>
5153 New_Copy
5154 (Get_Discriminant_Value
5156 Lhs_Type,
5160 -- Comment needed here ???
5162 else
5163 -- Infer the discriminant value
5165 Lhs_Discr_Val :=
5166 New_Copy
5167 (Get_Discriminant_Value
5169 Lhs_Type,
5173 -- Rhs of equality
5176 and then Has_Per_Object_Constraint
5178 then
5179 if Is_Unchecked_Union
5181 then
5182 Rhs_Discr_Val :=
5186 else
5187 Rhs_Discr_Val :=
5190 Selector_Name =>
5193 Rhs_Type,
5197 else
5198 Rhs_Discr_Val :=
5201 Rhs_Type,
5210 L_Exp,
5211 R_Exp,
5212 Lhs_Discr_Val,
5213 Rhs_Discr_Val)));
5216 -- Normal case, not an unchecked union
5218 else
5228 ------------------------------------
5229 -- Has_Unconstrained_UU_Component --
5230 ------------------------------------
5232 function Has_Unconstrained_UU_Component
5234 is
5240 function Component_Is_Unconstrained_UU
5242 -- Determines whether the subtype of the component is an
5243 -- unconstrained Unchecked_Union.
5245 function Variant_Is_Unconstrained_UU
5247 -- Determines whether a component of the variant has an unconstrained
5248 -- Unchecked_Union subtype.
5250 -----------------------------------
5251 -- Component_Is_Unconstrained_UU --
5252 -----------------------------------
5254 function Component_Is_Unconstrained_UU
5256 is
5257 begin
5262 declare
5266 begin
5267 -- Unconstrained nominal type. In the case of a constraint
5268 -- present, the node kind would have been N_Subtype_Indication.
5278 ---------------------------------
5279 -- Variant_Is_Unconstrained_UU --
5280 ---------------------------------
5282 function Variant_Is_Unconstrained_UU
5284 is
5287 begin
5292 -- We only need to test one component
5294 declare
5297 begin
5307 -- None of the components withing the variant were of
5308 -- unconstrained Unchecked_Union type.
5313 -- Start of processing for Has_Unconstrained_UU_Component
5315 begin
5323 -- Inspect available components
5326 declare
5329 begin
5332 -- One component is sufficient
5343 -- Inspect available components withing variants
5346 declare
5349 begin
5352 -- One component within a variant is sufficient
5363 -- Neither the available components, nor the components inside the
5364 -- variant parts were of an unconstrained Unchecked_Union subtype.
5369 -- Start of processing for Expand_N_Op_Eq
5371 begin
5378 else
5382 -- It may happen in error situations that the underlying type is not
5383 -- set. The error will be detected later, here we just defend the
5384 -- expander code.
5392 -- Boolean types (requiring handling of non-standard case)
5400 -- Array types
5404 -- If we are doing full validity checking, and it is possible for the
5405 -- array elements to be invalid then expand out array comparisons to
5406 -- make sure that we check the array elements.
5408 if Validity_Check_Operands
5410 then
5411 declare
5413 Force_Validity_Checks;
5414 begin
5417 Expand_Array_Equality
5421 Bodies,
5422 Typl));
5428 -- Packed case where both operands are known aligned
5433 then
5436 -- Where the component type is elementary we can use a block bit
5437 -- comparison (if supported on the target) exception in the case
5438 -- of floating-point (negative zero issues require element by
5439 -- element comparison), and atomic types (where we must be sure
5440 -- to load elements independently) and possibly unaligned arrays.
5447 and then Support_Composite_Compare_On_Target
5448 then
5451 -- For composite and floating-point cases, expand equality loop to
5452 -- make sure of using proper comparisons for tagged types, and
5453 -- correctly handling the floating-point case.
5455 else
5457 Expand_Array_Equality
5461 Bodies,
5462 Typl));
5467 -- Record Types
5471 -- For tagged types, use the primitive "="
5475 -- No need to do anything else compiling under restriction
5476 -- No_Dispatching_Calls. During the semantic analysis we
5477 -- already notified such violation.
5483 -- If this is derived from an untagged private type completed with
5484 -- a tagged type, it does not have a full view, so we use the
5485 -- primitive operations of the private type. This check should no
5486 -- longer be necessary when these types get their full views???
5492 then
5493 -- Search for equality operation, checking that the operands
5494 -- have the same type. Note that we must find a matching entry,
5495 -- or something is very wrong!
5503 and then
5512 -- Find the type's predefined equality or an overriding
5513 -- user- defined equality. The reason for not simply calling
5514 -- Find_Prim_Op here is that there may be a user-defined
5515 -- overloaded equality op that precedes the equality that we want,
5516 -- so we have to explicitly search (e.g., there could be an
5517 -- equality with two different parameter types).
5519 else
5529 and then
5541 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
5542 -- predefined equality operator for a type which has a subcomponent
5543 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
5550 -- Prevent Gigi from generating incorrect code by rewriting the
5551 -- equality as a standard False.
5558 -- If we can infer the discriminants of the operands, we make a
5559 -- call to the TSS equality function.
5562 and then
5564 then
5565 Build_Equality_Call
5568 else
5569 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5570 -- the predefined equality operator for an Unchecked_Union type
5571 -- if either of the operands lack inferable discriminants.
5577 -- Prevent Gigi from generating incorrect code by rewriting
5578 -- the equality as a standard False.
5585 -- If a type support function is present (for complex cases), use it
5588 Build_Equality_Call
5591 -- Otherwise expand the component by component equality. Note that
5592 -- we never use block-bit comparisons for records, because of the
5593 -- problems with gaps. The backend will often be able to recombine
5594 -- the separate comparisons that we generate here.
5596 else
5607 -- Test if result is known at compile time
5611 -- If we still have comparison for Vax_Float, process it
5619 -----------------------
5620 -- Expand_N_Op_Expon --
5621 -----------------------
5639 begin
5642 -- If either operand is of a private type, then we have the use of an
5643 -- intrinsic operator, and we get rid of the privateness, by using root
5644 -- types of underlying types for the actual operation. Otherwise the
5645 -- private types will cause trouble if we expand multiplications or
5646 -- shifts etc. We also do this transformation if the result type is
5647 -- different from the base type.
5650 or else
5652 or else
5654 or else
5656 then
5657 declare
5661 begin
5672 -- Test for case of known right argument
5677 -- We only fold small non-negative exponents. You might think we
5678 -- could fold small negative exponents for the real case, but we
5679 -- can't because we are required to raise Constraint_Error for
5680 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
5681 -- See ACVC test C4A012B.
5685 -- X ** 0 = 1 (or 1.0)
5689 -- Call Remove_Side_Effects to ensure that any side effects
5690 -- in the ignored left operand (in particular function calls
5691 -- to user defined functions) are properly executed.
5697 else
5701 -- X ** 1 = X
5706 -- X ** 2 = X * X
5709 Xnode :=
5714 -- X ** 3 = X * X * X
5717 Xnode :=
5719 Left_Opnd =>
5725 -- X ** 4 ->
5726 -- En : constant base'type := base * base;
5727 -- ...
5728 -- En * En
5731 Temp :=
5739 Expression =>
5744 Xnode :=
5756 -- Case of (2 ** expression) appearing as an argument of an integer
5757 -- multiplication, or as the right argument of a division of a non-
5758 -- negative integer. In such cases we leave the node untouched, setting
5759 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
5760 -- of the higher level node converts it into a shift.
5762 -- Note: this transformation is not applicable for a modular type with
5763 -- a non-binary modulus in the multiplication case, since we get a wrong
5764 -- result if the shift causes an overflow before the modular reduction.
5771 and then not Ovflo
5773 then
5774 declare
5779 begin
5782 and then
5784 or else
5788 or else
5794 then
5801 -- Fall through if exponentiation must be done using a runtime routine
5803 -- First deal with modular case
5807 -- Non-binary case, we call the special exponentiation routine for
5808 -- the non-binary case, converting the argument to Long_Long_Integer
5809 -- and passing the modulus value. Then the result is converted back
5810 -- to the base type.
5820 Exp))));
5822 -- Binary case, in this case, we call one of two routines, either the
5823 -- unsigned integer case, or the unsigned long long integer case,
5824 -- with a final "and" operation to do the required mod.
5826 else
5829 else
5836 Left_Opnd =>
5841 Exp)),
5842 Right_Opnd =>
5847 -- Common exit point for modular type case
5852 -- Signed integer cases, done using either Integer or Long_Long_Integer.
5853 -- It is not worth having routines for Short_[Short_]Integer, since for
5854 -- most machines it would not help, and it would generate more code that
5855 -- might need certification when a certified run time is required.
5857 -- In the integer cases, we have two routines, one for when overflow
5858 -- checks are required, and one when they are not required, since there
5859 -- is a real gain in omitting checks on many machines.
5863 and then
5866 then
5871 else
5880 else
5884 -- Floating-point cases, always done using Long_Long_Float. We do not
5885 -- need separate routines for the overflow case here, since in the case
5886 -- of floating-point, we generate infinities anyway as a rule (either
5887 -- that or we automatically trap overflow), and if there is an infinity
5888 -- generated and a range check is required, the check will fail anyway.
5890 else
5896 -- Common processing for integer cases and floating-point cases.
5897 -- If we are in the right type, we can call runtime routine directly
5902 then
5908 -- Otherwise we have to introduce conversions (conversions are also
5909 -- required in the universal cases, since the runtime routine is
5910 -- typed using one of the standard types).
5912 else
5919 Exp))));
5925 exception
5930 --------------------
5931 -- Expand_N_Op_Ge --
5932 --------------------
5940 begin
5957 -- If we still have comparison, and Vax_Float type, process it
5965 --------------------
5966 -- Expand_N_Op_Gt --
5967 --------------------
5975 begin
5992 -- If we still have comparison, and Vax_Float type, process it
6000 --------------------
6001 -- Expand_N_Op_Le --
6002 --------------------
6010 begin
6027 -- If we still have comparison, and Vax_Float type, process it
6035 --------------------
6036 -- Expand_N_Op_Lt --
6037 --------------------
6045 begin
6062 -- If we still have comparison, and Vax_Float type, process it
6070 -----------------------
6071 -- Expand_N_Op_Minus --
6072 -----------------------
6078 begin
6081 if not Backend_Overflow_Checks_On_Target
6084 then
6085 -- Software overflow checking expands -expr into (0 - expr)
6094 -- Vax floating-point types case
6101 ---------------------
6102 -- Expand_N_Op_Mod --
6103 ---------------------
6123 begin
6129 -- Convert mod to rem if operands are known non-negative. We do this
6130 -- since it is quite likely that this will improve the quality of code,
6131 -- (the operation now corresponds to the hardware remainder), and it
6132 -- does not seem likely that it could be harmful.
6135 and then
6137 then
6143 -- Instead of reanalyzing the node we do the analysis manually. This
6144 -- avoids anomalies when the replacement is done in an instance and
6145 -- is epsilon more efficient.
6154 -- Otherwise, normal mod processing
6156 else
6161 -- Apply optimization x mod 1 = 0. We don't really need that with
6162 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
6163 -- certainly harmless.
6168 then
6169 -- Call Remove_Side_Effects to ensure that any side effects in
6170 -- the ignored left operand (in particular function calls to
6171 -- user defined functions) are properly executed.
6180 -- Deal with annoying case of largest negative number remainder
6181 -- minus one. Gigi does not handle this case correctly, because
6182 -- it generates a divide instruction which may trap in this case.
6184 -- In fact the check is quite easy, if the right operand is -1, then
6185 -- the mod value is always 0, and we can just ignore the left operand
6186 -- completely in this case.
6188 -- The operand type may be private (e.g. in the expansion of an
6189 -- intrinsic operation) so we must use the underlying type to get the
6190 -- bounds, and convert the literals explicitly.
6192 LLB :=
6193 Expr_Value
6197 and then
6199 then
6205 Right_Opnd =>
6218 --------------------------
6219 -- Expand_N_Op_Multiply --
6220 --------------------------
6239 begin
6242 -- Special optimizations for integer types
6246 -- N * 0 = 0 for integer types
6250 then
6251 -- Call Remove_Side_Effects to ensure that any side effects in
6252 -- the ignored left operand (in particular function calls to
6253 -- user defined functions) are properly executed.
6262 -- Similar handling for 0 * N = 0
6266 then
6273 -- N * 1 = 1 * N = N for integer types
6275 -- This optimisation is not done if we are going to
6276 -- rewrite the product 1 * 2 ** N to a shift.
6280 and then not Lp2
6281 then
6287 and then not Rp2
6288 then
6294 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
6295 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6296 -- operand is an integer, as required for this to work.
6301 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
6306 Right_Opnd =>
6313 else
6317 Right_Opnd =>
6323 -- Same processing for the operands the other way round
6329 Right_Opnd =>
6335 -- Do required fixup of universal fixed operation
6342 -- Multiplications with fixed-point results
6346 -- No special processing if Treat_Fixed_As_Integer is set, since from
6347 -- a semantic point of view such operations are simply integer
6348 -- operations and will be treated that way.
6352 -- Case of fixed * integer => fixed
6357 -- Case of integer * fixed => fixed
6362 -- Case of fixed * fixed => fixed
6364 else
6369 -- Other cases of multiplication of fixed-point operands. Again we
6370 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
6374 then
6377 else
6382 -- Mixed-mode operations can appear in a non-static universal context,
6383 -- in which case the integer argument must be converted explicitly.
6387 then
6394 then
6399 -- Non-fixed point cases, check software overflow checking required
6404 -- Deal with VAX float case
6412 --------------------
6413 -- Expand_N_Op_Ne --
6414 --------------------
6419 begin
6420 -- Case of elementary type with standard operator
6424 then
6427 -- Boolean types (requiring handling of non-standard case)
6438 -- If we still have comparison for Vax_Float, process it
6445 -- For all cases other than elementary types, we rewrite node as the
6446 -- negation of an equality operation, and reanalyze. The equality to be
6447 -- used is defined in the same scope and has the same signature. This
6448 -- signature must be set explicitly since in an instance it may not have
6449 -- the same visibility as in the generic unit. This avoids duplicating
6450 -- or factoring the complex code for record/array equality tests etc.
6452 else
6453 declare
6458 begin
6461 Neg :=
6463 Right_Opnd =>
6473 -- For navigation purposes, the inequality is treated as an
6474 -- implicit reference to the corresponding equality. Preserve the
6475 -- Comes_From_ source flag so that the proper Xref entry is
6476 -- generated.
6486 ---------------------
6487 -- Expand_N_Op_Not --
6488 ---------------------
6490 -- If the argument is other than a Boolean array type, there is no special
6491 -- expansion required.
6493 -- For the packed case, we call the special routine in Exp_Pakd, except
6494 -- that if the component size is greater than one, we use the standard
6495 -- routine generating a gruesome loop (it is so peculiar to have packed
6496 -- arrays with non-standard Boolean representations anyway, so it does not
6497 -- matter that we do not handle this case efficiently).
6499 -- For the unpacked case (and for the special packed case where we have non
6500 -- standard Booleans, as discussed above), we generate and insert into the
6501 -- tree the following function definition:
6503 -- function Nnnn (A : arr) is
6504 -- B : arr;
6505 -- begin
6506 -- for J in a'range loop
6507 -- B (J) := not A (J);
6508 -- end loop;
6509 -- return B;
6510 -- end Nnnn;
6512 -- Here arr is the actual subtype of the parameter (and hence always
6513 -- constrained). Then we replace the not with a call to this function.
6529 begin
6532 -- For boolean operand, deal with non-standard booleans
6541 -- Only array types need any other processing
6547 -- Case of array operand. If bit packed with a component size of 1,
6548 -- handle it in Exp_Pakd if the operand is known to be aligned.
6553 then
6558 -- Case of array operand which is not bit-packed. If the context is
6559 -- a safe assignment, call in-place operation, If context is a larger
6560 -- boolean expression in the context of a safe assignment, expansion is
6561 -- done by enclosing operation.
6574 -- Special case the negation of a binary operation
6577 and then Safe_In_Place_Array_Op
6579 then
6586 then
6587 declare
6592 begin
6596 then
6597 -- (not A) op (not B) can be reduced to a single call
6603 then
6604 -- A xor (not B) can also be special-cased
6616 A_J :=
6621 B_J :=
6626 Loop_Statement :=
6630 Iteration_Scheme =>
6632 Loop_Parameter_Specification =>
6635 Discrete_Subtype_Definition =>
6650 Specification =>
6664 Handled_Statement_Sequence =>
6667 Loop_Statement,
6669 Expression =>
6680 --------------------
6681 -- Expand_N_Op_Or --
6682 --------------------
6687 begin
6701 ----------------------
6702 -- Expand_N_Op_Plus --
6703 ----------------------
6706 begin
6710 ---------------------
6711 -- Expand_N_Op_Rem --
6712 ---------------------
6731 begin
6738 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
6739 -- but it is useful with other back ends (e.g. AAMP), and is certainly
6740 -- harmless.
6745 then
6746 -- Call Remove_Side_Effects to ensure that any side effects in the
6747 -- ignored left operand (in particular function calls to user defined
6748 -- functions) are properly executed.
6757 -- Deal with annoying case of largest negative number remainder minus
6758 -- one. Gigi does not handle this case correctly, because it generates
6759 -- a divide instruction which may trap in this case.
6761 -- In fact the check is quite easy, if the right operand is -1, then
6762 -- the remainder is always 0, and we can just ignore the left operand
6763 -- completely in this case.
6768 -- The operand type may be private (e.g. in the expansion of an
6769 -- intrinsic operation) so we must use the underlying type to get the
6770 -- bounds, and convert the literals explicitly.
6772 LLB :=
6773 Expr_Value
6776 -- Now perform the test, generating code only if needed
6779 and then
6781 then
6787 Right_Opnd =>
6801 -----------------------------
6802 -- Expand_N_Op_Rotate_Left --
6803 -----------------------------
6806 begin
6810 ------------------------------
6811 -- Expand_N_Op_Rotate_Right --
6812 ------------------------------
6815 begin
6819 ----------------------------
6820 -- Expand_N_Op_Shift_Left --
6821 ----------------------------
6824 begin
6828 -----------------------------
6829 -- Expand_N_Op_Shift_Right --
6830 -----------------------------
6833 begin
6837 ----------------------------------------
6838 -- Expand_N_Op_Shift_Right_Arithmetic --
6839 ----------------------------------------
6842 begin
6846 --------------------------
6847 -- Expand_N_Op_Subtract --
6848 --------------------------
6853 begin
6856 -- N - 0 = N for integer types
6861 then
6866 -- Arithmetic overflow checks for signed integer/fixed point types
6870 then
6873 -- Vax floating-point types case
6880 ---------------------
6881 -- Expand_N_Op_Xor --
6882 ---------------------
6887 begin
6901 ----------------------
6902 -- Expand_N_Or_Else --
6903 ----------------------
6905 -- Expand into conditional expression if Actions present, and also
6906 -- deal with optimizing case of arguments being True or False.
6915 begin
6916 -- Deal with non-standard booleans
6924 -- Check for cases where left argument is known to be True or False
6928 -- If left argument is False, change (False or else Right) to Right.
6929 -- Any actions associated with Right will be executed unconditionally
6930 -- and can thus be inserted into the tree unconditionally.
6939 -- If left argument is True, change (True and then Right) to True. In
6940 -- this case we can forget the actions associated with Right, since
6941 -- they will never be executed.
6953 -- If Actions are present, we expand
6955 -- left or else right
6957 -- into
6959 -- if left then True else right end
6961 -- with the actions becoming the Else_Actions of the conditional
6962 -- expression. This conditional expression is then further expanded
6963 -- (and will eventually disappear)
6970 Left,
6972 Right)));
6980 -- No actions present, check for cases of right argument True/False
6984 -- Change (Left or else False) to Left. Note that we know there are
6985 -- no actions associated with the True operand, since we just checked
6986 -- for this case above.
6991 -- Change (Left or else True) to True, making sure to preserve any
6992 -- side effects associated with the Left operand.
6996 Rewrite
7004 -----------------------------------
7005 -- Expand_N_Qualified_Expression --
7006 -----------------------------------
7012 begin
7013 -- Do validity check if validity checking operands
7015 if Validity_Checks_On
7016 and then Validity_Check_Operands
7017 then
7021 -- Apply possible constraint check
7026 ---------------------------------
7027 -- Expand_N_Selected_Component --
7028 ---------------------------------
7030 -- If the selector is a discriminant of a concurrent object, rewrite the
7031 -- prefix to denote the corresponding record type.
7043 -- Gigi needs a temporary for prefixes that depend on a discriminant,
7044 -- unless the context of an assignment can provide size information.
7045 -- Don't we have a general routine that does this???
7047 -----------------------
7048 -- In_Left_Hand_Side --
7049 -----------------------
7052 begin
7060 -- Start of processing for Expand_N_Selected_Component
7062 begin
7063 -- Insert explicit dereference if required
7071 then
7078 -- Deal with discriminant check required
7082 -- Present the discriminant checking function to the backend, so that
7083 -- it can inline the call to the function.
7085 Add_Inlined_Body
7086 (Discriminant_Checking_Func
7089 -- Now reset the flag and generate the call
7095 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7096 -- function, then additional actuals must be passed.
7100 then
7104 -- Gigi cannot handle unchecked conversions that are the prefix of a
7105 -- selected component with discriminants. This must be checked during
7106 -- expansion, because during analysis the type of the selector is not
7107 -- known at the point the prefix is analyzed. If the conversion is the
7108 -- target of an assignment, then we cannot force the evaluation.
7113 then
7117 -- Remaining processing applies only if selector is a discriminant
7121 -- If the selector is a discriminant of a constrained record type,
7122 -- we may be able to rewrite the expression with the actual value
7123 -- of the discriminant, a useful optimization in some cases.
7128 then
7129 -- Do this optimization for discrete types only, and not for
7130 -- access types (access discriminants get us into trouble!)
7135 -- Don't do this on the left hand of an assignment statement.
7136 -- Normally one would think that references like this would
7137 -- not occur, but they do in generated code, and mean that
7138 -- we really do want to assign the discriminant!
7142 then
7145 -- Don't do this optimization for the prefix of an attribute or
7146 -- the operand of an object renaming declaration since these are
7147 -- contexts where we do not want the value anyway.
7152 then
7155 -- Don't do this optimization if we are within the code for a
7156 -- discriminant check, since the whole point of such a check may
7157 -- be to verify the condition on which the code below depends!
7162 -- Green light to see if we can do the optimization. There is
7163 -- still one condition that inhibits the optimization below but
7164 -- now is the time to check the particular discriminant.
7166 else
7167 -- Loop through discriminants to find the matching discriminant
7168 -- constraint to see if we can copy it.
7174 -- Check if this is the matching discriminant
7178 -- Here we have the matching discriminant. Check for
7179 -- the case of a discriminant of a component that is
7180 -- constrained by an outer discriminant, which cannot
7181 -- be optimized away.
7183 if
7184 Denotes_Discriminant
7186 then
7189 -- In the context of a case statement, the expression may
7190 -- have the base type of the discriminant, and we need to
7191 -- preserve the constraint to avoid spurious errors on
7192 -- missing cases.
7196 then
7199 Subtype_Mark =>
7201 Expression =>
7205 -- In case that comes out as a static expression,
7206 -- reset it (a selected component is never static).
7211 -- Otherwise we can just copy the constraint, but the
7212 -- result is certainly not static! In some cases the
7213 -- discriminant constraint has been analyzed in the
7214 -- context of the original subtype indication, but for
7215 -- itypes the constraint might not have been analyzed
7216 -- yet, and this must be done now.
7218 else
7230 -- Note: the above loop should always find a matching
7231 -- discriminant, but if it does not, we just missed an
7232 -- optimization due to some glitch (perhaps a previous error),
7233 -- so ignore.
7238 -- The only remaining processing is in the case of a discriminant of
7239 -- a concurrent object, where we rewrite the prefix to denote the
7240 -- corresponding record type. If the type is derived and has renamed
7241 -- discriminants, use corresponding discriminant, which is the one
7242 -- that appears in the corresponding record.
7252 then
7256 New_N :=
7258 Prefix =>
7268 --------------------
7269 -- Expand_N_Slice --
7270 --------------------
7279 -- Check whether the argument is an actual for a procedure call, in
7280 -- which case the expansion of a bit-packed slice is deferred until the
7281 -- call itself is expanded. The reason this is required is that we might
7282 -- have an IN OUT or OUT parameter, and the copy out is essential, and
7283 -- that copy out would be missed if we created a temporary here in
7284 -- Expand_N_Slice. Note that we don't bother to test specifically for an
7285 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
7286 -- is harmless to defer expansion in the IN case, since the call
7287 -- processing will still generate the appropriate copy in operation,
7288 -- which will take care of the slice.
7291 -- Create a named variable for the value of the slice, in cases where
7292 -- the back-end cannot handle it properly, e.g. when packed types or
7293 -- unaligned slices are involved.
7295 -------------------------
7296 -- Is_Procedure_Actual --
7297 -------------------------
7302 begin
7303 loop
7304 -- If our parent is a procedure call we can return
7309 -- If our parent is a type conversion, keep climbing the tree,
7310 -- since a type conversion can be a procedure actual. Also keep
7311 -- climbing if parameter association or a qualified expression,
7312 -- since these are additional cases that do can appear on
7313 -- procedure actuals.
7316 N_Parameter_Association,
7317 N_Qualified_Expression)
7318 then
7321 -- Any other case is not what we are looking for
7323 else
7329 --------------------
7330 -- Make_Temporary --
7331 --------------------
7337 begin
7338 Decl :=
7346 Decl,
7355 -- Start of processing for Expand_N_Slice
7357 begin
7358 -- Special handling for access types
7371 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7372 -- function, then additional actuals must be passed.
7376 then
7380 -- Range checks are potentially also needed for cases involving a slice
7381 -- indexed by a subtype indication, but Do_Range_Check can currently
7382 -- only be set for expressions ???
7389 -- Do not enable range check to nodes associated with the frontend
7390 -- expansion of the dispatch table. We first check if Ada.Tags is
7391 -- already loaded to avoid the addition of an undesired dependence
7392 -- on such run-time unit.
7394 and then
7396 or else not
7402 then
7406 -- The remaining case to be handled is packed slices. We can leave
7407 -- packed slices as they are in the following situations:
7409 -- 1. Right or left side of an assignment (we can handle this
7410 -- situation correctly in the assignment statement expansion).
7412 -- 2. Prefix of indexed component (the slide is optimized away in this
7413 -- case, see the start of Expand_N_Slice.)
7415 -- 3. Object renaming declaration, since we want the name of the
7416 -- slice, not the value.
7418 -- 4. Argument to procedure call, since copy-in/copy-out handling may
7419 -- be required, and this is handled in the expansion of call
7420 -- itself.
7422 -- 5. Prefix of an address attribute (this is an error which is caught
7423 -- elsewhere, and the expansion would interfere with generating the
7424 -- error message).
7428 -- Apply transformation for actuals of a function call, where
7429 -- Expand_Actuals is not used.
7433 then
7434 Make_Temporary;
7440 then
7446 then
7451 then
7454 else
7455 Make_Temporary;
7459 ------------------------------
7460 -- Expand_N_Type_Conversion --
7461 ------------------------------
7470 -- This is called in the case of record and array type conversions to
7471 -- see if there is a change of representation to be handled. Change of
7472 -- representation is actually handled at the assignment statement level,
7473 -- and what this procedure does is rewrite node N conversion as an
7474 -- assignment to temporary. If there is no change of representation,
7475 -- then the conversion node is unchanged.
7478 -- Handles generation of range check for real target value
7480 -----------------------------------
7481 -- Handle_Changed_Representation --
7482 -----------------------------------
7492 begin
7493 -- Nothing else to do if no change of representation
7498 -- The real change of representation work is done by the assignment
7499 -- statement processing. So if this type conversion is appearing as
7500 -- the expression of an assignment statement, nothing needs to be
7501 -- done to the conversion.
7506 -- Otherwise we need to generate a temporary variable, and do the
7507 -- change of representation assignment into that temporary variable.
7508 -- The conversion is then replaced by a reference to this variable.
7510 else
7513 -- If type is unconstrained we have to add a constraint, copied
7514 -- from the actual value of the left hand side.
7529 Selector_Name =>
7540 -- We convert the bounds explicitly. We use an unchecked
7541 -- conversion because bounds checks are done elsewhere.
7545 Low_Bound =>
7548 Prefix =>
7549 Duplicate_Subexpr_No_Checks
7555 High_Bound =>
7558 Prefix =>
7559 Duplicate_Subexpr_No_Checks
7573 Odef :=
7576 Constraint =>
7582 Decl :=
7589 -- Insert required actions. It is essential to suppress checks
7590 -- since we have suppressed default initialization, which means
7591 -- that the variable we create may have no discriminants.
7594 New_List (
7595 Decl,
7606 ----------------------
7607 -- Real_Range_Check --
7608 ----------------------
7610 -- Case of conversions to floating-point or fixed-point. If range checks
7611 -- are enabled and the target type has a range constraint, we convert:
7613 -- typ (x)
7615 -- to
7617 -- Tnn : typ'Base := typ'Base (x);
7618 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7619 -- Tnn
7621 -- This is necessary when there is a conversion of integer to float or
7622 -- to fixed-point to ensure that the correct checks are made. It is not
7623 -- necessary for float to float where it is enough to simply set the
7624 -- Do_Range_Check flag.
7634 begin
7635 -- Nothing to do if conversion was rewritten
7641 -- Nothing to do if range checks suppressed, or target has the same
7642 -- range as the base type (or is the base type).
7646 and then
7648 then
7652 -- Nothing to do if expression is an entity on which checks have been
7653 -- suppressed.
7657 then
7661 -- Nothing to do if bounds are all static and we can tell that the
7662 -- expression is within the bounds of the target. Note that if the
7663 -- operand is of an unconstrained floating-point type, then we do
7664 -- not trust it to be in range (might be infinite)
7666 declare
7670 begin
7677 then
7678 declare
7684 begin
7688 else
7696 then
7704 -- For float to float conversions, we are done
7707 and then
7709 then
7713 -- Otherwise rewrite the conversion as described above
7716 Rewrite
7720 -- Enable overflow except for case of integer to float conversions,
7721 -- where it is never required, since we can never have overflow in
7722 -- this case.
7728 Tnn :=
7739 Condition =>
7741 Left_Opnd =>
7744 Right_Opnd =>
7747 Prefix =>
7750 Right_Opnd =>
7753 Right_Opnd =>
7756 Prefix =>
7764 -- Start of processing for Expand_N_Type_Conversion
7766 begin
7767 -- Nothing at all to do if conversion is to the identical type so remove
7768 -- the conversion completely, it is useless.
7775 -- Nothing to do if this is the second argument of read. This is a
7776 -- "backwards" conversion that will be handled by the specialized code
7777 -- in attribute processing.
7782 then
7786 -- Here if we may need to expand conversion
7788 -- Do validity check if validity checking operands
7790 if Validity_Checks_On
7791 and then Validity_Check_Operands
7792 then
7796 -- Special case of converting from non-standard boolean type
7800 then
7806 -- Case of converting to an access type
7810 -- Apply an accessibility check when the conversion operand is an
7811 -- access parameter (or a renaming thereof), unless conversion was
7812 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
7813 -- Note that other checks may still need to be applied below (such
7814 -- as tagged type checks).
7817 and then
7819 or else
7822 and then Is_Formal
7827 then
7828 Apply_Accessibility_Check
7831 -- If the level of the operand type is statically deeper than the
7832 -- level of the target type, then force Program_Error. Note that this
7833 -- can only occur for cases where the attribute is within the body of
7834 -- an instantiation (otherwise the conversion will already have been
7835 -- rejected as illegal). Note: warnings are issued by the analyzer
7836 -- for the instance cases.
7838 elsif In_Instance_Body
7841 then
7847 -- When the operand is a selected access discriminant the check needs
7848 -- to be made against the level of the object denoted by the prefix
7849 -- of the selected name. Force Program_Error for this case as well
7850 -- (this accessibility violation can only happen if within the body
7851 -- of an instantiation).
7853 elsif In_Instance_Body
7858 then
7866 -- Case of conversions of tagged types and access to tagged types
7868 -- When needed, that is to say when the expression is class-wide, Add
7869 -- runtime a tag check for (strict) downward conversion by using the
7870 -- membership test, generating:
7872 -- [constraint_error when Operand not in Target_Type'Class]
7874 -- or in the access type case
7876 -- [constraint_error
7877 -- when Operand /= null
7878 -- and then Operand.all not in
7879 -- Designated_Type (Target_Type)'Class]
7884 then
7885 -- Do not do any expansion in the access type case if the parent is a
7886 -- renaming, since this is an error situation which will be caught by
7887 -- Sem_Ch8, and the expansion can interfere with this error check.
7891 then
7895 -- Otherwise, proceed with processing tagged conversion
7897 declare
7904 -- Create a membership check to test whether Operand is a member
7905 -- of Targ_Typ. If the original Target_Type is an access, include
7906 -- a test for null value. The check is inserted at N.
7908 --------------------
7909 -- Make_Tag_Check --
7910 --------------------
7915 begin
7916 -- Generate:
7917 -- [Constraint_Error
7918 -- when Operand /= null
7919 -- and then Operand.all not in Targ_Typ]
7922 Cond :=
7924 Left_Opnd =>
7929 Right_Opnd =>
7931 Left_Opnd =>
7936 -- Generate:
7937 -- [Constraint_Error when Operand not in Targ_Typ]
7939 else
7940 Cond :=
7952 -- Start of processing
7954 begin
7959 else
7966 -- Ada 2005 (AI-251): Handle interface type conversion
7975 -- Create a runtime tag check for a downward class-wide type
7976 -- conversion.
7981 then
7986 -- AI05-0073: If the result subtype of the function is defined
7987 -- by an access_definition designating a specific tagged type
7988 -- T, a check is made that the result value is null or the tag
7989 -- of the object designated by the result value identifies T.
7990 -- Constraint_Error is raised if this check fails.
7993 declare
7997 begin
7998 -- Climb scope stack looking for the enclosing function
8003 loop
8007 -- The function's return subtype must be defined using
8008 -- an access definition.
8011 N_Access_Definition
8012 then
8015 -- The return subtype denotes a specific tagged type,
8016 -- in other words, a non class-wide type.
8020 then
8028 -- We have generated a tag check for either a class-wide type
8029 -- conversion or for AI05-0073.
8032 declare
8034 begin
8035 Conv :=
8046 -- Case of other access type conversions
8051 -- Case of conversions from a fixed-point type
8053 -- These conversions require special expansion and processing, found in
8054 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
8055 -- since from a semantic point of view, these are simple integer
8056 -- conversions, which do not need further processing.
8060 then
8061 -- We should never see universal fixed at this case, since the
8062 -- expansion of the constituent divide or multiply should have
8063 -- eliminated the explicit mention of universal fixed.
8067 -- Check for special case of the conversion to universal real that
8068 -- occurs as a result of the use of a round attribute. In this case,
8069 -- the real type for the conversion is taken from the target type of
8070 -- the Round attribute and the result must be marked as rounded.
8075 then
8080 -- Otherwise do correct fixed-conversion, but skip these if the
8081 -- Conversion_OK flag is set, because from a semantic point of
8082 -- view these are simple integer conversions needing no further
8083 -- processing (the backend will simply treat them as integers)
8088 Real_Range_Check;
8093 else
8096 Real_Range_Check;
8100 -- Case of conversions to a fixed-point type
8102 -- These conversions require special expansion and processing, found in
8103 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
8104 -- since from a semantic point of view, these are simple integer
8105 -- conversions, which do not need further processing.
8109 then
8112 Real_Range_Check;
8113 else
8116 Real_Range_Check;
8119 -- Case of float-to-integer conversions
8121 -- We also handle float-to-fixed conversions with Conversion_OK set
8122 -- since semantically the fixed-point target is treated as though it
8123 -- were an integer in such cases.
8126 and then
8128 or else
8130 then
8131 -- One more check here, gcc is still not able to do conversions of
8132 -- this type with proper overflow checking, and so gigi is doing an
8133 -- approximation of what is required by doing floating-point compares
8134 -- with the end-point. But that can lose precision in some cases, and
8135 -- give a wrong result. Converting the operand to Universal_Real is
8136 -- helpful, but still does not catch all cases with 64-bit integers
8137 -- on targets with only 64-bit floats
8139 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
8140 -- Can this code be removed ???
8145 Subtype_Mark =>
8147 Expression =>
8155 -- Case of array conversions
8157 -- Expansion of array conversions, add required length/range checks but
8158 -- only do this if there is no change of representation. For handling of
8159 -- this case, see Handle_Changed_Representation.
8165 else
8169 Handle_Changed_Representation;
8171 -- Case of conversions of discriminated types
8173 -- Add required discriminant checks if target is constrained. Again this
8174 -- change is skipped if we have a change of representation.
8178 then
8180 Handle_Changed_Representation;
8182 -- Case of all other record conversions. The only processing required
8183 -- is to check for a change of representation requiring the special
8184 -- assignment processing.
8188 -- Ada 2005 (AI-216): Program_Error is raised when converting from
8189 -- a derived Unchecked_Union type to an unconstrained type that is
8190 -- not Unchecked_Union if the operand lacks inferable discriminants.
8197 then
8198 -- To prevent Gigi from generating illegal code, we generate a
8199 -- Program_Error node, but we give it the target type of the
8200 -- conversion.
8202 declare
8206 begin
8211 else
8212 Handle_Changed_Representation;
8215 -- Case of conversions of enumeration types
8219 -- Special processing is required if there is a change of
8220 -- representation (from enumeration representation clauses)
8224 -- Convert: x(y) to x'val (ytyp'val (y))
8239 -- Case of conversions to floating-point
8242 Real_Range_Check;
8245 -- At this stage, either the conversion node has been transformed into
8246 -- some other equivalent expression, or left as a conversion that can
8247 -- be handled by Gigi. The conversions that Gigi can handle are the
8248 -- following:
8250 -- Conversions with no change of representation or type
8252 -- Numeric conversions involving integer, floating- and fixed-point
8253 -- values. Fixed-point values are allowed only if Conversion_OK is
8254 -- set, i.e. if the fixed-point values are to be treated as integers.
8256 -- No other conversions should be passed to Gigi
8258 -- Check: are these rules stated in sinfo??? if so, why restate here???
8260 -- The only remaining step is to generate a range check if we still have
8261 -- a type conversion at this stage and Do_Range_Check is set. For now we
8262 -- do this only for conversions of discrete types.
8266 then
8267 declare
8272 begin
8275 then
8278 -- Before we do a range check, we have to deal with treating a
8279 -- fixed-point operand as an integer. The way we do this is
8280 -- simply to do an unchecked conversion to an appropriate
8281 -- integer type large enough to hold the result.
8283 -- This code is not active yet, because we are only dealing
8284 -- with discrete types so far ???
8288 then
8293 else
8300 -- Reset overflow flag, since the range check will include
8301 -- dealing with possible overflow, and generate the check If
8302 -- Address is either a source type or target type, suppress
8303 -- range check to avoid typing anomalies when it is a visible
8304 -- integer type.
8309 then
8310 Generate_Range_Check
8317 -- Final step, if the result is a type conversion involving Vax_Float
8318 -- types, then it is subject for further special processing.
8322 then
8328 -----------------------------------
8329 -- Expand_N_Unchecked_Expression --
8330 -----------------------------------
8332 -- Remove the unchecked expression node from the tree. It's job was simply
8333 -- to make sure that its constituent expression was handled with checks
8334 -- off, and now that that is done, we can remove it from the tree, and
8335 -- indeed must, since gigi does not expect to see these nodes.
8340 begin
8345 ----------------------------------------
8346 -- Expand_N_Unchecked_Type_Conversion --
8347 ----------------------------------------
8349 -- If this cannot be handled by Gigi and we haven't already made a
8350 -- temporary for it, do it now.
8357 begin
8358 -- If we have a conversion of a compile time known value to a target
8359 -- type and the value is in range of the target type, then we can simply
8360 -- replace the construct by an integer literal of the correct type. We
8361 -- only apply this to integer types being converted. Possibly it may
8362 -- apply in other cases, but it is too much trouble to worry about.
8364 -- Note that we do not do this transformation if the Kill_Range_Check
8365 -- flag is set, since then the value may be outside the expected range.
8366 -- This happens in the Normalize_Scalars case.
8368 -- We also skip this if either the target or operand type is biased
8369 -- because in this case, the unchecked conversion is supposed to
8370 -- preserve the bit pattern, not the integer value.
8378 then
8379 declare
8382 begin
8384 and then
8386 and then
8388 and then
8390 then
8393 -- If Address is the target type, just set the type to avoid a
8394 -- spurious type error on the literal when Address is a visible
8395 -- integer type.
8399 else
8408 -- Nothing to do if conversion is safe
8414 -- Otherwise force evaluation unless Assignment_OK flag is set (this
8415 -- flag indicates ??? -- more comments needed here)
8419 else
8424 ----------------------------
8425 -- Expand_Record_Equality --
8426 ----------------------------
8428 -- For non-variant records, Equality is expanded when needed into:
8430 -- and then Lhs.Discr1 = Rhs.Discr1
8431 -- and then ...
8432 -- and then Lhs.Discrn = Rhs.Discrn
8433 -- and then Lhs.Cmp1 = Rhs.Cmp1
8434 -- and then ...
8435 -- and then Lhs.Cmpn = Rhs.Cmpn
8437 -- The expression is folded by the back-end for adjacent fields. This
8438 -- function is called for tagged record in only one occasion: for imple-
8439 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
8440 -- otherwise the primitive "=" is used directly.
8442 function Expand_Record_Equality
8448 is
8457 -- Return the first field to compare beginning with C, skipping the
8458 -- inherited components.
8460 ----------------------
8461 -- Suitable_Element --
8462 ----------------------
8465 begin
8471 then
8476 then
8481 then
8487 else
8492 -- Start of processing for Expand_Record_Equality
8494 begin
8495 -- Generates the following code: (assuming that Typ has one Discr and
8496 -- component C2 is also a record)
8498 -- True
8499 -- and then Lhs.Discr1 = Rhs.Discr1
8500 -- and then Lhs.C1 = Rhs.C1
8501 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8502 -- and then ...
8503 -- and then Lhs.Cmpn = Rhs.Cmpn
8509 declare
8514 begin
8519 else
8524 Check :=
8526 Lhs =>
8530 Rhs =>
8536 -- If some (sub)component is an unchecked_union, the whole
8537 -- operation will raise program error.
8543 else
8544 Result :=
8557 -------------------------------------
8558 -- Fixup_Universal_Fixed_Operation --
8559 -------------------------------------
8564 begin
8565 -- We must have a type conversion immediately above us
8569 -- Normally the type conversion gives our target type. The exception
8570 -- occurs in the case of the Round attribute, where the conversion
8571 -- will be to universal real, and our real type comes from the Round
8572 -- attribute (as well as an indication that we must round the result)
8576 then
8580 -- Normal case where type comes from conversion above us
8582 else
8587 ------------------------------
8588 -- Get_Allocator_Final_List --
8589 ------------------------------
8591 function Get_Allocator_Final_List
8595 is
8599 -- The entity whose finalization list must be used to attach the
8600 -- allocated object.
8602 begin
8605 -- If the context is an access parameter, we need to create a
8606 -- non-anonymous access type in order to have a usable final list,
8607 -- because there is otherwise no pool to which the allocated object
8608 -- can belong. We create both the type and the finalization chain
8609 -- here, because freezing an internal type does not create such a
8610 -- chain. The Final_Chain that is thus created is shared by the
8611 -- access parameter. The access type is tested against the result
8612 -- type of the function to exclude allocators whose type is an
8613 -- anonymous access result type. We freeze the type at once to
8614 -- ensure that it is properly decorated for the back-end, even
8615 -- if the context and current scope is a loop.
8618 in N_Subprogram_Specification
8619 and then
8620 PtrT /=
8622 then
8627 Type_Definition =>
8629 Subtype_Indication =>
8636 -- Ada 2005 (AI-318-02): If the context is a return object
8637 -- declaration, then the anonymous return subtype is defined to have
8638 -- the same accessibility level as that of the function's result
8639 -- subtype, which means that we want the scope where the function is
8640 -- declared.
8644 then
8647 -- Case of an access discriminant, or (Ada 2005), of an anonymous
8648 -- access component or anonymous access function result: find the
8649 -- final list associated with the scope of the type. (In the
8650 -- anonymous access component kind, a list controller will have
8651 -- been allocated when freezing the record type, and PtrT has an
8652 -- Associated_Final_Chain attribute designating it.)
8662 ---------------------------------
8663 -- Has_Inferable_Discriminants --
8664 ---------------------------------
8669 -- Determines whether the left-most prefix of a selected component is a
8670 -- formal parameter in a subprogram. Assumes N is a selected component.
8672 --------------------------------
8673 -- Prefix_Is_Formal_Parameter --
8674 --------------------------------
8679 begin
8680 -- Move to the left-most prefix by climbing up the tree
8684 loop
8691 -- Start of processing for Has_Inferable_Discriminants
8693 begin
8694 -- For identifiers and indexed components, it is sufficient to have a
8695 -- constrained Unchecked_Union nominal subtype.
8699 and then
8702 -- For selected components, the subtype of the selector must be a
8703 -- constrained Unchecked_Union. If the component is subject to a
8704 -- per-object constraint, then the enclosing object must have inferable
8705 -- discriminants.
8710 -- A small hack. If we have a per-object constrained selected
8711 -- component of a formal parameter, return True since we do not
8712 -- know the actual parameter association yet.
8718 -- Otherwise, check the enclosing object and the selector
8721 and then
8725 -- The call to Has_Inferable_Discriminants will determine whether
8726 -- the selector has a constrained Unchecked_Union nominal type.
8730 -- A qualified expression has inferable discriminants if its subtype
8731 -- mark is a constrained Unchecked_Union subtype.
8735 and then
8743 -------------------------------
8744 -- Insert_Dereference_Action --
8745 -------------------------------
8754 -- Return true if type of P is derived from Checked_Pool;
8756 -----------------------------
8757 -- Is_Checked_Storage_Pool --
8758 -----------------------------
8763 begin
8772 else
8780 -- Start of processing for Insert_Dereference_Action
8782 begin
8787 then
8798 -- Pool
8802 -- Storage_Address. We use the attribute Pool_Address, which uses
8803 -- the pointer itself to find the address of the object, and which
8804 -- handles unconstrained arrays properly by computing the address
8805 -- of the template. i.e. the correct address of the corresponding
8806 -- allocation.
8812 -- Size_In_Storage_Elements
8815 Left_Opnd =>
8817 Prefix =>
8821 Right_Opnd =>
8824 -- Alignment
8827 Prefix =>
8832 exception
8837 ------------------------------
8838 -- Make_Array_Comparison_Op --
8839 ------------------------------
8841 -- This is a hand-coded expansion of the following generic function:
8843 -- generic
8844 -- type elem is (<>);
8845 -- type index is (<>);
8846 -- type a is array (index range <>) of elem;
8848 -- function Gnnn (X : a; Y: a) return boolean is
8849 -- J : index := Y'first;
8851 -- begin
8852 -- if X'length = 0 then
8853 -- return false;
8855 -- elsif Y'length = 0 then
8856 -- return true;
8858 -- else
8859 -- for I in X'range loop
8860 -- if X (I) = Y (J) then
8861 -- if J = Y'last then
8862 -- exit;
8863 -- else
8864 -- J := index'succ (J);
8865 -- end if;
8867 -- else
8868 -- return X (I) > Y (J);
8869 -- end if;
8870 -- end loop;
8872 -- return X'length > Y'length;
8873 -- end if;
8874 -- end Gnnn;
8876 -- Note that since we are essentially doing this expansion by hand, we
8877 -- do not need to generate an actual or formal generic part, just the
8878 -- instantiated function itself.
8880 function Make_Array_Comparison_Op
8883 is
8904 begin
8905 -- if J = Y'last then
8906 -- exit;
8907 -- else
8908 -- J := index'succ (J);
8909 -- end if;
8911 Inner_If :=
8913 Condition =>
8916 Right_Opnd =>
8924 Else_Statements =>
8925 New_List (
8928 Expression =>
8934 -- if X (I) = Y (J) then
8935 -- if ... end if;
8936 -- else
8937 -- return X (I) > Y (J);
8938 -- end if;
8940 Loop_Body :=
8942 Condition =>
8944 Left_Opnd =>
8949 Right_Opnd =>
8958 Expression =>
8960 Left_Opnd =>
8965 Right_Opnd =>
8971 -- for I in X'range loop
8972 -- if ... end if;
8973 -- end loop;
8975 Loop_Statement :=
8979 Iteration_Scheme =>
8981 Loop_Parameter_Specification =>
8984 Discrete_Subtype_Definition =>
8991 -- if X'length = 0 then
8992 -- return false;
8993 -- elsif Y'length = 0 then
8994 -- return true;
8995 -- else
8996 -- for ... loop ... end loop;
8997 -- return X'length > Y'length;
8998 -- end if;
9000 Length1 :=
9005 Length2 :=
9010 Final_Expr :=
9015 If_Stat :=
9017 Condition =>
9019 Left_Opnd =>
9023 Right_Opnd =>
9026 Then_Statements =>
9027 New_List (
9033 Condition =>
9035 Left_Opnd =>
9039 Right_Opnd =>
9042 Then_Statements =>
9043 New_List (
9048 Loop_Statement,
9052 -- (X : a; Y: a)
9063 -- function Gnnn (...) return boolean is
9064 -- J : index := Y'first;
9065 -- begin
9066 -- if ... end if;
9067 -- end Gnnn;
9071 Func_Body :=
9073 Specification =>
9083 Expression =>
9088 Handled_Statement_Sequence =>
9095 ---------------------------
9096 -- Make_Boolean_Array_Op --
9097 ---------------------------
9099 -- For logical operations on boolean arrays, expand in line the following,
9100 -- replacing 'and' with 'or' or 'xor' where needed:
9102 -- function Annn (A : typ; B: typ) return typ is
9103 -- C : typ;
9104 -- begin
9105 -- for J in A'range loop
9106 -- C (J) := A (J) op B (J);
9107 -- end loop;
9108 -- return C;
9109 -- end Annn;
9111 -- Here typ is the boolean array type
9113 function Make_Boolean_Array_Op
9116 is
9134 begin
9135 A_J :=
9140 B_J :=
9145 C_J :=
9151 Op :=
9157 Op :=
9162 else
9163 Op :=
9169 Loop_Statement :=
9173 Iteration_Scheme =>
9175 Loop_Parameter_Specification =>
9178 Discrete_Subtype_Definition =>
9197 Func_Name :=
9201 Func_Body :=
9203 Specification =>
9214 Handled_Statement_Sequence =>
9217 Loop_Statement,
9224 ------------------------
9225 -- Rewrite_Comparison --
9226 ------------------------
9230 -- Set to True if first pass with Assume_Valid generates a warning in
9231 -- which case we skip the second pass to avoid warning overloaded.
9234 -- Set to Standard_True or Standard_False
9236 begin
9245 -- Now start looking at the comparison in detail. We potentially go
9246 -- through this loop twice. The first time, Assume_Valid is set False
9247 -- in the call to Compile_Time_Compare. If this call results in a
9248 -- clear result of always True or Always False, that's decisive and
9249 -- we are done. Otherwise we repeat the processing with Assume_Valid
9250 -- set to True to generate additional warnings. We can stil that step
9251 -- if Constant_Condition_Warnings is False.
9254 declare
9261 -- Res indicates if compare outcome can be compile time determined
9266 begin
9277 and then Constant_Condition_Warnings
9280 and then not In_Instance
9283 then
9284 Error_Msg_N
9302 and then Constant_Condition_Warnings
9305 and then not In_Instance
9308 then
9309 Error_Msg_N
9319 -- If this is the first iteration, then we actually convert the
9320 -- comparison into True or False, if the result is certain.
9326 else
9338 -- If this is the second iteration (AV = True), and the original
9339 -- node comes from source and we are not in an instance, then
9340 -- give a warning if we know result would be True or False. Note
9341 -- we know Constant_Condition_Warnings is set if we get here.
9344 and then not In_Instance
9345 then
9347 Error_Msg_N
9349 N);
9351 Error_Msg_N
9353 N);
9358 -- Skip second iteration if not warning on constant conditions or
9359 -- if the first iteration already generated a warning of some kind
9360 -- or if we are in any case assuming all values are valid (so that
9361 -- the first iteration took care of the valid case).
9369 ----------------------------
9370 -- Safe_In_Place_Array_Op --
9371 ----------------------------
9373 function Safe_In_Place_Array_Op
9377 is
9381 -- Operand is safe if it cannot overlap part of the target of the
9382 -- operation. If the operand and the target are identical, the operand
9383 -- is safe. The operand can be empty in the case of negation.
9386 -- Check that N is a stand-alone entity
9388 ------------------
9389 -- Is_Unaliased --
9390 ------------------
9393 begin
9394 return
9400 ---------------------
9401 -- Is_Safe_Operand --
9402 ---------------------
9405 begin
9416 return
9423 else
9428 -- Start of processing for Is_Safe_In_Place_Array_Op
9430 begin
9431 -- Skip this processing if the component size is different from system
9432 -- storage unit (since at least for NOT this would cause problems).
9437 -- Cannot do in place stuff on VM_Target since cannot pass addresses
9442 -- Cannot do in place stuff if non-standard Boolean representation
9449 else
9452 return
9458 -----------------------
9459 -- Tagged_Membership --
9460 -----------------------
9462 -- There are two different cases to consider depending on whether the right
9463 -- operand is a class-wide type or not. If not we just compare the actual
9464 -- tag of the left expr to the target type tag:
9465 --
9466 -- Left_Expr.Tag = Right_Type'Tag;
9467 --
9468 -- If it is a class-wide type we use the RT function CW_Membership which is
9469 -- usually implemented by looking in the ancestor tables contained in the
9470 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
9472 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
9473 -- function IW_Membership which is usually implemented by looking in the
9474 -- table of abstract interface types plus the ancestor table contained in
9475 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9486 begin
9494 Obj_Tag :=
9497 Selector_Name =>
9502 -- No need to issue a run-time check if we statically know that the
9503 -- result of this membership test is always true. For example,
9504 -- considering the following declarations:
9506 -- type Iface is interface;
9507 -- type T is tagged null record;
9508 -- type DT is new T and Iface with null record;
9510 -- Obj1 : T;
9511 -- Obj2 : DT;
9513 -- These membership tests are always true:
9515 -- Obj1 in T'Class
9516 -- Obj2 in T'Class;
9517 -- Obj2 in Iface'Class;
9519 -- We do not need to handle cases where the membership is illegal.
9520 -- For example:
9522 -- Obj1 in DT'Class; -- Compile time error
9523 -- Obj1 in Iface'Class; -- Compile time error
9528 and then Interface_Present_In_Ancestor
9531 then
9535 -- Ada 2005 (AI-251): Class-wide applied to interfaces
9539 -- Support to: "Iface_CW_Typ in Typ'Class"
9542 then
9543 -- Issue error if IW_Membership operation not available in a
9544 -- configurable run time setting.
9547 Error_Msg_CRT
9552 return
9559 New_Reference_To (
9560 Node (First_Elmt
9562 Loc)));
9564 -- Ada 95: Normal case
9566 else
9567 return
9570 Typ_Tag_Node =>
9571 New_Reference_To (
9572 Node (First_Elmt
9574 Loc));
9577 -- Right_Type is not a class-wide type
9579 else
9580 -- No need to check the tag of the object if Right_Typ is abstract
9585 else
9586 return
9589 Right_Opnd =>
9590 New_Reference_To
9596 ------------------------------
9597 -- Unary_Op_Validity_Checks --
9598 ------------------------------
9601 begin