| blob | 4f0ef91a4194d42e4c4a19e72379bc22816c2c13 |
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 ------------------------------------------------------------------------------
77 -----------------------
78 -- Local Subprograms --
79 -----------------------
83 -- Performs validity checks for a binary operator
85 procedure Build_Boolean_Array_Proc_Call
89 -- If a boolean array assignment can be done in place, build call to
90 -- corresponding library procedure.
93 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
94 -- Expand_Allocator_Expression. Allocating class-wide interface objects
95 -- this routine displaces the pointer to the allocated object to reference
96 -- the component referencing the corresponding secondary dispatch table.
99 -- Subsidiary to Expand_N_Allocator, for the case when the expression
100 -- is a qualified expression or an aggregate.
103 -- This routine handles expansion of the comparison operators (N_Op_Lt,
104 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
105 -- code for these operators is similar, differing only in the details of
106 -- the actual comparison call that is made. Special processing (call a
107 -- run-time routine)
109 function Expand_Array_Equality
115 -- Expand an array equality into a call to a function implementing this
116 -- equality, and a call to it. Loc is the location for the generated nodes.
117 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
118 -- on which to attach bodies of local functions that are created in the
119 -- process. It is the responsibility of the caller to insert those bodies
120 -- at the right place. Nod provides the Sloc value for the generated code.
121 -- Normally the types used for the generated equality routine are taken
122 -- from Lhs and Rhs. However, in some situations of generated code, the
123 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
124 -- the type to be used for the formal parameters.
127 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
128 -- case of array type arguments.
130 function Expand_Composite_Equality
136 -- Local recursive function used to expand equality for nested composite
137 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
138 -- to attach bodies of local functions that are created in the process.
139 -- This is the responsibility of the caller to insert those bodies at the
140 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
141 -- are the left and right sides for the comparison, and Typ is the type of
142 -- the arrays to compare.
145 -- Routine to expand concatenation of a sequence of two or more operands
146 -- (in the list Operands) and replace node Cnode with the result of the
147 -- concatenation. The operands can be of any appropriate type, and can
148 -- include both arrays and singleton elements.
151 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
152 -- fixed. We do not have such a type at runtime, so the purpose of this
153 -- routine is to find the real type by looking up the tree. We also
154 -- determine if the operation must be rounded.
156 function Get_Allocator_Final_List
160 -- If the designated type is controlled, build final_list expression for
161 -- created object. If context is an access parameter, create a local access
162 -- type to have a usable finalization list.
165 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
166 -- discriminants if it has a constrained nominal type, unless the object
167 -- is a component of an enclosing Unchecked_Union object that is subject
168 -- to a per-object constraint and the enclosing object lacks inferable
169 -- discriminants.
170 --
171 -- An expression of an Unchecked_Union type has inferable discriminants
172 -- if it is either a name of an object with inferable discriminants or a
173 -- qualified expression whose subtype mark denotes a constrained subtype.
176 -- N is an expression whose type is an access. When the type of the
177 -- associated storage pool is derived from Checked_Pool, generate a
178 -- call to the 'Dereference' primitive operation.
180 function Make_Array_Comparison_Op
183 -- Comparisons between arrays are expanded in line. This function produces
184 -- the body of the implementation of (a > b), where a and b are one-
185 -- dimensional arrays of some discrete type. The original node is then
186 -- expanded into the appropriate call to this function. Nod provides the
187 -- Sloc value for the generated code.
189 function Make_Boolean_Array_Op
192 -- Boolean operations on boolean arrays are expanded in line. This function
193 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
194 -- b). It is used only the normal case and not the packed case. The type
195 -- involved, Typ, is the Boolean array type, and the logical operations in
196 -- the body are simple boolean operations. Note that Typ is always a
197 -- constrained type (the caller has ensured this by using
198 -- Convert_To_Actual_Subtype if necessary).
201 -- If N is the node for a comparison whose outcome can be determined at
202 -- compile time, then the node N can be rewritten with True or False. If
203 -- the outcome cannot be determined at compile time, the call has no
204 -- effect. If N is a type conversion, then this processing is applied to
205 -- its expression. If N is neither comparison nor a type conversion, the
206 -- call has no effect.
208 procedure Tagged_Membership
212 -- Construct the expression corresponding to the tagged membership test.
213 -- Deals with a second operand being (or not) a class-wide type.
215 function Safe_In_Place_Array_Op
219 -- In the context of an assignment, where the right-hand side is a boolean
220 -- operation on arrays, check whether operation can be performed in place.
224 -- Performs validity checks for a unary operator
226 -------------------------------
227 -- Binary_Op_Validity_Checks --
228 -------------------------------
231 begin
238 ------------------------------------
239 -- Build_Boolean_Array_Proc_Call --
240 ------------------------------------
242 procedure Build_Boolean_Array_Proc_Call
246 is
259 begin
263 -- Use negated version of the binary operators
275 Call_Node :=
280 Target,
293 else
296 Call_Node :=
300 Target,
311 else
312 -- We use the following equivalences:
314 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
315 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
316 -- (not X) xor (not Y) = X xor Y
317 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
326 else
330 else
341 else
346 Call_Node :=
350 Target,
365 exception
370 --------------------------------
371 -- Displace_Allocator_Pointer --
372 --------------------------------
381 begin
382 -- Do nothing in case of VM targets: the virtual machine will handle
383 -- interfaces directly.
398 then
399 -- If the type of the allocator expression is not an interface type
400 -- we can generate code to reference the record component containing
401 -- the pointer to the secondary dispatch table.
404 declare
407 begin
408 -- 1) Get access to the allocated object
416 -- 2) Add the conversion to displace the pointer to reference
417 -- the secondary dispatch table.
422 -- 3) The 'access to the secondary dispatch table will be used
423 -- as the value returned by the allocator.
433 -- If the type of the allocator expression is an interface type we
434 -- generate a run-time call to displace "this" to reference the
435 -- component containing the pointer to the secondary dispatch table
436 -- or else raise Constraint_Error if the actual object does not
437 -- implement the target interface. This case corresponds with the
438 -- following example:
440 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
441 -- begin
442 -- return new Iface_2'Class'(Obj);
443 -- end Op;
445 else
454 New_Occurrence_Of
456 (First_Elmt
458 Loc)))));
464 ---------------------------------
465 -- Expand_Allocator_Expression --
466 ---------------------------------
474 procedure Apply_Accessibility_Check
477 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
478 -- type, generate an accessibility check to verify that the level of the
479 -- type of the created object is not deeper than the level of the access
480 -- type. If the type of the qualified expression is class- wide, then
481 -- always generate the check (except in the case where it is known to be
482 -- unnecessary, see comment below). Otherwise, only generate the check
483 -- if the level of the qualified expression type is statically deeper
484 -- than the access type.
485 --
486 -- Although the static accessibility will generally have been performed
487 -- as a legality check, it won't have been done in cases where the
488 -- allocator appears in generic body, so a run-time check is needed in
489 -- general. One special case is when the access type is declared in the
490 -- same scope as the class-wide allocator, in which case the check can
491 -- never fail, so it need not be generated.
492 --
493 -- As an open issue, there seem to be cases where the static level
494 -- associated with the class-wide object's underlying type is not
495 -- sufficient to perform the proper accessibility check, such as for
496 -- allocators in nested subprograms or accept statements initialized by
497 -- class-wide formals when the actual originates outside at a deeper
498 -- static level. The nested subprogram case might require passing
499 -- accessibility levels along with class-wide parameters, and the task
500 -- case seems to be an actual gap in the language rules that needs to
501 -- be fixed by the ARG. ???
503 -------------------------------
504 -- Apply_Accessibility_Check --
505 -------------------------------
507 procedure Apply_Accessibility_Check
510 is
513 begin
514 -- Note: we skip the accessibility check for the VM case, since
515 -- there does not seem to be any practical way of implementing it.
518 and then Tagged_Type_Expansion
521 and then
523 or else
526 then
527 -- If the allocator was built in place Ref is already a reference
528 -- to the access object initialized to the result of the allocator
529 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise
530 -- it is the entity associated with the object containing the
531 -- address of the allocated object.
535 else
541 Condition =>
543 Left_Opnd =>
548 Right_Opnd =>
555 -- Local variables
564 -- Type used as source for tag assignment
567 -- Target reference for tag assignment
574 -- Start of processing for Expand_Allocator_Expression
576 begin
581 -- Generate:
582 -- Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn
584 -- Allocate the object with no expression
589 -- Avoid its expansion to avoid generating a call to the default
590 -- C++ constructor
605 -- Locate the enclosing list and insert the C++ constructor call
607 declare
610 begin
618 Id_Ref =>
630 -- Ada 2005 (AI-318-02): If the initialization expression is a call
631 -- to a build-in-place function, then access to the allocated object
632 -- must be passed to the function. Currently we limit such functions
633 -- to those with constrained limited result subtypes, but eventually
634 -- we plan to expand the allowed forms of functions that are treated
635 -- as build-in-place.
639 then
645 -- Actions inserted before:
646 -- Temp : constant ptr_T := new T'(Expression);
647 -- <no CW> Temp._tag := T'tag;
648 -- <CTRL> Adjust (Finalizable (Temp.all));
649 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
651 -- We analyze by hand the new internal allocator to avoid
652 -- any recursion and inappropriate call to Initialize
654 -- We don't want to remove side effects when the expression must be
655 -- built in place. In the case of a build-in-place function call,
656 -- that could lead to a duplication of the call, which was already
657 -- substituted for the allocator.
663 Temp :=
666 -- For a class wide allocation generate the following code:
668 -- type Equiv_Record is record ... end record;
669 -- implicit subtype CW is <Class_Wide_Subytpe>;
670 -- temp : PtrT := new CW'(CW!(expr));
675 -- Ada 2005 (AI-251): If the expression is a class-wide interface
676 -- object we generate code to move up "this" to reference the
677 -- base of the object before allocating the new object.
679 -- Note that Exp'Address is recursively expanded into a call
680 -- to Base_Address (Exp.Tag)
684 and then Tagged_Type_Expansion
685 then
686 Set_Expression
695 else
696 Set_Expression
704 -- Keep separate the management of allocators returning interfaces
708 Tmp_Node :=
712 Expression =>
716 -- Copy the Comes_From_Source flag for the allocator we just
717 -- built, since logically this allocator is a replacement of
718 -- the original allocator node. This is for proper handling of
719 -- restriction No_Implicit_Heap_Allocations.
721 Set_Comes_From_Source
729 then
730 -- Create local finalization list for access parameter
737 else
748 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
749 -- interface type. In this case we use the type of the qualified
750 -- expression to allocate the object.
752 else
753 declare
759 begin
760 New_Decl :=
763 Type_Definition =>
768 Subtype_Indication =>
773 -- Inherit the final chain to ensure that the expansion of the
774 -- aggregate is correct in case of controlled types
781 -- Declare the object using the previous type declaration
784 Tmp_Node :=
788 Expression =>
792 -- Copy the Comes_From_Source flag for the allocator we just
793 -- built, since logically this allocator is a replacement of
794 -- the original allocator node. This is for proper handling
795 -- of restriction No_Implicit_Heap_Allocations.
797 Set_Comes_From_Source
805 then
806 -- Create local finalization list for access parameter
808 Flist :=
813 else
824 -- Generate an additional object containing the address of the
825 -- returned object. The type of this second object declaration
826 -- is the correct type required for the common processing that
827 -- is still performed by this subprogram. The displacement of
828 -- this pointer to reference the component associated with the
829 -- interface type will be done at the end of common processing.
831 New_Decl :=
848 -- Generate the tag assignment
850 -- Suppress the tag assignment when VM_Target because VM tags are
851 -- represented implicitly in objects.
856 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
857 -- interface objects because in this case the tag does not change.
870 then
872 TagR :=
879 Tag_Assign :=
881 Name =>
884 Selector_Name =>
887 Expression =>
889 New_Reference_To
891 Loc)));
893 -- The previous assignment has to be done in any case
901 then
902 declare
907 begin
908 -- If it is an allocation on the secondary stack (i.e. a value
909 -- returned from a function), the object is attached on the
910 -- caller side as soon as the call is completed (see
911 -- Expand_Ctrl_Function_Call)
914 declare
918 begin
929 -- Normal case, not a secondary stack allocation
931 else
934 then
935 -- Create local finalization list for access parameter
937 Flist :=
939 else
946 -- Generate an Adjust call if the object will be moved. In Ada
947 -- 2005, the object may be inherently limited, in which case
948 -- there is no Adjust procedure, and the object is built in
949 -- place. In Ada 95, the object can be limited but not
950 -- inherently limited if this allocator came from a return
951 -- statement (we're allocating the result on the secondary
952 -- stack). In that case, the object will be moved, so we _do_
953 -- want to Adjust.
955 if not Aggr_In_Place
957 then
959 Make_Adjust_Call (
960 Ref =>
962 -- An unchecked conversion is needed in the classwide
963 -- case because the designated type can be an ancestor of
964 -- the subtype mark of the allocator.
981 -- Ada 2005 (AI-251): Displace the pointer to reference the record
982 -- component containing the secondary dispatch table of the interface
983 -- type.
990 Temp :=
992 Tmp_Node :=
999 -- Copy the Comes_From_Source flag for the allocator we just built,
1000 -- since logically this allocator is a replacement of the original
1001 -- allocator node. This is for proper handling of restriction
1002 -- No_Implicit_Heap_Allocations.
1004 Set_Comes_From_Source
1015 then
1021 then
1022 -- Apply constraint to designated subtype indication
1030 -- Propagate constraint_error to enclosing allocator
1034 else
1035 -- If we have:
1036 -- type A is access T1;
1037 -- X : A := new T2'(...);
1038 -- T1 and T2 can be different subtypes, and we might need to check
1039 -- both constraints. First check against the type of the qualified
1040 -- expression.
1049 -- A check is also needed in cases where the designated subtype is
1050 -- constrained and differs from the subtype given in the qualified
1051 -- expression. Note that the check on the qualified expression does
1052 -- not allow sliding, but this check does (a relaxation from Ada 83).
1056 then
1057 Apply_Constraint_Check
1066 -- For an access to unconstrained packed array, GIGI needs to see an
1067 -- expression with a constrained subtype in order to compute the
1068 -- proper size for the allocator.
1073 then
1074 declare
1079 begin
1083 Subtype_Indication =>
1090 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1091 -- to a build-in-place function, then access to the allocated object
1092 -- must be passed to the function. Currently we limit such functions
1093 -- to those with constrained limited result subtypes, but eventually
1094 -- we plan to expand the allowed forms of functions that are treated
1095 -- as build-in-place.
1099 then
1104 exception
1109 -----------------------------
1110 -- Expand_Array_Comparison --
1111 -----------------------------
1113 -- Expansion is only required in the case of array types. For the unpacked
1114 -- case, an appropriate runtime routine is called. For packed cases, and
1115 -- also in some other cases where a runtime routine cannot be called, the
1116 -- form of the expansion is:
1118 -- [body for greater_nn; boolean_expression]
1120 -- The body is built by Make_Array_Comparison_Op, and the form of the
1121 -- Boolean expression depends on the operator involved.
1137 -- True for byte addressable target
1140 -- Returns True if the length of the given operand is known to be less
1141 -- than 4. Returns False if this length is known to be four or greater
1142 -- or is not known at compile time.
1144 ------------------------
1145 -- Length_Less_Than_4 --
1146 ------------------------
1151 begin
1155 else
1156 declare
1163 begin
1166 else
1172 else
1181 -- Start of processing for Expand_Array_Comparison
1183 begin
1184 -- Deal first with unpacked case, where we can call a runtime routine
1185 -- except that we avoid this for targets for which are not addressable
1186 -- by bytes, and for the JVM/CIL, since they do not support direct
1187 -- addressing of array components.
1190 and then Byte_Addressable
1192 then
1193 -- The call we generate is:
1195 -- Compare_Array_xn[_Unaligned]
1196 -- (left'address, right'address, left'length, right'length) <op> 0
1198 -- x = U for unsigned, S for signed
1199 -- n = 8,16,32,64 for component size
1200 -- Add _Unaligned if length < 4 and component size is 8.
1201 -- <op> is the standard comparison operator
1205 or else
1207 then
1210 else
1214 else
1217 else
1225 else
1232 else
1239 else
1277 -- Cases where we cannot make runtime call
1279 -- For (a <= b) we convert to not (a > b)
1284 Right_Opnd =>
1291 -- For < the Boolean expression is
1292 -- greater__nn (op2, op1)
1297 -- Switch operands
1302 -- For (a >= b) we convert to not (a < b)
1307 Right_Opnd =>
1314 -- For > the Boolean expression is
1315 -- greater__nn (op1, op2)
1317 else
1323 Expr :=
1332 exception
1337 ---------------------------
1338 -- Expand_Array_Equality --
1339 ---------------------------
1341 -- Expand an equality function for multi-dimensional arrays. Here is an
1342 -- example of such a function for Nb_Dimension = 2
1344 -- function Enn (A : atyp; B : btyp) return boolean is
1345 -- begin
1346 -- if (A'length (1) = 0 or else A'length (2) = 0)
1347 -- and then
1348 -- (B'length (1) = 0 or else B'length (2) = 0)
1349 -- then
1350 -- return True; -- RM 4.5.2(22)
1351 -- end if;
1353 -- if A'length (1) /= B'length (1)
1354 -- or else
1355 -- A'length (2) /= B'length (2)
1356 -- then
1357 -- return False; -- RM 4.5.2(23)
1358 -- end if;
1360 -- declare
1361 -- A1 : Index_T1 := A'first (1);
1362 -- B1 : Index_T1 := B'first (1);
1363 -- begin
1364 -- loop
1365 -- declare
1366 -- A2 : Index_T2 := A'first (2);
1367 -- B2 : Index_T2 := B'first (2);
1368 -- begin
1369 -- loop
1370 -- if A (A1, A2) /= B (B1, B2) then
1371 -- return False;
1372 -- end if;
1374 -- exit when A2 = A'last (2);
1375 -- A2 := Index_T2'succ (A2);
1376 -- B2 := Index_T2'succ (B2);
1377 -- end loop;
1378 -- end;
1380 -- exit when A1 = A'last (1);
1381 -- A1 := Index_T1'succ (A1);
1382 -- B1 := Index_T1'succ (B1);
1383 -- end loop;
1384 -- end;
1386 -- return true;
1387 -- end Enn;
1389 -- Note on the formal types used (atyp and btyp). If either of the arrays
1390 -- is of a private type, we use the underlying type, and do an unchecked
1391 -- conversion of the actual. If either of the arrays has a bound depending
1392 -- on a discriminant, then we use the base type since otherwise we have an
1393 -- escaped discriminant in the function.
1395 -- If both arrays are constrained and have the same bounds, we can generate
1396 -- a loop with an explicit iteration scheme using a 'Range attribute over
1397 -- the first array.
1399 function Expand_Array_Equality
1405 is
1421 -- The parameter types to be used for the formals
1423 function Arr_Attr
1427 -- This builds the attribute reference Arr'Nam (Expr)
1430 -- Create one statement to compare corresponding components, designated
1431 -- by a full set of indices.
1434 -- Given one of the arguments, computes the appropriate type to be used
1435 -- for that argument in the corresponding function formal
1437 function Handle_One_Dimension
1440 -- This procedure returns the following code
1441 --
1442 -- declare
1443 -- Bn : Index_T := B'First (N);
1444 -- begin
1445 -- loop
1446 -- xxx
1447 -- exit when An = A'Last (N);
1448 -- An := Index_T'Succ (An)
1449 -- Bn := Index_T'Succ (Bn)
1450 -- end loop;
1451 -- end;
1452 --
1453 -- If both indices are constrained and identical, the procedure
1454 -- returns a simpler loop:
1455 --
1456 -- for An in A'Range (N) loop
1457 -- xxx
1458 -- end loop
1459 --
1460 -- N is the dimension for which we are generating a loop. Index is the
1461 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1462 -- xxx statement is either the loop or declare for the next dimension
1463 -- or if this is the last dimension the comparison of corresponding
1464 -- components of the arrays.
1465 --
1466 -- The actual way the code works is to return the comparison of
1467 -- corresponding components for the N+1 call. That's neater!
1470 -- This function constructs the test for both arrays being empty
1471 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1472 -- and then
1473 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1476 -- This function constructs the test for arrays having different lengths
1477 -- in at least one index position, in which case the resulting code is:
1479 -- A'length (1) /= B'length (1)
1480 -- or else
1481 -- A'length (2) /= B'length (2)
1482 -- or else
1483 -- ...
1485 --------------
1486 -- Arr_Attr --
1487 --------------
1489 function Arr_Attr
1493 is
1494 begin
1495 return
1502 ------------------------
1503 -- Component_Equality --
1504 ------------------------
1510 begin
1511 -- if a(i1...) /= b(j1...) then return false; end if;
1513 L :=
1518 R :=
1523 Test := Expand_Composite_Equality
1526 -- If some (sub)component is an unchecked_union, the whole operation
1527 -- will raise program error.
1531 -- This node is going to be inserted at a location where a
1532 -- statement is expected: clear its Etype so analysis will set
1533 -- it to the expected Standard_Void_Type.
1538 else
1539 return
1548 ------------------
1549 -- Get_Arg_Type --
1550 ------------------
1556 begin
1562 else
1568 or else
1570 then
1582 --------------------------
1583 -- Handle_One_Dimension --
1584 ---------------------------
1586 function Handle_One_Dimension
1589 is
1591 Ltyp /= Rtyp
1593 -- If the index types are identical, and we are working with
1594 -- constrained types, then we can use the same index for both
1595 -- of the arrays.
1605 begin
1610 -- Case where we generate a loop
1615 Bn :=
1618 else
1630 -- Generate guard for loop, followed by increments of indices
1634 Condition =>
1642 Expression =>
1651 Expression =>
1658 -- If separate indexes, we need a declare block for An and Bn, and a
1659 -- loop without an iteration scheme.
1662 Loop_Stm :=
1665 return
1678 Handled_Statement_Sequence =>
1682 -- If no separate indexes, return loop statement with explicit
1683 -- iteration scheme on its own
1685 else
1686 Loop_Stm :=
1689 Iteration_Scheme =>
1691 Loop_Parameter_Specification =>
1694 Discrete_Subtype_Definition =>
1700 -----------------------
1701 -- Test_Empty_Arrays --
1702 -----------------------
1711 begin
1715 Atest :=
1720 Btest :=
1729 else
1730 Alist :=
1735 Blist :=
1742 return
1748 -----------------------------
1749 -- Test_Lengths_Correspond --
1750 -----------------------------
1756 begin
1759 Rtest :=
1766 else
1767 Result :=
1777 -- Start of processing for Expand_Array_Equality
1779 begin
1783 -- For now, if the argument types are not the same, go to the base type,
1784 -- since the code assumes that the formals have the same type. This is
1785 -- fixable in future ???
1793 -- Build list of formals for function
1806 -- Build statement sequence for function
1808 Func_Body :=
1810 Specification =>
1818 Handled_Statement_Sequence =>
1826 Expression =>
1833 Expression =>
1844 -- If the array type is distinct from the type of the arguments, it
1845 -- is the full view of a private type. Apply an unchecked conversion
1846 -- to insure that analysis of the call succeeds.
1848 declare
1851 begin
1857 then
1863 then
1872 return
1878 -----------------------------
1879 -- Expand_Boolean_Operator --
1880 -----------------------------
1882 -- Note that we first get the actual subtypes of the operands, since we
1883 -- always want to deal with types that have bounds.
1888 begin
1889 -- Special case of bit packed array where both operands are known to be
1890 -- properly aligned. In this case we use an efficient run time routine
1891 -- to carry out the operation (see System.Bit_Ops).
1896 then
1901 -- For the normal non-packed case, the general expansion is to build
1902 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1903 -- and then inserting it into the tree. The original operator node is
1904 -- then rewritten as a call to this function. We also use this in the
1905 -- packed case if either operand is a possibly unaligned object.
1907 declare
1914 begin
1927 then
1932 and then
1934 then
1936 else
1942 -- Now rewrite the expression with a call
1947 Parameter_Associations =>
1948 New_List (
1949 L,
1950 Make_Type_Conversion
1958 -------------------------------
1959 -- Expand_Composite_Equality --
1960 -------------------------------
1962 -- This function is only called for comparing internal fields of composite
1963 -- types when these fields are themselves composites. This is a special
1964 -- case because it is not possible to respect normal Ada visibility rules.
1966 function Expand_Composite_Equality
1972 is
1978 begin
1981 else
1985 -- Defense against malformed private types with no completion the error
1986 -- will be diagnosed later by check_completion
1996 -- If the operand is an elementary type other than a floating-point
1997 -- type, then we can simply use the built-in block bitwise equality,
1998 -- since the predefined equality operators always apply and bitwise
1999 -- equality is fine for all these cases.
2003 then
2006 -- For composite component types, and floating-point types, use the
2007 -- expansion. This deals with tagged component types (where we use
2008 -- the applicable equality routine) and floating-point, (where we
2009 -- need to worry about negative zeroes), and also the case of any
2010 -- composite type recursively containing such fields.
2012 else
2018 -- Call the primitive operation "=" of this type
2024 -- If this is derived from an untagged private type completed with a
2025 -- tagged type, it does not have a full view, so we use the primitive
2026 -- operations of the private type. This check should no longer be
2027 -- necessary when these types receive their full views ???
2034 then
2036 else
2040 loop
2052 return
2055 Parameter_Associations =>
2056 New_List
2066 -- Inherited equality from parent type. Convert the actuals to
2067 -- match signature of operation.
2069 declare
2072 begin
2073 return
2076 Parameter_Associations =>
2081 else
2082 -- Comparison between Unchecked_Union components
2085 declare
2091 begin
2092 -- Lhs subtype
2098 -- Rhs subtype
2104 -- Lhs of the composite equality
2108 -- Since the enclosing record type can never be an
2109 -- Unchecked_Union (this code is executed for records
2110 -- that do not have variants), we may reference its
2111 -- discriminant(s).
2116 then
2117 Lhs_Discr_Val :=
2120 Selector_Name =>
2121 New_Copy (
2122 Get_Discriminant_Value (
2124 Lhs_Type,
2127 else
2129 Get_Discriminant_Value (
2131 Lhs_Type,
2135 else
2136 -- It is not possible to infer the discriminant since
2137 -- the subtype is not constrained.
2139 return
2144 -- Rhs of the composite equality
2150 then
2151 Rhs_Discr_Val :=
2154 Selector_Name =>
2155 New_Copy (
2156 Get_Discriminant_Value (
2158 Rhs_Type,
2161 else
2163 Get_Discriminant_Value (
2165 Rhs_Type,
2169 else
2170 return
2175 -- Call the TSS equality function with the inferred
2176 -- discriminant values.
2178 return
2182 Lhs,
2183 Rhs,
2184 Lhs_Discr_Val,
2185 Rhs_Discr_Val));
2189 -- Shouldn't this be an else, we can't fall through the above
2190 -- IF, right???
2192 return
2198 else
2202 else
2203 -- It can be a simple record or the full view of a scalar private
2209 ------------------------
2210 -- Expand_Concatenate --
2211 ------------------------
2217 -- Result type of concatenation
2220 -- Component type. Elements of this component type can appear as one
2221 -- of the operands of concatenation as well as arrays.
2224 -- Index subtype
2227 -- Index type. This is the base type of the index subtype, and is used
2228 -- for all computed bounds (which may be out of range of Istyp in the
2229 -- case of null ranges).
2232 -- This is the type we use to do arithmetic to compute the bounds and
2233 -- lengths of operands. The choice of this type is a little subtle and
2234 -- is discussed in a separate section at the start of the body code.
2237 -- Raised if concatenation is sure to raise a CE
2240 -- Reset to False if at least one operand is encountered which is known
2241 -- at compile time to be non-null. Used for handling the special case
2242 -- of setting the high bound to the last operand high bound for a null
2243 -- result, thus ensuring a proper high bound in the super-flat case.
2246 -- Number of concatenation operands including possibly null operands
2249 -- Number of operands excluding any known to be null, except that the
2250 -- last operand is always retained, in case it provides the bounds for
2251 -- a null result.
2254 -- Current operand being processed in the loop through operands. After
2255 -- this loop is complete, always contains the last operand (which is not
2256 -- the same as Operands (NN), since null operands are skipped).
2258 -- Arrays describing the operands, only the first NN entries of each
2259 -- array are set (NN < N when we exclude known null operands).
2262 -- True if length of corresponding operand known at compile time
2265 -- Set to the corresponding entry in the Opnds list (but note that null
2266 -- operands are excluded, so not all entries in the list are stored).
2269 -- Set to length of operand. Entries in this array are set only if the
2270 -- corresponding entry in Is_Fixed_Length is True.
2273 -- Set to lower bound of operand. Either an integer literal in the case
2274 -- where the bound is known at compile time, else actual lower bound.
2275 -- The operand low bound is of type Ityp.
2278 -- Set to an entity of type Natural that contains the length of an
2279 -- operand whose length is not known at compile time. Entries in this
2280 -- array are set only if the corresponding entry in Is_Fixed_Length
2281 -- is False. The entity is of type Artyp.
2284 -- The J'th entry in an expression node that represents the total length
2285 -- of operands 1 through J. It is either an integer literal node, or a
2286 -- reference to a constant entity with the right value, so it is fine
2287 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2288 -- entry always is set to zero. The length is of type Artyp.
2291 -- A tree node representing the low bound of the result (of type Ityp).
2292 -- This is either an integer literal node, or an identifier reference to
2293 -- a constant entity initialized to the appropriate value.
2296 -- A tree node representing the high bound of the last operand. This
2297 -- need only be set if the result could be null. It is used for the
2298 -- special case of setting the right high bound for a null result.
2299 -- This is of type Ityp.
2302 -- A tree node representing the high bound of the result (of type Ityp)
2305 -- Result of the concatenation (of type Ityp)
2308 -- Collect actions to be inserted if Save_Space is False
2312 -- Set to True if we are saving generated code space by calling routines
2313 -- in packages System.Concat_n.
2316 -- Set True during generation of the assignements of operands into
2317 -- result once an operand known to be non-null has been seen.
2320 -- This function makes an N_Integer_Literal node that is returned in
2321 -- analyzed form with the type set to Artyp. Importantly this literal
2322 -- is not flagged as static, so that if we do computations with it that
2323 -- result in statically detected out of range conditions, we will not
2324 -- generate error messages but instead warning messages.
2327 -- Given a node of type Ityp, returns the corresponding value of type
2328 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2329 -- For enum types, the Pos of the value is returned.
2332 -- The inverse function (uses Val in the case of enumeration types)
2334 ------------------------
2335 -- Make_Artyp_Literal --
2336 ------------------------
2340 begin
2347 --------------
2348 -- To_Artyp --
2349 --------------
2352 begin
2357 return
2363 else
2368 -------------
2369 -- To_Ityp --
2370 -------------
2373 begin
2375 return
2381 -- Case where we will do a type conversion
2383 else
2386 else
2392 -- Local Declarations
2401 begin
2402 -- Choose an appropriate computational type
2404 -- We will be doing calculations of lengths and bounds in this routine
2405 -- and computing one from the other in some cases, e.g. getting the high
2406 -- bound by adding the length-1 to the low bound.
2408 -- We can't just use the index type, or even its base type for this
2409 -- purpose for two reasons. First it might be an enumeration type which
2410 -- is not suitable fo computations of any kind, and second it may simply
2411 -- not have enough range. For example if the index type is -128..+127
2412 -- then lengths can be up to 256, which is out of range of the type.
2414 -- For enumeration types, we can simply use Standard_Integer, this is
2415 -- sufficient since the actual number of enumeration literals cannot
2416 -- possibly exceed the range of integer (remember we will be doing the
2417 -- arithmetic with POS values, not representation values).
2422 -- If index type is Positive, we use the standard unsigned type, to give
2423 -- more room on the top of the range, obviating the need for an overflow
2424 -- check when creating the upper bound. This is needed to avoid junk
2425 -- overflow checks in the common case of String types.
2427 -- ??? Disabled for now
2429 -- elsif Istyp = Standard_Positive then
2430 -- Artyp := Standard_Unsigned;
2432 -- For modular types, we use a 32-bit modular type for types whose size
2433 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2434 -- identity type, and for larger unsigned types we use 64-bits.
2441 else
2445 -- Similar treatment for signed types
2447 else
2452 else
2457 -- Supply dummy entry at start of length array
2461 -- Go through operands setting up the above arrays
2468 -- The parent got messed up when we put the operands in a list,
2469 -- so now put back the proper parent for the saved operand.
2473 -- Set will be True when we have setup one entry in the array
2477 -- Singleton element (or character literal) case
2486 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2487 -- since we know that the result cannot be null).
2496 -- String literal case (can only occur for strings of course)
2505 -- Capture last operand high bound if result could be null
2508 Last_Opnd_High_Bound :=
2510 Left_Opnd =>
2515 -- Skip null string literal
2525 -- Set length and bounds
2534 -- All other cases
2536 else
2537 -- Check constrained case with known bounds
2540 declare
2546 begin
2547 -- Fixed length constrained array type with known at compile
2548 -- time bounds is last case of fixed length operand.
2551 and then
2553 then
2554 declare
2560 begin
2565 -- Capture last operand bound if result could be null
2568 Last_Opnd_High_Bound :=
2574 -- Exclude null length case unless last operand
2595 -- All cases where the length is not known at compile time, or the
2596 -- special case of an operand which is known to be null but has a
2597 -- lower bound other than 1 or is other than a string type.
2602 -- Capture operand bounds
2606 Prefix =>
2611 Last_Opnd_High_Bound :=
2614 Prefix =>
2619 -- Capture length of operand in entity
2633 Object_Definition =>
2636 Expression =>
2638 Prefix =>
2644 -- Set next entry in aggregate length array
2646 -- For first entry, make either integer literal for fixed length
2647 -- or a reference to the saved length for variable length.
2654 else
2659 -- If entry is fixed length and only fixed lengths so far, make
2660 -- appropriate new integer literal adding new length.
2664 then
2669 -- All other cases, construct an addition node for the length and
2670 -- create an entity initialized to this length.
2672 else
2673 Ent :=
2679 else
2688 Object_Definition =>
2691 Expression =>
2703 -- If we have only skipped null operands, return the last operand
2710 -- If we have only one non-null operand, return it and we are done.
2711 -- There is one case in which this cannot be done, and that is when
2712 -- the sole operand is of the element type, in which case it must be
2713 -- converted to an array, and the easiest way of doing that is to go
2714 -- through the normal general circuit.
2718 then
2723 -- Cases where we have a real concatenation
2725 -- Next step is to find the low bound for the result array that we
2726 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
2728 -- If the ultimate ancestor of the index subtype is a constrained array
2729 -- definition, then the lower bound is that of the index subtype as
2730 -- specified by (RM 4.5.3(6)).
2732 -- The right test here is to go to the root type, and then the ultimate
2733 -- ancestor is the first subtype of this root type.
2736 Low_Bound :=
2738 Prefix =>
2742 -- If the first operand in the list has known length we know that
2743 -- the lower bound of the result is the lower bound of this operand.
2748 -- OK, we don't know the lower bound, we have to build a horrible
2749 -- expression actions node of the form
2751 -- if Cond1'Length /= 0 then
2752 -- Opnd1 low bound
2753 -- else
2754 -- if Opnd2'Length /= 0 then
2755 -- Opnd2 low bound
2756 -- else
2757 -- ...
2759 -- The nesting ends either when we hit an operand whose length is known
2760 -- at compile time, or on reaching the last operand, whose low bound we
2761 -- take unconditionally whether or not it is null. It's easiest to do
2762 -- this with a recursive procedure:
2764 else
2765 declare
2767 -- Returns the lower bound determined by operands J .. NN
2769 ---------------------
2770 -- Get_Known_Bound --
2771 ---------------------
2774 begin
2778 else
2779 return
2792 begin
2793 Ent :=
2807 -- Now we can safely compute the upper bound, normally
2808 -- Low_Bound + Length - 1.
2810 High_Bound :=
2811 To_Ityp (
2814 Right_Opnd =>
2819 -- Note that calculation of the high bound may cause overflow in some
2820 -- very weird cases, so in the general case we need an overflow check on
2821 -- the high bound. We can avoid this for the common case of string types
2822 -- and other types whose index is Positive, since we chose a wider range
2823 -- for the arithmetic type.
2829 -- Handle the exceptional case where the result is null, in which case
2830 -- case the bounds come from the last operand (so that we get the proper
2831 -- bounds if the last operand is super-flat).
2834 High_Bound :=
2840 Last_Opnd_High_Bound,
2841 High_Bound));
2844 -- Here is where we insert the saved up actions
2848 -- Now we construct an array object with appropriate bounds
2850 Ent :=
2854 -- If the bound is statically known to be out of range, we do not want
2855 -- to abort, we want a warning and a runtime constraint error. Note that
2856 -- we have arranged that the result will not be treated as a static
2857 -- constant, so we won't get an illegality during this insertion.
2862 Object_Definition =>
2865 Constraint =>
2873 -- If the result of the concatenation appears as the initializing
2874 -- expression of an object declaration, we can just rename the
2875 -- result, rather than copying it.
2879 -- Catch the static out of range case now
2885 -- Now we will generate the assignments to do the actual concatenation
2887 -- There is one case in which we will not do this, namely when all the
2888 -- following conditions are met:
2890 -- The result type is Standard.String
2892 -- There are nine or fewer retained (non-null) operands
2894 -- The optimization level is -O0
2896 -- The corresponding System.Concat_n.Str_Concat_n routine is
2897 -- available in the run time.
2899 -- The debug flag gnatd.c is not set
2901 -- If all these conditions are met then we generate a call to the
2902 -- relevant concatenation routine. The purpose of this is to avoid
2903 -- undesirable code bloat at -O0.
2908 and then not Debug_Flag_Dot_C
2909 then
2910 declare
2913 RE_Str_Concat_3,
2914 RE_Str_Concat_4,
2915 RE_Str_Concat_5,
2916 RE_Str_Concat_6,
2917 RE_Str_Concat_7,
2918 RE_Str_Concat_8,
2919 RE_Str_Concat_9);
2921 begin
2923 declare
2927 begin
2942 else
2959 -- Not special case so generate the assignments
2964 declare
2973 Right_Opnd =>
2978 begin
2979 -- Singleton case, simple assignment
2985 Name =>
2992 -- Array case, slice assignment, skipped when argument is fixed
2993 -- length and known to be null.
2996 declare
2999 Name =>
3001 Prefix =>
3003 Discrete_Range =>
3008 begin
3014 -- Here if operand length is not statically known and no
3015 -- operand known to be non-null has been processed yet.
3016 -- If operand length is 0, we do not need to perform the
3017 -- assignment, and we must avoid the evaluation of the
3018 -- high bound of the slice, since it may underflow if the
3019 -- low bound is Ityp'First.
3021 Assign :=
3023 Condition =>
3025 Left_Opnd =>
3028 Then_Statements =>
3038 -- Finally we build the result, which is a reference to the array object
3046 exception
3049 -- Kill warning generated for the declaration of the static out of
3050 -- range high bound, and instead generate a Constraint_Error with
3051 -- an appropriate specific message.
3054 Apply_Compile_Time_Constraint_Error
3058 -- Set_Etype (Cnode, Atyp);
3061 ------------------------
3062 -- Expand_N_Allocator --
3063 ------------------------
3075 -- Generate finalization calls for all nested coextensions of N. This
3076 -- routine may allocate list controllers if necessary.
3079 -- Static coextensions have the same lifetime as the entity they
3080 -- constrain. Such occurrences can be rewritten as aliased objects
3081 -- and their unrestricted access used instead of the coextension.
3084 -- Given a constrained array type E, returns a node representing the
3085 -- code to compute the size in storage elements for the given type.
3086 -- This is done without using the attribute (which malfunctions for
3087 -- large sizes ???)
3089 ---------------------------------------
3090 -- Complete_Coextension_Finalization --
3091 ---------------------------------------
3100 -- Determine whether node N is part of a return statement
3103 -- Determine whether node N is a subtype indicator allocator which
3104 -- acts a coextension. Such coextensions need initialization.
3106 -------------------------------
3107 -- Inside_A_Return_Statement --
3108 -------------------------------
3113 begin
3116 if Nkind_In
3118 then
3121 -- Stop the traversal when we reach a subprogram body
3133 -------------------------------
3134 -- Needs_Initialization_Call --
3135 -------------------------------
3140 begin
3144 N_Object_Declaration
3145 then
3148 return
3152 N_Qualified_Expression;
3158 -- Start of processing for Complete_Coextension_Finalization
3160 begin
3161 -- When a coextension root is inside a return statement, we need to
3162 -- use the finalization chain of the function's scope. This does not
3163 -- apply for controlled named access types because in those cases we
3164 -- can use the finalization chain of the type itself.
3167 and then
3169 or else
3172 then
3173 declare
3178 begin
3183 -- Retrieve the declaration of the body
3185 Decl :=
3186 Parent
3187 (Parent
3195 -- Push the scope of the function body since we are inserting
3196 -- the list before the body, but we are currently in the body
3197 -- itself. Override the finalization list of PtrT since the
3198 -- finalization context is now different.
3202 Pop_Scope;
3205 -- The root allocator may not be controlled, but it still needs a
3206 -- finalization list for all nested coextensions.
3212 Flist :=
3214 Prefix =>
3216 Selector_Name =>
3223 -- Generate:
3224 -- typ! (coext.all)
3227 Ref :=
3230 Expression =>
3233 else
3237 -- No initialization call if not allowed
3243 -- Generate:
3244 -- initialize (Ref)
3245 -- attach_to_final_list (Ref, Flist, 2)
3249 Make_Init_Call (
3255 -- Generate:
3256 -- attach_to_final_list (Ref, Flist, 2)
3258 else
3260 Make_Attach_Call (
3271 -------------------------
3272 -- Rewrite_Coextension --
3273 -------------------------
3280 -- Generate:
3281 -- Cnn : aliased Etyp;
3287 Object_Definition =>
3291 begin
3296 -- Find the proper insertion node for the declaration
3317 ------------------------------
3318 -- Size_In_Storage_Elements --
3319 ------------------------------
3322 begin
3323 -- Logically this just returns E'Max_Size_In_Storage_Elements.
3324 -- However, the reason for the existence of this function is
3325 -- to construct a test for sizes too large, which means near the
3326 -- 32-bit limit on a 32-bit machine, and precisely the trouble
3327 -- is that we get overflows when sizes are greater than 2**31.
3329 -- So what we end up doing for array types is to use the expression:
3331 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
3333 -- which avoids this problem. All this is a big bogus, but it does
3334 -- mean we catch common cases of trying to allocate arrays that
3335 -- are too large, and which in the absence of a check results in
3336 -- undetected chaos ???
3338 declare
3342 begin
3344 Len :=
3354 else
3355 Res :=
3362 return
3365 Right_Opnd =>
3372 -- Start of processing for Expand_N_Allocator
3374 begin
3375 -- RM E.2.3(22). We enforce that the expected type of an allocator
3376 -- shall not be a remote access-to-class-wide-limited-private type
3378 -- Why is this being done at expansion time, seems clearly wrong ???
3382 -- Set the Storage Pool
3395 else
3401 -- Under certain circumstances we can replace an allocator by an access
3402 -- to statically allocated storage. The conditions, as noted in AARM
3403 -- 3.10 (10c) are as follows:
3405 -- Size and initial value is known at compile time
3406 -- Access type is access-to-constant
3408 -- The allocator is not part of a constraint on a record component,
3409 -- because in that case the inserted actions are delayed until the
3410 -- record declaration is fully analyzed, which is too late for the
3411 -- analysis of the rewritten allocator.
3419 then
3420 -- Here we can do the optimization. For the allocator
3422 -- new x'(y)
3424 -- We insert an object declaration
3426 -- Tnn : aliased x := y;
3428 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
3429 -- marked as requiring static allocation.
3431 Temp :=
3436 -- If context is constrained, use constrained subtype directly,
3437 -- so that the constant is not labelled as having a nominally
3438 -- unconstrained subtype.
3459 -- We set the variable as statically allocated, since we don't want
3460 -- it going on the stack of the current procedure!
3466 -- Same if the allocator is an access discriminant for a local object:
3467 -- instead of an allocator we create a local value and constrain the
3468 -- the enclosing object with the corresponding access attribute.
3475 -- The current allocator creates an object which may contain nested
3476 -- coextensions. Use the current allocator's finalization list to
3477 -- generate finalization call for all nested coextensions.
3480 Complete_Coextension_Finalization;
3483 -- Check for size too large, we do this because the back end misses
3484 -- proper checks here and can generate rubbish allocation calls when
3485 -- we are near the limit. We only do this for the 32-bit address case
3486 -- since that is from a practical point of view where we see a problem.
3492 then
3493 -- The check we want to generate should look like
3495 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
3496 -- raise Storage_Error;
3497 -- end if;
3499 -- where 3.5 gigabytes is a constant large enough to accomodate any
3500 -- reasonable request for. But we can't do it this way because at
3501 -- least at the moment we don't compute this attribute right, and
3502 -- can silently give wrong results when the result gets large. Since
3503 -- this is all about large results, that's bad, so instead we only
3504 -- apply the check for constrained arrays, and manually compute the
3505 -- value of the attribute ???
3510 Condition =>
3513 Right_Opnd =>
3520 -- Handle case of qualified expression (other than optimization above)
3521 -- First apply constraint checks, because the bounds or discriminants
3522 -- in the aggregate might not match the subtype mark in the allocator.
3525 Apply_Constraint_Check
3532 -- If the allocator is for a type which requires initialization, and
3533 -- there is no initial value (i.e. operand is a subtype indication
3534 -- rather than a qualified expression), then we must generate a call to
3535 -- the initialization routine using an expressions action node:
3537 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3539 -- Here ptr_T is the pointer type for the allocator, and T is the
3540 -- subtype of the allocator. A special case arises if the designated
3541 -- type of the access type is a task or contains tasks. In this case
3542 -- the call to Init (Temp.all ...) is replaced by code that ensures
3543 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3544 -- for details). In addition, if the type T is a task T, then the
3545 -- first argument to Init must be converted to the task record type.
3547 declare
3560 begin
3564 -- Case of no initialization procedure present
3568 -- Case of simple initialization required
3582 -- No initialization required
3584 else
3588 -- Case of initialization procedure present, must be called
3590 else
3598 -- Construct argument list for the initialization routine call
3600 Arg1 :=
3606 -- The initialization procedure expects a specific type. if the
3607 -- context is access to class wide, indicate that the object
3608 -- being allocated has the right specific type.
3614 -- If designated type is a concurrent type or if it is private
3615 -- type whose definition is a concurrent type, the first
3616 -- argument in the Init routine has to be unchecked conversion
3617 -- to the corresponding record type. If the designated type is
3618 -- a derived type, we also convert the argument to its root
3619 -- type.
3622 Arg1 :=
3628 then
3629 Arg1 :=
3630 Unchecked_Convert_To
3634 declare
3636 begin
3644 -- For the task case, pass the Master_Id of the access type as
3645 -- the value of the _Master parameter, and _Chain as the value
3646 -- of the _Chain parameter (_Chain will be defined as part of
3647 -- the generated code for the allocator).
3649 -- In Ada 2005, the context may be a function that returns an
3650 -- anonymous access type. In that case the Master_Id has been
3651 -- created when expanding the function declaration.
3656 -- If we have a non-library level task with restriction
3657 -- No_Task_Hierarchy set, then no point in expanding.
3661 then
3665 -- The designated type was an incomplete type, and the
3666 -- access type did not get expanded. Salvage it now.
3669 Expand_N_Full_Type_Declaration
3673 -- If the context of the allocator is a declaration or an
3674 -- assignment, we can generate a meaningful image for it,
3675 -- even though subsequent assignments might remove the
3676 -- connection between task and entity. We build this image
3677 -- when the left-hand side is a simple variable, a simple
3678 -- indexed assignment or a simple selected component.
3681 declare
3684 begin
3686 Decls :=
3687 Build_Task_Image_Decls
3689 New_Occurrence_Of
3692 elsif Nkind_In
3695 then
3696 Decls :=
3697 Build_Task_Image_Decls
3699 else
3705 Decls :=
3706 Build_Task_Image_Decls
3709 else
3714 New_Reference_To
3722 -- Has_Task is false, Decls not used
3724 else
3728 -- Add discriminants if discriminated type
3730 declare
3734 begin
3742 then
3749 -- If the allocated object will be constrained by the
3750 -- default values for discriminants, then build a subtype
3751 -- with those defaults, and change the allocated subtype
3752 -- to that. Note that this happens in fewer cases in Ada
3753 -- 2005 (AI-363).
3759 or else
3761 then
3771 -- AI-416: when the discriminant constraint is an
3772 -- anonymous access type make sure an accessibility
3773 -- check is inserted if necessary (3.10.2(22.q/2))
3776 and then
3778 then
3779 Apply_Accessibility_Check
3788 -- We set the allocator as analyzed so that when we analyze the
3789 -- expression actions node, we do not get an unwanted recursive
3790 -- expansion of the allocator expression.
3795 -- Here is the transformation:
3796 -- input: new T
3797 -- output: Temp : constant ptr_T := new T;
3798 -- Init (Temp.all, ...);
3799 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
3800 -- <CTRL> Initialize (Finalizable (Temp.all));
3802 -- Here ptr_T is the pointer type for the allocator, and is the
3803 -- subtype of the allocator.
3805 Temp_Decl :=
3815 -- If the designated type is a task type or contains tasks,
3816 -- create block to activate created tasks, and insert
3817 -- declaration for Task_Image variable ahead of call.
3820 declare
3823 begin
3830 else
3839 -- Postpone the generation of a finalization call for the
3840 -- current allocator if it acts as a coextension.
3849 else
3850 Flist :=
3853 -- Anonymous access types created for access parameters
3854 -- are attached to an explicitly constructed controller,
3855 -- which ensures that they can be finalized properly,
3856 -- even if their deallocation might not happen. The list
3857 -- associated with the controller is doubly-linked. For
3858 -- other anonymous access types, the object may end up
3859 -- on the global final list which is singly-linked.
3860 -- Work needed for access discriminants in Ada 2005 ???
3864 else
3869 Make_Init_Call (
3884 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
3885 -- object that has been rewritten as a reference, we displace "this"
3886 -- to reference properly its secondary dispatch table.
3890 then
3894 exception
3899 -----------------------
3900 -- Expand_N_And_Then --
3901 -----------------------
3903 -- Expand into conditional expression if Actions present, and also deal
3904 -- with optimizing case of arguments being True or False.
3913 begin
3914 -- Deal with non-standard booleans
3922 -- Check for cases where left argument is known to be True or False
3926 -- If left argument is True, change (True and then Right) to Right.
3927 -- Any actions associated with Right will be executed unconditionally
3928 -- and can thus be inserted into the tree unconditionally.
3937 -- If left argument is False, change (False and then Right) to False.
3938 -- In this case we can forget the actions associated with Right,
3939 -- since they will never be executed.
3951 -- If Actions are present, we expand
3953 -- left and then right
3955 -- into
3957 -- if left then right else false end
3959 -- with the actions becoming the Then_Actions of the conditional
3960 -- expression. This conditional expression is then further expanded
3961 -- (and will eventually disappear)
3968 Left,
3969 Right,
3972 -- If the right part of the expression is a function call then it can
3973 -- be part of the expansion of the predefined equality operator of a
3974 -- tagged type and we may need to adjust its SCIL dispatching node.
3976 if Generate_SCIL
3978 then
3988 -- No actions present, check for cases of right argument True/False
3992 -- Change (Left and then True) to Left. Note that we know there are
3993 -- no actions associated with the True operand, since we just checked
3994 -- for this case above.
3999 -- Change (Left and then False) to False, making sure to preserve any
4000 -- side effects associated with the Left operand.
4011 -------------------------------------
4012 -- Expand_N_Conditional_Expression --
4013 -------------------------------------
4015 -- Expand into expression actions if then/else actions present
4030 begin
4031 -- If either then or else actions are present, then given:
4033 -- if cond then then-expr else else-expr end
4035 -- we insert the following sequence of actions (using Insert_Actions):
4037 -- Cnn : typ;
4038 -- if cond then
4039 -- <<then actions>>
4040 -- Cnn := then-expr;
4041 -- else
4042 -- <<else actions>>
4043 -- Cnn := else-expr
4044 -- end if;
4046 -- and replace the conditional expression by a reference to Cnn
4048 -- If the type is limited or unconstrained, the above expansion is
4049 -- not legal, because it involves either an uninitialized object
4050 -- or an illegal assignment. Instead, we generate:
4052 -- type Ptr is access all Typ;
4053 -- Cnn : Ptr;
4054 -- if cond then
4055 -- <<then actions>>
4056 -- Cnn := then-expr'Unrestricted_Access;
4057 -- else
4058 -- <<else actions>>
4059 -- Cnn := else-expr'Unrestricted_Access;
4060 -- end if;
4062 -- and replace the conditional expresion by a reference to Cnn.all.
4067 P_Decl :=
4069 Defining_Identifier =>
4071 Type_Definition =>
4074 Subtype_Indication =>
4079 Decl :=
4082 Object_Definition =>
4085 New_If :=
4092 Expression =>
4100 Expression =>
4105 New_N :=
4109 -- For other types, we only need to expand if there are other actions
4110 -- associated with either branch.
4115 Decl :=
4120 New_If :=
4139 else
4140 -- No expansion needed, gigi handles it like a C conditional
4141 -- expression.
4146 -- Move the SLOC of the parent If statement to the newly created one and
4147 -- change it to the SLOC of the expression which, after expansion, will
4148 -- correspond to what is being evaluated.
4152 then
4157 -- Make sure Then_Actions and Else_Actions are appropriately moved
4158 -- to the new if statement.
4161 Insert_List_Before
4166 Insert_List_Before
4176 -----------------------------------
4177 -- Expand_N_Explicit_Dereference --
4178 -----------------------------------
4181 begin
4182 -- Insert explicit dereference call for the checked storage pool case
4187 -----------------
4188 -- Expand_N_In --
4189 -----------------
4199 -- For each disjunct we create a simple equality or membership test.
4200 -- The whole membership is rewritten as a short-circuit disjunction.
4202 ---------------------------
4203 -- Expand_Set_Membership --
4204 ---------------------------
4211 -- If the alternative is a subtype mark, create a simple membership
4212 -- test. Otherwise create an equality test for it.
4214 ---------------
4215 -- Make_Cond --
4216 ---------------
4223 begin
4226 then
4227 Cond :=
4231 else
4240 -- Start of proessing for Expand_N_In
4242 begin
4248 Res :=
4260 -- Replaces node N by Lop'Valid. This is done when we have an explicit
4261 -- test for the left operand being in range of its subtype.
4263 ----------------------------
4264 -- Substitute_Valid_Check --
4265 ----------------------------
4268 begin
4281 -- Start of processing for Expand_N_In
4283 begin
4287 Expand_Set_Membership;
4291 -- Check case of explicit test for an expression in range of its
4292 -- subtype. This is suspicious usage and we replace it with a 'Valid
4293 -- test and give a warning.
4300 then
4301 Substitute_Valid_Check;
4305 -- Do validity check on operands
4312 -- Case of explicit range
4315 declare
4328 Constant_Condition_Warnings
4331 -- This must be true for any of the optimization warnings, we
4332 -- clearly want to give them only for source with the flag on.
4333 -- We also skip these warnings in an instance since it may be
4334 -- the case that different instantiations have different ranges.
4337 Warn1
4340 -- For the case where only one bound warning is elided, we also
4341 -- insist on an explicit range and an integer type. The reason is
4342 -- that the use of enumeration ranges including an end point is
4343 -- common, as is the use of a subtype name, one of whose bounds
4344 -- is the same as the type of the expression.
4346 begin
4347 -- If test is explicit x'first .. x'last, replace by valid check
4360 then
4361 Substitute_Valid_Check;
4365 -- If bounds of type are known at compile time, and the end points
4366 -- are known at compile time and identical, this is another case
4367 -- for substituting a valid test. We only do this for discrete
4368 -- types, since it won't arise in practice for float types.
4379 -- Kill warnings in instances, since they may be cases where we
4380 -- have a test in the generic that makes sense with some types
4381 -- and not with other types.
4383 and then not In_Instance
4384 then
4385 Substitute_Valid_Check;
4389 -- If we have an explicit range, do a bit of optimization based
4390 -- on range analysis (we may be able to kill one or both checks).
4395 -- If either check is known to fail, replace result by False since
4396 -- the other check does not matter. Preserve the static flag for
4397 -- legality checks, because we are constant-folding beyond RM 4.9.
4412 -- If both checks are known to succeed, replace result by True,
4413 -- since we know we are in range.
4428 -- If lower bound check succeeds and upper bound check is not
4429 -- known to succeed or fail, then replace the range check with
4430 -- a comparison against the upper bound.
4446 -- If upper bound check succeeds and lower bound check is not
4447 -- known to succeed or fail, then replace the range check with
4448 -- a comparison against the lower bound.
4465 -- We couldn't optimize away the range check, but there is one
4466 -- more issue. If we are checking constant conditionals, then we
4467 -- see if we can determine the outcome assuming everything is
4468 -- valid, and if so give an appropriate warning.
4474 -- Result is out of range for valid value
4477 Error_Msg_N
4480 -- Result is in range for valid value
4483 Error_Msg_N
4486 -- Lower bound check succeeds if value is valid
4489 Error_Msg_N
4492 -- Upper bound check succeeds if value is valid
4495 Error_Msg_N
4501 -- For all other cases of an explicit range, nothing to be done
4505 -- Here right operand is a subtype mark
4507 else
4508 declare
4516 begin
4519 -- For tagged type, do tagged membership operation
4523 -- No expansion will be performed when VM_Target, as the VM
4524 -- back-ends will handle the membership tests directly (tags
4525 -- are not explicitly represented in Java objects, so the
4526 -- normal tagged membership expansion is not what we want).
4533 -- Update decoration of relocated node referenced by the
4534 -- SCIL node.
4536 if Generate_SCIL
4538 then
4546 -- If type is scalar type, rewrite as x in t'first .. t'last.
4547 -- This reason we do this is that the bounds may have the wrong
4548 -- type if they come from the original type definition. Also this
4549 -- way we get all the processing above for an explicit range.
4554 Low_Bound =>
4559 High_Bound =>
4566 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4567 -- a membership test if the subtype mark denotes a constrained
4568 -- Unchecked_Union subtype and the expression lacks inferable
4569 -- discriminants.
4574 then
4579 -- Prevent Gigi from generating incorrect code by rewriting
4580 -- the test as a standard False.
4588 -- Here we have a non-scalar type
4599 -- For the constrained array case, we have to check the subscripts
4600 -- for an exact match if the lengths are non-zero (the lengths
4601 -- must match in any case).
4606 function Construct_Attribute_Reference
4610 -- Build attribute reference E'Nam(Dim)
4612 -----------------------------------
4613 -- Construct_Attribute_Reference --
4614 -----------------------------------
4616 function Construct_Attribute_Reference
4620 is
4621 begin
4622 return
4630 -- Start of processing for Check_Subscripts
4632 begin
4636 Left_Opnd =>
4637 Construct_Attribute_Reference
4640 Right_Opnd =>
4641 Construct_Attribute_Reference
4646 Left_Opnd =>
4647 Construct_Attribute_Reference
4650 Right_Opnd =>
4651 Construct_Attribute_Reference
4656 Cond :=
4658 Left_Opnd =>
4669 -- These are the cases where constraint checks may be required,
4670 -- e.g. records with possible discriminants
4672 else
4673 -- Expand the test into a series of discriminant comparisons.
4674 -- The expression that is built is the negation of the one that
4675 -- is used for checking discriminant constraints.
4685 Left_Opnd =>
4692 else
4703 --------------------------------
4704 -- Expand_N_Indexed_Component --
4705 --------------------------------
4713 begin
4714 -- A special optimization, if we have an indexed component that is
4715 -- selecting from a slice, then we can eliminate the slice, since, for
4716 -- example, x (i .. j)(k) is identical to x(k). The only difference is
4717 -- the range check required by the slice. The range check for the slice
4718 -- itself has already been generated. The range check for the
4719 -- subscripting operation is ensured by converting the subject to
4720 -- the subtype of the slice.
4722 -- This optimization not only generates better code, avoiding slice
4723 -- messing especially in the packed case, but more importantly bypasses
4724 -- some problems in handling this peculiar case, for example, the issue
4725 -- of dealing specially with object renamings.
4732 Convert_To
4739 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
4740 -- function, then additional actuals must be passed.
4744 then
4748 -- If the prefix is an access type, then we unconditionally rewrite if
4749 -- as an explicit dereference. This simplifies processing for several
4750 -- cases, including packed array cases and certain cases in which checks
4751 -- must be generated. We used to try to do this only when it was
4752 -- necessary, but it cleans up the code to do it all the time.
4759 -- Generate index and validity checks
4767 -- All done for the non-packed case
4773 -- For packed arrays that are not bit-packed (i.e. the case of an array
4774 -- with one or more index types with a non-contiguous enumeration type),
4775 -- we can always use the normal packed element get circuit.
4782 -- For a reference to a component of a bit packed array, we have to
4783 -- convert it to a reference to the corresponding Packed_Array_Type.
4784 -- We only want to do this for simple references, and not for:
4786 -- Left side of assignment, or prefix of left side of assignment, or
4787 -- prefix of the prefix, to handle packed arrays of packed arrays,
4788 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4790 -- Renaming objects in renaming associations
4791 -- This case is handled when a use of the renamed variable occurs
4793 -- Actual parameters for a procedure call
4794 -- This case is handled in Exp_Ch6.Expand_Actuals
4796 -- The second expression in a 'Read attribute reference
4798 -- The prefix of an address or size attribute reference
4800 -- The following circuit detects these exceptions
4802 declare
4806 begin
4807 loop
4812 N_Procedure_Call_Statement)
4814 and then
4816 then
4821 or else
4824 then
4829 then
4832 -- If the expression is an index of an indexed component, it must
4833 -- be expanded regardless of context.
4837 then
4843 then
4849 then
4854 then
4857 else
4862 -- Keep looking up tree for unchecked expression, or if we are the
4863 -- prefix of a possible assignment left side.
4871 ---------------------
4872 -- Expand_N_Not_In --
4873 ---------------------
4875 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
4876 -- can be done. This avoids needing to duplicate this expansion code.
4883 begin
4886 Right_Opnd =>
4891 -- If this is a set membership, preserve list of alternatives
4895 -- We want this to appear as coming from source if original does (see
4896 -- transformations in Expand_N_In).
4901 -- Now analyze transformed node
4906 -------------------
4907 -- Expand_N_Null --
4908 -------------------
4910 -- The only replacement required is for the case of a null of type that is
4911 -- an access to protected subprogram. We represent such access values as a
4912 -- record, and so we must replace the occurrence of null by the equivalent
4913 -- record (with a null address and a null pointer in it), so that the
4914 -- backend creates the proper value.
4921 begin
4923 Agg :=
4932 -- For subsequent semantic analysis, the node must retain its type.
4933 -- Gigi in any case replaces this type by the corresponding record
4934 -- type before processing the node.
4939 exception
4944 ---------------------
4945 -- Expand_N_Op_Abs --
4946 ---------------------
4952 begin
4955 -- Deal with software overflow checking
4957 if not Backend_Overflow_Checks_On_Target
4960 then
4961 -- The only case to worry about is when the argument is equal to the
4962 -- largest negative number, so what we do is to insert the check:
4964 -- [constraint_error when Expr = typ'Base'First]
4966 -- with the usual Duplicate_Subexpr use coding for expr
4970 Condition =>
4973 Right_Opnd =>
4975 Prefix =>
4981 -- Vax floating-point types case
4988 ---------------------
4989 -- Expand_N_Op_Add --
4990 ---------------------
4995 begin
4998 -- N + 0 = 0 + N = N for integer types
5003 then
5009 then
5015 -- Arithmetic overflow checks for signed integer/fixed point types
5019 then
5023 -- Vax floating-point types case
5030 ---------------------
5031 -- Expand_N_Op_And --
5032 ---------------------
5037 begin
5045 -- Replace AND by AND THEN if Short_Circuit_And_Or active and the
5046 -- type is standard Boolean (do not mess with AND that uses a non-
5047 -- standard Boolean type, because something strange is going on).
5056 -- Otherwise, adjust conditions
5058 else
5067 ------------------------
5068 -- Expand_N_Op_Concat --
5069 ------------------------
5073 -- List of operands to be concatenated
5076 -- Node which is to be replaced by the result of concatenating the nodes
5077 -- in the list Opnds.
5079 begin
5080 -- Ensure validity of both operands
5084 -- If we are the left operand of a concatenation higher up the tree,
5085 -- then do nothing for now, since we want to deal with a series of
5086 -- concatenations as a unit.
5090 then
5094 -- We get here with a concatenation whose left operand may be a
5095 -- concatenation itself with a consistent type. We need to process
5096 -- these concatenation operands from left to right, which means
5097 -- from the deepest node in the tree to the highest node.
5104 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
5105 -- nodes above, so now we process bottom up, doing the operations. We
5106 -- gather a string that is as long as possible up to five operands
5108 -- The outer loop runs more than once if more than one concatenation
5109 -- type is involved.
5115 -- The inner loop gathers concatenation operands
5120 loop
5132 ------------------------
5133 -- Expand_N_Op_Divide --
5134 ------------------------
5144 and then
5148 begin
5155 -- N / 1 = N for integer types
5162 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
5163 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5164 -- operand is an unsigned integer, as required for this to work.
5169 -- We cannot do this transformation in configurable run time mode if we
5170 -- have 64-bit -- integers and long shifts are not available.
5172 and then
5175 then
5179 Right_Opnd =>
5185 -- Do required fixup of universal fixed operation
5192 -- Divisions with fixed-point results
5196 -- No special processing if Treat_Fixed_As_Integer is set, since
5197 -- from a semantic point of view such operations are simply integer
5198 -- operations and will be treated that way.
5203 else
5208 -- Other cases of division of fixed-point operands. Again we exclude the
5209 -- case where Treat_Fixed_As_Integer is set.
5214 then
5217 else
5222 -- Mixed-mode operations can appear in a non-static universal context,
5223 -- in which case the integer argument must be converted explicitly.
5227 then
5235 then
5241 -- Non-fixed point cases, do integer zero divide and overflow checks
5246 -- Check for 64-bit division available, or long shifts if the divisor
5247 -- is a small power of 2 (since such divides will be converted into
5248 -- long shifts).
5251 and then not Support_64_Bit_Divides_On_Target
5252 and then
5254 or else not Support_Long_Shifts_On_Target
5261 then
5265 -- Deal with Vax_Float
5273 --------------------
5274 -- Expand_N_Op_Eq --
5275 --------------------
5290 -- If a constructed equality exists for the type or for its parent,
5291 -- build and analyze call, adding conversions if the operation is
5292 -- inherited.
5295 -- Determines whether a type has a subcomponent of an unconstrained
5296 -- Unchecked_Union subtype. Typ is a record type.
5298 -------------------------
5299 -- Build_Equality_Call --
5300 -------------------------
5307 begin
5310 then
5315 -- If we have an Unchecked_Union, we need to add the inferred
5316 -- discriminant values as actuals in the function call. At this
5317 -- point, the expansion has determined that both operands have
5318 -- inferable discriminants.
5321 declare
5327 begin
5328 -- Per-object constrained selected components require special
5329 -- attention. If the enclosing scope of the component is an
5330 -- Unchecked_Union, we cannot reference its discriminants
5331 -- directly. This is why we use the two extra parameters of
5332 -- the equality function of the enclosing Unchecked_Union.
5334 -- type UU_Type (Discr : Integer := 0) is
5335 -- . . .
5336 -- end record;
5337 -- pragma Unchecked_Union (UU_Type);
5339 -- 1. Unchecked_Union enclosing record:
5341 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
5342 -- . . .
5343 -- Comp : UU_Type (Discr);
5344 -- . . .
5345 -- end Enclosing_UU_Type;
5346 -- pragma Unchecked_Union (Enclosing_UU_Type);
5348 -- Obj1 : Enclosing_UU_Type;
5349 -- Obj2 : Enclosing_UU_Type (1);
5351 -- [. . .] Obj1 = Obj2 [. . .]
5353 -- Generated code:
5355 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
5357 -- A and B are the formal parameters of the equality function
5358 -- of Enclosing_UU_Type. The function always has two extra
5359 -- formals to capture the inferred discriminant values.
5361 -- 2. Non-Unchecked_Union enclosing record:
5363 -- type
5364 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
5365 -- is record
5366 -- . . .
5367 -- Comp : UU_Type (Discr);
5368 -- . . .
5369 -- end Enclosing_Non_UU_Type;
5371 -- Obj1 : Enclosing_Non_UU_Type;
5372 -- Obj2 : Enclosing_Non_UU_Type (1);
5374 -- ... Obj1 = Obj2 ...
5376 -- Generated code:
5378 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
5379 -- obj1.discr, obj2.discr)) then
5381 -- In this case we can directly reference the discriminants of
5382 -- the enclosing record.
5384 -- Lhs of equality
5387 and then Has_Per_Object_Constraint
5389 then
5390 -- Enclosing record is an Unchecked_Union, use formal A
5394 then
5395 Lhs_Discr_Val :=
5399 -- Enclosing record is of a non-Unchecked_Union type, it is
5400 -- possible to reference the discriminant.
5402 else
5403 Lhs_Discr_Val :=
5406 Selector_Name =>
5407 New_Copy
5408 (Get_Discriminant_Value
5410 Lhs_Type,
5414 -- Comment needed here ???
5416 else
5417 -- Infer the discriminant value
5419 Lhs_Discr_Val :=
5420 New_Copy
5421 (Get_Discriminant_Value
5423 Lhs_Type,
5427 -- Rhs of equality
5430 and then Has_Per_Object_Constraint
5432 then
5433 if Is_Unchecked_Union
5435 then
5436 Rhs_Discr_Val :=
5440 else
5441 Rhs_Discr_Val :=
5444 Selector_Name =>
5447 Rhs_Type,
5451 else
5452 Rhs_Discr_Val :=
5455 Rhs_Type,
5464 L_Exp,
5465 R_Exp,
5466 Lhs_Discr_Val,
5467 Rhs_Discr_Val)));
5470 -- Normal case, not an unchecked union
5472 else
5482 ------------------------------------
5483 -- Has_Unconstrained_UU_Component --
5484 ------------------------------------
5486 function Has_Unconstrained_UU_Component
5488 is
5494 function Component_Is_Unconstrained_UU
5496 -- Determines whether the subtype of the component is an
5497 -- unconstrained Unchecked_Union.
5499 function Variant_Is_Unconstrained_UU
5501 -- Determines whether a component of the variant has an unconstrained
5502 -- Unchecked_Union subtype.
5504 -----------------------------------
5505 -- Component_Is_Unconstrained_UU --
5506 -----------------------------------
5508 function Component_Is_Unconstrained_UU
5510 is
5511 begin
5516 declare
5520 begin
5521 -- Unconstrained nominal type. In the case of a constraint
5522 -- present, the node kind would have been N_Subtype_Indication.
5532 ---------------------------------
5533 -- Variant_Is_Unconstrained_UU --
5534 ---------------------------------
5536 function Variant_Is_Unconstrained_UU
5538 is
5541 begin
5546 -- We only need to test one component
5548 declare
5551 begin
5561 -- None of the components withing the variant were of
5562 -- unconstrained Unchecked_Union type.
5567 -- Start of processing for Has_Unconstrained_UU_Component
5569 begin
5577 -- Inspect available components
5580 declare
5583 begin
5586 -- One component is sufficient
5597 -- Inspect available components withing variants
5600 declare
5603 begin
5606 -- One component within a variant is sufficient
5617 -- Neither the available components, nor the components inside the
5618 -- variant parts were of an unconstrained Unchecked_Union subtype.
5623 -- Start of processing for Expand_N_Op_Eq
5625 begin
5632 else
5636 -- It may happen in error situations that the underlying type is not
5637 -- set. The error will be detected later, here we just defend the
5638 -- expander code.
5646 -- Boolean types (requiring handling of non-standard case)
5654 -- Array types
5658 -- If we are doing full validity checking, and it is possible for the
5659 -- array elements to be invalid then expand out array comparisons to
5660 -- make sure that we check the array elements.
5662 if Validity_Check_Operands
5664 then
5665 declare
5667 Force_Validity_Checks;
5668 begin
5671 Expand_Array_Equality
5675 Bodies,
5676 Typl));
5682 -- Packed case where both operands are known aligned
5687 then
5690 -- Where the component type is elementary we can use a block bit
5691 -- comparison (if supported on the target) exception in the case
5692 -- of floating-point (negative zero issues require element by
5693 -- element comparison), and atomic types (where we must be sure
5694 -- to load elements independently) and possibly unaligned arrays.
5701 and then Support_Composite_Compare_On_Target
5702 then
5705 -- For composite and floating-point cases, expand equality loop to
5706 -- make sure of using proper comparisons for tagged types, and
5707 -- correctly handling the floating-point case.
5709 else
5711 Expand_Array_Equality
5715 Bodies,
5716 Typl));
5721 -- Record Types
5725 -- For tagged types, use the primitive "="
5729 -- No need to do anything else compiling under restriction
5730 -- No_Dispatching_Calls. During the semantic analysis we
5731 -- already notified such violation.
5737 -- If this is derived from an untagged private type completed with
5738 -- a tagged type, it does not have a full view, so we use the
5739 -- primitive operations of the private type. This check should no
5740 -- longer be necessary when these types get their full views???
5746 then
5747 -- Search for equality operation, checking that the operands
5748 -- have the same type. Note that we must find a matching entry,
5749 -- or something is very wrong!
5757 and then
5766 -- Find the type's predefined equality or an overriding
5767 -- user- defined equality. The reason for not simply calling
5768 -- Find_Prim_Op here is that there may be a user-defined
5769 -- overloaded equality op that precedes the equality that we want,
5770 -- so we have to explicitly search (e.g., there could be an
5771 -- equality with two different parameter types).
5773 else
5783 and then
5795 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
5796 -- predefined equality operator for a type which has a subcomponent
5797 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
5804 -- Prevent Gigi from generating incorrect code by rewriting the
5805 -- equality as a standard False.
5812 -- If we can infer the discriminants of the operands, we make a
5813 -- call to the TSS equality function.
5816 and then
5818 then
5819 Build_Equality_Call
5822 else
5823 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5824 -- the predefined equality operator for an Unchecked_Union type
5825 -- if either of the operands lack inferable discriminants.
5831 -- Prevent Gigi from generating incorrect code by rewriting
5832 -- the equality as a standard False.
5839 -- If a type support function is present (for complex cases), use it
5842 Build_Equality_Call
5845 -- Otherwise expand the component by component equality. Note that
5846 -- we never use block-bit comparisons for records, because of the
5847 -- problems with gaps. The backend will often be able to recombine
5848 -- the separate comparisons that we generate here.
5850 else
5861 -- Test if result is known at compile time
5865 -- If we still have comparison for Vax_Float, process it
5873 -----------------------
5874 -- Expand_N_Op_Expon --
5875 -----------------------
5893 begin
5896 -- If either operand is of a private type, then we have the use of an
5897 -- intrinsic operator, and we get rid of the privateness, by using root
5898 -- types of underlying types for the actual operation. Otherwise the
5899 -- private types will cause trouble if we expand multiplications or
5900 -- shifts etc. We also do this transformation if the result type is
5901 -- different from the base type.
5904 or else
5906 or else
5908 or else
5910 then
5911 declare
5915 begin
5926 -- Test for case of known right argument
5931 -- We only fold small non-negative exponents. You might think we
5932 -- could fold small negative exponents for the real case, but we
5933 -- can't because we are required to raise Constraint_Error for
5934 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
5935 -- See ACVC test C4A012B.
5939 -- X ** 0 = 1 (or 1.0)
5943 -- Call Remove_Side_Effects to ensure that any side effects
5944 -- in the ignored left operand (in particular function calls
5945 -- to user defined functions) are properly executed.
5951 else
5955 -- X ** 1 = X
5960 -- X ** 2 = X * X
5963 Xnode :=
5968 -- X ** 3 = X * X * X
5971 Xnode :=
5973 Left_Opnd =>
5979 -- X ** 4 ->
5980 -- En : constant base'type := base * base;
5981 -- ...
5982 -- En * En
5985 Temp :=
5993 Expression =>
5998 Xnode :=
6010 -- Case of (2 ** expression) appearing as an argument of an integer
6011 -- multiplication, or as the right argument of a division of a non-
6012 -- negative integer. In such cases we leave the node untouched, setting
6013 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
6014 -- of the higher level node converts it into a shift.
6016 -- Note: this transformation is not applicable for a modular type with
6017 -- a non-binary modulus in the multiplication case, since we get a wrong
6018 -- result if the shift causes an overflow before the modular reduction.
6025 and then not Ovflo
6027 then
6028 declare
6033 begin
6036 and then
6038 or else
6042 or else
6048 then
6055 -- Fall through if exponentiation must be done using a runtime routine
6057 -- First deal with modular case
6061 -- Non-binary case, we call the special exponentiation routine for
6062 -- the non-binary case, converting the argument to Long_Long_Integer
6063 -- and passing the modulus value. Then the result is converted back
6064 -- to the base type.
6074 Exp))));
6076 -- Binary case, in this case, we call one of two routines, either the
6077 -- unsigned integer case, or the unsigned long long integer case,
6078 -- with a final "and" operation to do the required mod.
6080 else
6083 else
6090 Left_Opnd =>
6095 Exp)),
6096 Right_Opnd =>
6101 -- Common exit point for modular type case
6106 -- Signed integer cases, done using either Integer or Long_Long_Integer.
6107 -- It is not worth having routines for Short_[Short_]Integer, since for
6108 -- most machines it would not help, and it would generate more code that
6109 -- might need certification when a certified run time is required.
6111 -- In the integer cases, we have two routines, one for when overflow
6112 -- checks are required, and one when they are not required, since there
6113 -- is a real gain in omitting checks on many machines.
6117 and then
6120 then
6125 else
6134 else
6138 -- Floating-point cases, always done using Long_Long_Float. We do not
6139 -- need separate routines for the overflow case here, since in the case
6140 -- of floating-point, we generate infinities anyway as a rule (either
6141 -- that or we automatically trap overflow), and if there is an infinity
6142 -- generated and a range check is required, the check will fail anyway.
6144 else
6150 -- Common processing for integer cases and floating-point cases.
6151 -- If we are in the right type, we can call runtime routine directly
6156 then
6162 -- Otherwise we have to introduce conversions (conversions are also
6163 -- required in the universal cases, since the runtime routine is
6164 -- typed using one of the standard types).
6166 else
6173 Exp))));
6179 exception
6184 --------------------
6185 -- Expand_N_Op_Ge --
6186 --------------------
6194 begin
6211 -- If we still have comparison, and Vax_Float type, process it
6219 --------------------
6220 -- Expand_N_Op_Gt --
6221 --------------------
6229 begin
6246 -- If we still have comparison, and Vax_Float type, process it
6254 --------------------
6255 -- Expand_N_Op_Le --
6256 --------------------
6264 begin
6281 -- If we still have comparison, and Vax_Float type, process it
6289 --------------------
6290 -- Expand_N_Op_Lt --
6291 --------------------
6299 begin
6316 -- If we still have comparison, and Vax_Float type, process it
6324 -----------------------
6325 -- Expand_N_Op_Minus --
6326 -----------------------
6332 begin
6335 if not Backend_Overflow_Checks_On_Target
6338 then
6339 -- Software overflow checking expands -expr into (0 - expr)
6348 -- Vax floating-point types case
6355 ---------------------
6356 -- Expand_N_Op_Mod --
6357 ---------------------
6377 begin
6383 -- Convert mod to rem if operands are known non-negative. We do this
6384 -- since it is quite likely that this will improve the quality of code,
6385 -- (the operation now corresponds to the hardware remainder), and it
6386 -- does not seem likely that it could be harmful.
6389 and then
6391 then
6397 -- Instead of reanalyzing the node we do the analysis manually. This
6398 -- avoids anomalies when the replacement is done in an instance and
6399 -- is epsilon more efficient.
6408 -- Otherwise, normal mod processing
6410 else
6415 -- Apply optimization x mod 1 = 0. We don't really need that with
6416 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
6417 -- certainly harmless.
6422 then
6423 -- Call Remove_Side_Effects to ensure that any side effects in
6424 -- the ignored left operand (in particular function calls to
6425 -- user defined functions) are properly executed.
6434 -- Deal with annoying case of largest negative number remainder
6435 -- minus one. Gigi does not handle this case correctly, because
6436 -- it generates a divide instruction which may trap in this case.
6438 -- In fact the check is quite easy, if the right operand is -1, then
6439 -- the mod value is always 0, and we can just ignore the left operand
6440 -- completely in this case.
6442 -- The operand type may be private (e.g. in the expansion of an
6443 -- intrinsic operation) so we must use the underlying type to get the
6444 -- bounds, and convert the literals explicitly.
6446 LLB :=
6447 Expr_Value
6451 and then
6453 then
6459 Right_Opnd =>
6472 --------------------------
6473 -- Expand_N_Op_Multiply --
6474 --------------------------
6493 begin
6496 -- Special optimizations for integer types
6500 -- N * 0 = 0 for integer types
6504 then
6505 -- Call Remove_Side_Effects to ensure that any side effects in
6506 -- the ignored left operand (in particular function calls to
6507 -- user defined functions) are properly executed.
6516 -- Similar handling for 0 * N = 0
6520 then
6527 -- N * 1 = 1 * N = N for integer types
6529 -- This optimisation is not done if we are going to
6530 -- rewrite the product 1 * 2 ** N to a shift.
6534 and then not Lp2
6535 then
6541 and then not Rp2
6542 then
6548 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
6549 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6550 -- operand is an integer, as required for this to work.
6555 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
6560 Right_Opnd =>
6567 else
6571 Right_Opnd =>
6577 -- Same processing for the operands the other way round
6583 Right_Opnd =>
6589 -- Do required fixup of universal fixed operation
6596 -- Multiplications with fixed-point results
6600 -- No special processing if Treat_Fixed_As_Integer is set, since from
6601 -- a semantic point of view such operations are simply integer
6602 -- operations and will be treated that way.
6606 -- Case of fixed * integer => fixed
6611 -- Case of integer * fixed => fixed
6616 -- Case of fixed * fixed => fixed
6618 else
6623 -- Other cases of multiplication of fixed-point operands. Again we
6624 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
6628 then
6631 else
6636 -- Mixed-mode operations can appear in a non-static universal context,
6637 -- in which case the integer argument must be converted explicitly.
6641 then
6648 then
6653 -- Non-fixed point cases, check software overflow checking required
6658 -- Deal with VAX float case
6666 --------------------
6667 -- Expand_N_Op_Ne --
6668 --------------------
6673 begin
6674 -- Case of elementary type with standard operator
6678 then
6681 -- Boolean types (requiring handling of non-standard case)
6692 -- If we still have comparison for Vax_Float, process it
6699 -- For all cases other than elementary types, we rewrite node as the
6700 -- negation of an equality operation, and reanalyze. The equality to be
6701 -- used is defined in the same scope and has the same signature. This
6702 -- signature must be set explicitly since in an instance it may not have
6703 -- the same visibility as in the generic unit. This avoids duplicating
6704 -- or factoring the complex code for record/array equality tests etc.
6706 else
6707 declare
6712 begin
6715 Neg :=
6717 Right_Opnd =>
6727 -- For navigation purposes, the inequality is treated as an
6728 -- implicit reference to the corresponding equality. Preserve the
6729 -- Comes_From_ source flag so that the proper Xref entry is
6730 -- generated.
6740 ---------------------
6741 -- Expand_N_Op_Not --
6742 ---------------------
6744 -- If the argument is other than a Boolean array type, there is no special
6745 -- expansion required.
6747 -- For the packed case, we call the special routine in Exp_Pakd, except
6748 -- that if the component size is greater than one, we use the standard
6749 -- routine generating a gruesome loop (it is so peculiar to have packed
6750 -- arrays with non-standard Boolean representations anyway, so it does not
6751 -- matter that we do not handle this case efficiently).
6753 -- For the unpacked case (and for the special packed case where we have non
6754 -- standard Booleans, as discussed above), we generate and insert into the
6755 -- tree the following function definition:
6757 -- function Nnnn (A : arr) is
6758 -- B : arr;
6759 -- begin
6760 -- for J in a'range loop
6761 -- B (J) := not A (J);
6762 -- end loop;
6763 -- return B;
6764 -- end Nnnn;
6766 -- Here arr is the actual subtype of the parameter (and hence always
6767 -- constrained). Then we replace the not with a call to this function.
6783 begin
6786 -- For boolean operand, deal with non-standard booleans
6795 -- Only array types need any other processing
6801 -- Case of array operand. If bit packed with a component size of 1,
6802 -- handle it in Exp_Pakd if the operand is known to be aligned.
6807 then
6812 -- Case of array operand which is not bit-packed. If the context is
6813 -- a safe assignment, call in-place operation, If context is a larger
6814 -- boolean expression in the context of a safe assignment, expansion is
6815 -- done by enclosing operation.
6828 -- Special case the negation of a binary operation
6831 and then Safe_In_Place_Array_Op
6833 then
6840 then
6841 declare
6846 begin
6850 then
6851 -- (not A) op (not B) can be reduced to a single call
6857 then
6858 -- A xor (not B) can also be special-cased
6870 A_J :=
6875 B_J :=
6880 Loop_Statement :=
6884 Iteration_Scheme =>
6886 Loop_Parameter_Specification =>
6889 Discrete_Subtype_Definition =>
6904 Specification =>
6918 Handled_Statement_Sequence =>
6921 Loop_Statement,
6923 Expression =>
6934 --------------------
6935 -- Expand_N_Op_Or --
6936 --------------------
6941 begin
6949 -- Replace OR by OR ELSE if Short_Circuit_And_Or active and the
6950 -- type is standard Boolean (do not mess with AND that uses a non-
6951 -- standard Boolean type, because something strange is going on).
6960 -- Otherwise, adjust conditions
6962 else
6971 ----------------------
6972 -- Expand_N_Op_Plus --
6973 ----------------------
6976 begin
6980 ---------------------
6981 -- Expand_N_Op_Rem --
6982 ---------------------
6997 -- Set if corresponding operand can be negative
7001 begin
7008 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
7009 -- but it is useful with other back ends (e.g. AAMP), and is certainly
7010 -- harmless.
7015 then
7016 -- Call Remove_Side_Effects to ensure that any side effects in the
7017 -- ignored left operand (in particular function calls to user defined
7018 -- functions) are properly executed.
7027 -- Deal with annoying case of largest negative number remainder minus
7028 -- one. Gigi does not handle this case correctly, because it generates
7029 -- a divide instruction which may trap in this case.
7031 -- In fact the check is quite easy, if the right operand is -1, then
7032 -- the remainder is always 0, and we can just ignore the left operand
7033 -- completely in this case.
7041 -- We won't mess with trying to find out if the left operand can really
7042 -- be the largest negative number (that's a pain in the case of private
7043 -- types and this is really marginal). We will just assume that we need
7044 -- the test if the left operand can be negative at all.
7052 Right_Opnd =>
7066 -----------------------------
7067 -- Expand_N_Op_Rotate_Left --
7068 -----------------------------
7071 begin
7075 ------------------------------
7076 -- Expand_N_Op_Rotate_Right --
7077 ------------------------------
7080 begin
7084 ----------------------------
7085 -- Expand_N_Op_Shift_Left --
7086 ----------------------------
7089 begin
7093 -----------------------------
7094 -- Expand_N_Op_Shift_Right --
7095 -----------------------------
7098 begin
7102 ----------------------------------------
7103 -- Expand_N_Op_Shift_Right_Arithmetic --
7104 ----------------------------------------
7107 begin
7111 --------------------------
7112 -- Expand_N_Op_Subtract --
7113 --------------------------
7118 begin
7121 -- N - 0 = N for integer types
7126 then
7131 -- Arithmetic overflow checks for signed integer/fixed point types
7135 then
7138 -- Vax floating-point types case
7145 ---------------------
7146 -- Expand_N_Op_Xor --
7147 ---------------------
7152 begin
7166 ----------------------
7167 -- Expand_N_Or_Else --
7168 ----------------------
7170 -- Expand into conditional expression if Actions present, and also
7171 -- deal with optimizing case of arguments being True or False.
7180 begin
7181 -- Deal with non-standard booleans
7189 -- Check for cases where left argument is known to be True or False
7193 -- If left argument is False, change (False or else Right) to Right.
7194 -- Any actions associated with Right will be executed unconditionally
7195 -- and can thus be inserted into the tree unconditionally.
7204 -- If left argument is True, change (True and then Right) to True. In
7205 -- this case we can forget the actions associated with Right, since
7206 -- they will never be executed.
7218 -- If Actions are present, we expand
7220 -- left or else right
7222 -- into
7224 -- if left then True else right end
7226 -- with the actions becoming the Else_Actions of the conditional
7227 -- expression. This conditional expression is then further expanded
7228 -- (and will eventually disappear)
7235 Left,
7237 Right)));
7245 -- No actions present, check for cases of right argument True/False
7249 -- Change (Left or else False) to Left. Note that we know there are
7250 -- no actions associated with the True operand, since we just checked
7251 -- for this case above.
7256 -- Change (Left or else True) to True, making sure to preserve any
7257 -- side effects associated with the Left operand.
7261 Rewrite
7269 -----------------------------------
7270 -- Expand_N_Qualified_Expression --
7271 -----------------------------------
7277 begin
7278 -- Do validity check if validity checking operands
7280 if Validity_Checks_On
7281 and then Validity_Check_Operands
7282 then
7286 -- Apply possible constraint check
7296 ---------------------------------
7297 -- Expand_N_Selected_Component --
7298 ---------------------------------
7300 -- If the selector is a discriminant of a concurrent object, rewrite the
7301 -- prefix to denote the corresponding record type.
7313 -- Gigi needs a temporary for prefixes that depend on a discriminant,
7314 -- unless the context of an assignment can provide size information.
7315 -- Don't we have a general routine that does this???
7317 -----------------------
7318 -- In_Left_Hand_Side --
7319 -----------------------
7322 begin
7330 -- Start of processing for Expand_N_Selected_Component
7332 begin
7333 -- Insert explicit dereference if required
7341 then
7348 -- Deal with discriminant check required
7352 -- Present the discriminant checking function to the backend, so that
7353 -- it can inline the call to the function.
7355 Add_Inlined_Body
7356 (Discriminant_Checking_Func
7359 -- Now reset the flag and generate the call
7365 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7366 -- function, then additional actuals must be passed.
7370 then
7374 -- Gigi cannot handle unchecked conversions that are the prefix of a
7375 -- selected component with discriminants. This must be checked during
7376 -- expansion, because during analysis the type of the selector is not
7377 -- known at the point the prefix is analyzed. If the conversion is the
7378 -- target of an assignment, then we cannot force the evaluation.
7383 then
7387 -- Remaining processing applies only if selector is a discriminant
7391 -- If the selector is a discriminant of a constrained record type,
7392 -- we may be able to rewrite the expression with the actual value
7393 -- of the discriminant, a useful optimization in some cases.
7398 then
7399 -- Do this optimization for discrete types only, and not for
7400 -- access types (access discriminants get us into trouble!)
7405 -- Don't do this on the left hand of an assignment statement.
7406 -- Normally one would think that references like this would
7407 -- not occur, but they do in generated code, and mean that
7408 -- we really do want to assign the discriminant!
7412 then
7415 -- Don't do this optimization for the prefix of an attribute or
7416 -- the operand of an object renaming declaration since these are
7417 -- contexts where we do not want the value anyway.
7422 then
7425 -- Don't do this optimization if we are within the code for a
7426 -- discriminant check, since the whole point of such a check may
7427 -- be to verify the condition on which the code below depends!
7432 -- Green light to see if we can do the optimization. There is
7433 -- still one condition that inhibits the optimization below but
7434 -- now is the time to check the particular discriminant.
7436 else
7437 -- Loop through discriminants to find the matching discriminant
7438 -- constraint to see if we can copy it.
7444 -- Check if this is the matching discriminant
7448 -- Here we have the matching discriminant. Check for
7449 -- the case of a discriminant of a component that is
7450 -- constrained by an outer discriminant, which cannot
7451 -- be optimized away.
7453 if
7454 Denotes_Discriminant
7456 then
7459 -- In the context of a case statement, the expression may
7460 -- have the base type of the discriminant, and we need to
7461 -- preserve the constraint to avoid spurious errors on
7462 -- missing cases.
7466 then
7469 Subtype_Mark =>
7471 Expression =>
7475 -- In case that comes out as a static expression,
7476 -- reset it (a selected component is never static).
7481 -- Otherwise we can just copy the constraint, but the
7482 -- result is certainly not static! In some cases the
7483 -- discriminant constraint has been analyzed in the
7484 -- context of the original subtype indication, but for
7485 -- itypes the constraint might not have been analyzed
7486 -- yet, and this must be done now.
7488 else
7500 -- Note: the above loop should always find a matching
7501 -- discriminant, but if it does not, we just missed an
7502 -- optimization due to some glitch (perhaps a previous error),
7503 -- so ignore.
7508 -- The only remaining processing is in the case of a discriminant of
7509 -- a concurrent object, where we rewrite the prefix to denote the
7510 -- corresponding record type. If the type is derived and has renamed
7511 -- discriminants, use corresponding discriminant, which is the one
7512 -- that appears in the corresponding record.
7522 then
7526 New_N :=
7528 Prefix =>
7538 --------------------
7539 -- Expand_N_Slice --
7540 --------------------
7549 -- Check whether the argument is an actual for a procedure call, in
7550 -- which case the expansion of a bit-packed slice is deferred until the
7551 -- call itself is expanded. The reason this is required is that we might
7552 -- have an IN OUT or OUT parameter, and the copy out is essential, and
7553 -- that copy out would be missed if we created a temporary here in
7554 -- Expand_N_Slice. Note that we don't bother to test specifically for an
7555 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
7556 -- is harmless to defer expansion in the IN case, since the call
7557 -- processing will still generate the appropriate copy in operation,
7558 -- which will take care of the slice.
7561 -- Create a named variable for the value of the slice, in cases where
7562 -- the back-end cannot handle it properly, e.g. when packed types or
7563 -- unaligned slices are involved.
7565 -------------------------
7566 -- Is_Procedure_Actual --
7567 -------------------------
7572 begin
7573 loop
7574 -- If our parent is a procedure call we can return
7579 -- If our parent is a type conversion, keep climbing the tree,
7580 -- since a type conversion can be a procedure actual. Also keep
7581 -- climbing if parameter association or a qualified expression,
7582 -- since these are additional cases that do can appear on
7583 -- procedure actuals.
7586 N_Parameter_Association,
7587 N_Qualified_Expression)
7588 then
7591 -- Any other case is not what we are looking for
7593 else
7599 ------------------------------
7600 -- Make_Temporary_For_Slice --
7601 ------------------------------
7606 begin
7607 Decl :=
7615 Decl,
7624 -- Start of processing for Expand_N_Slice
7626 begin
7627 -- Special handling for access types
7640 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7641 -- function, then additional actuals must be passed.
7645 then
7649 -- The remaining case to be handled is packed slices. We can leave
7650 -- packed slices as they are in the following situations:
7652 -- 1. Right or left side of an assignment (we can handle this
7653 -- situation correctly in the assignment statement expansion).
7655 -- 2. Prefix of indexed component (the slide is optimized away in this
7656 -- case, see the start of Expand_N_Slice.)
7658 -- 3. Object renaming declaration, since we want the name of the
7659 -- slice, not the value.
7661 -- 4. Argument to procedure call, since copy-in/copy-out handling may
7662 -- be required, and this is handled in the expansion of call
7663 -- itself.
7665 -- 5. Prefix of an address attribute (this is an error which is caught
7666 -- elsewhere, and the expansion would interfere with generating the
7667 -- error message).
7671 -- Apply transformation for actuals of a function call, where
7672 -- Expand_Actuals is not used.
7676 then
7677 Make_Temporary_For_Slice;
7683 then
7689 then
7694 then
7697 else
7698 Make_Temporary_For_Slice;
7702 ------------------------------
7703 -- Expand_N_Type_Conversion --
7704 ------------------------------
7713 -- This is called in the case of record and array type conversions to
7714 -- see if there is a change of representation to be handled. Change of
7715 -- representation is actually handled at the assignment statement level,
7716 -- and what this procedure does is rewrite node N conversion as an
7717 -- assignment to temporary. If there is no change of representation,
7718 -- then the conversion node is unchanged.
7721 -- Called when we know that an accessibility check will fail. Rewrites
7722 -- node N to an appropriate raise statement and outputs warning msgs.
7723 -- The Etype of the raise node is set to Target_Type.
7726 -- Handles generation of range check for real target value
7728 -----------------------------------
7729 -- Handle_Changed_Representation --
7730 -----------------------------------
7740 begin
7742 -- Nothing else to do if no change of representation
7747 -- The real change of representation work is done by the assignment
7748 -- statement processing. So if this type conversion is appearing as
7749 -- the expression of an assignment statement, nothing needs to be
7750 -- done to the conversion.
7755 -- Otherwise we need to generate a temporary variable, and do the
7756 -- change of representation assignment into that temporary variable.
7757 -- The conversion is then replaced by a reference to this variable.
7759 else
7762 -- If type is unconstrained we have to add a constraint, copied
7763 -- from the actual value of the left hand side.
7778 Selector_Name =>
7789 -- We convert the bounds explicitly. We use an unchecked
7790 -- conversion because bounds checks are done elsewhere.
7794 Low_Bound =>
7797 Prefix =>
7798 Duplicate_Subexpr_No_Checks
7804 High_Bound =>
7807 Prefix =>
7808 Duplicate_Subexpr_No_Checks
7822 Odef :=
7825 Constraint =>
7831 Decl :=
7838 -- Insert required actions. It is essential to suppress checks
7839 -- since we have suppressed default initialization, which means
7840 -- that the variable we create may have no discriminants.
7843 New_List (
7844 Decl,
7855 -------------------------------
7856 -- Raise_Accessibility_Error --
7857 -------------------------------
7860 begin
7867 Error_Msg_NE
7871 ----------------------
7872 -- Real_Range_Check --
7873 ----------------------
7875 -- Case of conversions to floating-point or fixed-point. If range checks
7876 -- are enabled and the target type has a range constraint, we convert:
7878 -- typ (x)
7880 -- to
7882 -- Tnn : typ'Base := typ'Base (x);
7883 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7884 -- Tnn
7886 -- This is necessary when there is a conversion of integer to float or
7887 -- to fixed-point to ensure that the correct checks are made. It is not
7888 -- necessary for float to float where it is enough to simply set the
7889 -- Do_Range_Check flag.
7899 begin
7900 -- Nothing to do if conversion was rewritten
7906 -- Nothing to do if range checks suppressed, or target has the same
7907 -- range as the base type (or is the base type).
7911 and then
7913 then
7917 -- Nothing to do if expression is an entity on which checks have been
7918 -- suppressed.
7922 then
7926 -- Nothing to do if bounds are all static and we can tell that the
7927 -- expression is within the bounds of the target. Note that if the
7928 -- operand is of an unconstrained floating-point type, then we do
7929 -- not trust it to be in range (might be infinite)
7931 declare
7935 begin
7942 then
7943 declare
7949 begin
7953 else
7961 then
7969 -- For float to float conversions, we are done
7972 and then
7974 then
7978 -- Otherwise rewrite the conversion as described above
7984 -- Enable overflow except for case of integer to float conversions,
7985 -- where it is never required, since we can never have overflow in
7986 -- this case.
7992 Tnn :=
8003 Condition =>
8005 Left_Opnd =>
8008 Right_Opnd =>
8011 Prefix =>
8014 Right_Opnd =>
8017 Right_Opnd =>
8020 Prefix =>
8028 -- Start of processing for Expand_N_Type_Conversion
8030 begin
8031 -- Nothing at all to do if conversion is to the identical type so remove
8032 -- the conversion completely, it is useless, except that it may carry
8033 -- an Assignment_OK attribute, which must be propagated to the operand.
8044 -- Nothing to do if this is the second argument of read. This is a
8045 -- "backwards" conversion that will be handled by the specialized code
8046 -- in attribute processing.
8051 then
8055 -- Here if we may need to expand conversion
8057 -- If the operand of the type conversion is an arithmetic operation on
8058 -- signed integers, and the based type of the signed integer type in
8059 -- question is smaller than Standard.Integer, we promote both of the
8060 -- operands to type Integer.
8062 -- For example, if we have
8064 -- target-type (opnd1 + opnd2)
8066 -- and opnd1 and opnd2 are of type short integer, then we rewrite
8067 -- this as:
8069 -- target-type (integer(opnd1) + integer(opnd2))
8071 -- We do this because we are always allowed to compute in a larger type
8072 -- if we do the right thing with the result, and in this case we are
8073 -- going to do a conversion which will do an appropriate check to make
8074 -- sure that things are in range of the target type in any case. This
8075 -- avoids some unnecessary intermediate overflows.
8077 -- We might consider a similar transformation in the case where the
8078 -- target is a real type or a 64-bit integer type, and the operand
8079 -- is an arithmetic operation using a 32-bit integer type. However,
8080 -- we do not bother with this case, because it could cause significant
8081 -- ineffiencies on 32-bit machines. On a 64-bit machine it would be
8082 -- much cheaper, but we don't want different behavior on 32-bit and
8083 -- 64-bit machines. Note that the exclusion of the 64-bit case also
8084 -- handles the configurable run-time cases where 64-bit arithmetic
8085 -- may simply be unavailable.
8087 -- Note: this circuit is partially redundant with respect to the circuit
8088 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
8089 -- the processing here. Also we still need the Checks circuit, since we
8090 -- have to be sure not to generate junk overflow checks in the first
8091 -- place, since it would be trick to remove them here!
8095 -- All conditions met, go ahead with transformation
8097 declare
8101 begin
8102 R :=
8111 L :=
8129 -- Do validity check if validity checking operands
8131 if Validity_Checks_On
8132 and then Validity_Check_Operands
8133 then
8137 -- Special case of converting from non-standard boolean type
8141 then
8147 -- Case of converting to an access type
8151 -- Apply an accessibility check when the conversion operand is an
8152 -- access parameter (or a renaming thereof), unless conversion was
8153 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
8154 -- Note that other checks may still need to be applied below (such
8155 -- as tagged type checks).
8158 and then
8160 or else
8163 and then Is_Formal
8168 then
8169 Apply_Accessibility_Check
8172 -- If the level of the operand type is statically deeper than the
8173 -- level of the target type, then force Program_Error. Note that this
8174 -- can only occur for cases where the attribute is within the body of
8175 -- an instantiation (otherwise the conversion will already have been
8176 -- rejected as illegal). Note: warnings are issued by the analyzer
8177 -- for the instance cases.
8179 elsif In_Instance_Body
8182 then
8183 Raise_Accessibility_Error;
8185 -- When the operand is a selected access discriminant the check needs
8186 -- to be made against the level of the object denoted by the prefix
8187 -- of the selected name. Force Program_Error for this case as well
8188 -- (this accessibility violation can only happen if within the body
8189 -- of an instantiation).
8191 elsif In_Instance_Body
8196 then
8197 Raise_Accessibility_Error;
8202 -- Case of conversions of tagged types and access to tagged types
8204 -- When needed, that is to say when the expression is class-wide, Add
8205 -- runtime a tag check for (strict) downward conversion by using the
8206 -- membership test, generating:
8208 -- [constraint_error when Operand not in Target_Type'Class]
8210 -- or in the access type case
8212 -- [constraint_error
8213 -- when Operand /= null
8214 -- and then Operand.all not in
8215 -- Designated_Type (Target_Type)'Class]
8220 then
8221 -- Do not do any expansion in the access type case if the parent is a
8222 -- renaming, since this is an error situation which will be caught by
8223 -- Sem_Ch8, and the expansion can interfere with this error check.
8227 then
8231 -- Otherwise, proceed with processing tagged conversion
8233 declare
8240 -- Create a membership check to test whether Operand is a member
8241 -- of Targ_Typ. If the original Target_Type is an access, include
8242 -- a test for null value. The check is inserted at N.
8244 --------------------
8245 -- Make_Tag_Check --
8246 --------------------
8251 begin
8252 -- Generate:
8253 -- [Constraint_Error
8254 -- when Operand /= null
8255 -- and then Operand.all not in Targ_Typ]
8258 Cond :=
8260 Left_Opnd =>
8265 Right_Opnd =>
8267 Left_Opnd =>
8272 -- Generate:
8273 -- [Constraint_Error when Operand not in Targ_Typ]
8275 else
8276 Cond :=
8288 -- Start of processing
8290 begin
8293 -- Handle entities from the limited view
8295 Actual_Op_Typ :=
8297 Actual_Targ_Typ :=
8299 else
8306 -- Ada 2005 (AI-251): Handle interface type conversion
8315 -- Create a runtime tag check for a downward class-wide type
8316 -- conversion.
8322 then
8327 -- AI05-0073: If the result subtype of the function is defined
8328 -- by an access_definition designating a specific tagged type
8329 -- T, a check is made that the result value is null or the tag
8330 -- of the object designated by the result value identifies T.
8331 -- Constraint_Error is raised if this check fails.
8334 declare
8338 begin
8339 -- Climb scope stack looking for the enclosing function
8344 loop
8348 -- The function's return subtype must be defined using
8349 -- an access definition.
8352 N_Access_Definition
8353 then
8356 -- The return subtype denotes a specific tagged type,
8357 -- in other words, a non class-wide type.
8361 then
8369 -- We have generated a tag check for either a class-wide type
8370 -- conversion or for AI05-0073.
8373 declare
8375 begin
8376 Conv :=
8387 -- Case of other access type conversions
8392 -- Case of conversions from a fixed-point type
8394 -- These conversions require special expansion and processing, found in
8395 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
8396 -- since from a semantic point of view, these are simple integer
8397 -- conversions, which do not need further processing.
8401 then
8402 -- We should never see universal fixed at this case, since the
8403 -- expansion of the constituent divide or multiply should have
8404 -- eliminated the explicit mention of universal fixed.
8408 -- Check for special case of the conversion to universal real that
8409 -- occurs as a result of the use of a round attribute. In this case,
8410 -- the real type for the conversion is taken from the target type of
8411 -- the Round attribute and the result must be marked as rounded.
8416 then
8421 -- Otherwise do correct fixed-conversion, but skip these if the
8422 -- Conversion_OK flag is set, because from a semantic point of
8423 -- view these are simple integer conversions needing no further
8424 -- processing (the backend will simply treat them as integers)
8429 Real_Range_Check;
8434 else
8437 Real_Range_Check;
8441 -- Case of conversions to a fixed-point type
8443 -- These conversions require special expansion and processing, found in
8444 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
8445 -- since from a semantic point of view, these are simple integer
8446 -- conversions, which do not need further processing.
8450 then
8453 Real_Range_Check;
8454 else
8457 Real_Range_Check;
8460 -- Case of float-to-integer conversions
8462 -- We also handle float-to-fixed conversions with Conversion_OK set
8463 -- since semantically the fixed-point target is treated as though it
8464 -- were an integer in such cases.
8467 and then
8469 or else
8471 then
8472 -- One more check here, gcc is still not able to do conversions of
8473 -- this type with proper overflow checking, and so gigi is doing an
8474 -- approximation of what is required by doing floating-point compares
8475 -- with the end-point. But that can lose precision in some cases, and
8476 -- give a wrong result. Converting the operand to Universal_Real is
8477 -- helpful, but still does not catch all cases with 64-bit integers
8478 -- on targets with only 64-bit floats
8480 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
8481 -- Can this code be removed ???
8486 Subtype_Mark =>
8488 Expression =>
8496 -- Case of array conversions
8498 -- Expansion of array conversions, add required length/range checks but
8499 -- only do this if there is no change of representation. For handling of
8500 -- this case, see Handle_Changed_Representation.
8506 else
8510 Handle_Changed_Representation;
8512 -- Case of conversions of discriminated types
8514 -- Add required discriminant checks if target is constrained. Again this
8515 -- change is skipped if we have a change of representation.
8519 then
8521 Handle_Changed_Representation;
8523 -- Case of all other record conversions. The only processing required
8524 -- is to check for a change of representation requiring the special
8525 -- assignment processing.
8529 -- Ada 2005 (AI-216): Program_Error is raised when converting from
8530 -- a derived Unchecked_Union type to an unconstrained type that is
8531 -- not Unchecked_Union if the operand lacks inferable discriminants.
8538 then
8539 -- To prevent Gigi from generating illegal code, we generate a
8540 -- Program_Error node, but we give it the target type of the
8541 -- conversion.
8543 declare
8547 begin
8552 else
8553 Handle_Changed_Representation;
8556 -- Case of conversions of enumeration types
8560 -- Special processing is required if there is a change of
8561 -- representation (from enumeration representation clauses)
8565 -- Convert: x(y) to x'val (ytyp'val (y))
8580 -- Case of conversions to floating-point
8583 Real_Range_Check;
8586 -- At this stage, either the conversion node has been transformed into
8587 -- some other equivalent expression, or left as a conversion that can
8588 -- be handled by Gigi. The conversions that Gigi can handle are the
8589 -- following:
8591 -- Conversions with no change of representation or type
8593 -- Numeric conversions involving integer, floating- and fixed-point
8594 -- values. Fixed-point values are allowed only if Conversion_OK is
8595 -- set, i.e. if the fixed-point values are to be treated as integers.
8597 -- No other conversions should be passed to Gigi
8599 -- Check: are these rules stated in sinfo??? if so, why restate here???
8601 -- The only remaining step is to generate a range check if we still have
8602 -- a type conversion at this stage and Do_Range_Check is set. For now we
8603 -- do this only for conversions of discrete types.
8607 then
8608 declare
8613 begin
8616 then
8619 -- Before we do a range check, we have to deal with treating a
8620 -- fixed-point operand as an integer. The way we do this is
8621 -- simply to do an unchecked conversion to an appropriate
8622 -- integer type large enough to hold the result.
8624 -- This code is not active yet, because we are only dealing
8625 -- with discrete types so far ???
8629 then
8634 else
8641 -- Reset overflow flag, since the range check will include
8642 -- dealing with possible overflow, and generate the check If
8643 -- Address is either a source type or target type, suppress
8644 -- range check to avoid typing anomalies when it is a visible
8645 -- integer type.
8650 then
8651 Generate_Range_Check
8658 -- Final step, if the result is a type conversion involving Vax_Float
8659 -- types, then it is subject for further special processing.
8663 then
8669 -----------------------------------
8670 -- Expand_N_Unchecked_Expression --
8671 -----------------------------------
8673 -- Remove the unchecked expression node from the tree. It's job was simply
8674 -- to make sure that its constituent expression was handled with checks
8675 -- off, and now that that is done, we can remove it from the tree, and
8676 -- indeed must, since gigi does not expect to see these nodes.
8681 begin
8686 ----------------------------------------
8687 -- Expand_N_Unchecked_Type_Conversion --
8688 ----------------------------------------
8690 -- If this cannot be handled by Gigi and we haven't already made a
8691 -- temporary for it, do it now.
8698 begin
8699 -- Nothing at all to do if conversion is to the identical type so remove
8700 -- the conversion completely, it is useless, except that it may carry
8701 -- an Assignment_OK indication which must be proprgated to the operand.
8712 -- If we have a conversion of a compile time known value to a target
8713 -- type and the value is in range of the target type, then we can simply
8714 -- replace the construct by an integer literal of the correct type. We
8715 -- only apply this to integer types being converted. Possibly it may
8716 -- apply in other cases, but it is too much trouble to worry about.
8718 -- Note that we do not do this transformation if the Kill_Range_Check
8719 -- flag is set, since then the value may be outside the expected range.
8720 -- This happens in the Normalize_Scalars case.
8722 -- We also skip this if either the target or operand type is biased
8723 -- because in this case, the unchecked conversion is supposed to
8724 -- preserve the bit pattern, not the integer value.
8732 then
8733 declare
8736 begin
8738 and then
8740 and then
8742 and then
8744 then
8747 -- If Address is the target type, just set the type to avoid a
8748 -- spurious type error on the literal when Address is a visible
8749 -- integer type.
8753 else
8762 -- Nothing to do if conversion is safe
8768 -- Otherwise force evaluation unless Assignment_OK flag is set (this
8769 -- flag indicates ??? -- more comments needed here)
8773 else
8778 ----------------------------
8779 -- Expand_Record_Equality --
8780 ----------------------------
8782 -- For non-variant records, Equality is expanded when needed into:
8784 -- and then Lhs.Discr1 = Rhs.Discr1
8785 -- and then ...
8786 -- and then Lhs.Discrn = Rhs.Discrn
8787 -- and then Lhs.Cmp1 = Rhs.Cmp1
8788 -- and then ...
8789 -- and then Lhs.Cmpn = Rhs.Cmpn
8791 -- The expression is folded by the back-end for adjacent fields. This
8792 -- function is called for tagged record in only one occasion: for imple-
8793 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
8794 -- otherwise the primitive "=" is used directly.
8796 function Expand_Record_Equality
8802 is
8811 -- Return the first field to compare beginning with C, skipping the
8812 -- inherited components.
8814 ----------------------
8815 -- Suitable_Element --
8816 ----------------------
8819 begin
8825 then
8830 then
8835 then
8841 else
8846 -- Start of processing for Expand_Record_Equality
8848 begin
8849 -- Generates the following code: (assuming that Typ has one Discr and
8850 -- component C2 is also a record)
8852 -- True
8853 -- and then Lhs.Discr1 = Rhs.Discr1
8854 -- and then Lhs.C1 = Rhs.C1
8855 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8856 -- and then ...
8857 -- and then Lhs.Cmpn = Rhs.Cmpn
8863 declare
8868 begin
8873 else
8878 Check :=
8880 Lhs =>
8884 Rhs =>
8890 -- If some (sub)component is an unchecked_union, the whole
8891 -- operation will raise program error.
8897 else
8898 Result :=
8911 -------------------------------------
8912 -- Fixup_Universal_Fixed_Operation --
8913 -------------------------------------
8918 begin
8919 -- We must have a type conversion immediately above us
8923 -- Normally the type conversion gives our target type. The exception
8924 -- occurs in the case of the Round attribute, where the conversion
8925 -- will be to universal real, and our real type comes from the Round
8926 -- attribute (as well as an indication that we must round the result)
8930 then
8934 -- Normal case where type comes from conversion above us
8936 else
8941 ------------------------------
8942 -- Get_Allocator_Final_List --
8943 ------------------------------
8945 function Get_Allocator_Final_List
8949 is
8953 -- The entity whose finalization list must be used to attach the
8954 -- allocated object.
8956 begin
8959 -- If the context is an access parameter, we need to create a
8960 -- non-anonymous access type in order to have a usable final list,
8961 -- because there is otherwise no pool to which the allocated object
8962 -- can belong. We create both the type and the finalization chain
8963 -- here, because freezing an internal type does not create such a
8964 -- chain. The Final_Chain that is thus created is shared by the
8965 -- access parameter. The access type is tested against the result
8966 -- type of the function to exclude allocators whose type is an
8967 -- anonymous access result type. We freeze the type at once to
8968 -- ensure that it is properly decorated for the back-end, even
8969 -- if the context and current scope is a loop.
8972 in N_Subprogram_Specification
8973 and then
8974 PtrT /=
8976 then
8981 Type_Definition =>
8983 Subtype_Indication =>
8990 -- Ada 2005 (AI-318-02): If the context is a return object
8991 -- declaration, then the anonymous return subtype is defined to have
8992 -- the same accessibility level as that of the function's result
8993 -- subtype, which means that we want the scope where the function is
8994 -- declared.
8998 then
9001 -- Case of an access discriminant, or (Ada 2005), of an anonymous
9002 -- access component or anonymous access function result: find the
9003 -- final list associated with the scope of the type. (In the
9004 -- anonymous access component kind, a list controller will have
9005 -- been allocated when freezing the record type, and PtrT has an
9006 -- Associated_Final_Chain attribute designating it.)
9016 ---------------------------------
9017 -- Has_Inferable_Discriminants --
9018 ---------------------------------
9023 -- Determines whether the left-most prefix of a selected component is a
9024 -- formal parameter in a subprogram. Assumes N is a selected component.
9026 --------------------------------
9027 -- Prefix_Is_Formal_Parameter --
9028 --------------------------------
9033 begin
9034 -- Move to the left-most prefix by climbing up the tree
9038 loop
9045 -- Start of processing for Has_Inferable_Discriminants
9047 begin
9048 -- For identifiers and indexed components, it is sufficient to have a
9049 -- constrained Unchecked_Union nominal subtype.
9053 and then
9056 -- For selected components, the subtype of the selector must be a
9057 -- constrained Unchecked_Union. If the component is subject to a
9058 -- per-object constraint, then the enclosing object must have inferable
9059 -- discriminants.
9064 -- A small hack. If we have a per-object constrained selected
9065 -- component of a formal parameter, return True since we do not
9066 -- know the actual parameter association yet.
9072 -- Otherwise, check the enclosing object and the selector
9075 and then
9079 -- The call to Has_Inferable_Discriminants will determine whether
9080 -- the selector has a constrained Unchecked_Union nominal type.
9084 -- A qualified expression has inferable discriminants if its subtype
9085 -- mark is a constrained Unchecked_Union subtype.
9089 and then
9097 -------------------------------
9098 -- Insert_Dereference_Action --
9099 -------------------------------
9108 -- Return true if type of P is derived from Checked_Pool;
9110 -----------------------------
9111 -- Is_Checked_Storage_Pool --
9112 -----------------------------
9117 begin
9126 else
9134 -- Start of processing for Insert_Dereference_Action
9136 begin
9141 then
9152 -- Pool
9156 -- Storage_Address. We use the attribute Pool_Address, which uses
9157 -- the pointer itself to find the address of the object, and which
9158 -- handles unconstrained arrays properly by computing the address
9159 -- of the template. i.e. the correct address of the corresponding
9160 -- allocation.
9166 -- Size_In_Storage_Elements
9169 Left_Opnd =>
9171 Prefix =>
9175 Right_Opnd =>
9178 -- Alignment
9181 Prefix =>
9186 exception
9191 --------------------------------
9192 -- Integer_Promotion_Possible --
9193 --------------------------------
9200 begin
9203 return
9205 -- We only do the transformation for source constructs. We assume
9206 -- that the expander knows what it is doing when it generates code.
9210 -- If the operand type is Short_Integer or Short_Short_Integer,
9211 -- then we will promote to Integer, which is available on all
9212 -- targets, and is sufficient to ensure no intermediate overflow.
9213 -- Furthermore it is likely to be as efficient or more efficient
9214 -- than using the smaller type for the computation so we do this
9215 -- unconditionally.
9217 and then
9219 or else
9222 -- Test for interesting operation, which includes addition,
9223 -- division, exponentiation, multiplication, subtraction, absolute
9224 -- value and unary negation. Unary "+" is omitted since it is a
9225 -- no-op and thus can't overflow.
9228 N_Op_Add,
9229 N_Op_Divide,
9230 N_Op_Expon,
9231 N_Op_Minus,
9232 N_Op_Multiply,
9233 N_Op_Subtract);
9236 ------------------------------
9237 -- Make_Array_Comparison_Op --
9238 ------------------------------
9240 -- This is a hand-coded expansion of the following generic function:
9242 -- generic
9243 -- type elem is (<>);
9244 -- type index is (<>);
9245 -- type a is array (index range <>) of elem;
9247 -- function Gnnn (X : a; Y: a) return boolean is
9248 -- J : index := Y'first;
9250 -- begin
9251 -- if X'length = 0 then
9252 -- return false;
9254 -- elsif Y'length = 0 then
9255 -- return true;
9257 -- else
9258 -- for I in X'range loop
9259 -- if X (I) = Y (J) then
9260 -- if J = Y'last then
9261 -- exit;
9262 -- else
9263 -- J := index'succ (J);
9264 -- end if;
9266 -- else
9267 -- return X (I) > Y (J);
9268 -- end if;
9269 -- end loop;
9271 -- return X'length > Y'length;
9272 -- end if;
9273 -- end Gnnn;
9275 -- Note that since we are essentially doing this expansion by hand, we
9276 -- do not need to generate an actual or formal generic part, just the
9277 -- instantiated function itself.
9279 function Make_Array_Comparison_Op
9282 is
9303 begin
9304 -- if J = Y'last then
9305 -- exit;
9306 -- else
9307 -- J := index'succ (J);
9308 -- end if;
9310 Inner_If :=
9312 Condition =>
9315 Right_Opnd =>
9323 Else_Statements =>
9324 New_List (
9327 Expression =>
9333 -- if X (I) = Y (J) then
9334 -- if ... end if;
9335 -- else
9336 -- return X (I) > Y (J);
9337 -- end if;
9339 Loop_Body :=
9341 Condition =>
9343 Left_Opnd =>
9348 Right_Opnd =>
9357 Expression =>
9359 Left_Opnd =>
9364 Right_Opnd =>
9370 -- for I in X'range loop
9371 -- if ... end if;
9372 -- end loop;
9374 Loop_Statement :=
9378 Iteration_Scheme =>
9380 Loop_Parameter_Specification =>
9383 Discrete_Subtype_Definition =>
9390 -- if X'length = 0 then
9391 -- return false;
9392 -- elsif Y'length = 0 then
9393 -- return true;
9394 -- else
9395 -- for ... loop ... end loop;
9396 -- return X'length > Y'length;
9397 -- end if;
9399 Length1 :=
9404 Length2 :=
9409 Final_Expr :=
9414 If_Stat :=
9416 Condition =>
9418 Left_Opnd =>
9422 Right_Opnd =>
9425 Then_Statements =>
9426 New_List (
9432 Condition =>
9434 Left_Opnd =>
9438 Right_Opnd =>
9441 Then_Statements =>
9442 New_List (
9447 Loop_Statement,
9451 -- (X : a; Y: a)
9462 -- function Gnnn (...) return boolean is
9463 -- J : index := Y'first;
9464 -- begin
9465 -- if ... end if;
9466 -- end Gnnn;
9470 Func_Body :=
9472 Specification =>
9482 Expression =>
9487 Handled_Statement_Sequence =>
9494 ---------------------------
9495 -- Make_Boolean_Array_Op --
9496 ---------------------------
9498 -- For logical operations on boolean arrays, expand in line the following,
9499 -- replacing 'and' with 'or' or 'xor' where needed:
9501 -- function Annn (A : typ; B: typ) return typ is
9502 -- C : typ;
9503 -- begin
9504 -- for J in A'range loop
9505 -- C (J) := A (J) op B (J);
9506 -- end loop;
9507 -- return C;
9508 -- end Annn;
9510 -- Here typ is the boolean array type
9512 function Make_Boolean_Array_Op
9515 is
9533 begin
9534 A_J :=
9539 B_J :=
9544 C_J :=
9550 Op :=
9556 Op :=
9561 else
9562 Op :=
9568 Loop_Statement :=
9572 Iteration_Scheme =>
9574 Loop_Parameter_Specification =>
9577 Discrete_Subtype_Definition =>
9596 Func_Name :=
9600 Func_Body :=
9602 Specification =>
9613 Handled_Statement_Sequence =>
9616 Loop_Statement,
9623 ------------------------
9624 -- Rewrite_Comparison --
9625 ------------------------
9629 -- Set to True if first pass with Assume_Valid generates a warning in
9630 -- which case we skip the second pass to avoid warning overloaded.
9633 -- Set to Standard_True or Standard_False
9635 begin
9644 -- Now start looking at the comparison in detail. We potentially go
9645 -- through this loop twice. The first time, Assume_Valid is set False
9646 -- in the call to Compile_Time_Compare. If this call results in a
9647 -- clear result of always True or Always False, that's decisive and
9648 -- we are done. Otherwise we repeat the processing with Assume_Valid
9649 -- set to True to generate additional warnings. We can stil that step
9650 -- if Constant_Condition_Warnings is False.
9653 declare
9660 -- Res indicates if compare outcome can be compile time determined
9665 begin
9676 and then Constant_Condition_Warnings
9679 and then not In_Instance
9682 then
9683 Error_Msg_N
9701 and then Constant_Condition_Warnings
9704 and then not In_Instance
9707 then
9708 Error_Msg_N
9718 -- If this is the first iteration, then we actually convert the
9719 -- comparison into True or False, if the result is certain.
9725 else
9737 -- If this is the second iteration (AV = True), and the original
9738 -- node comes from source and we are not in an instance, then
9739 -- give a warning if we know result would be True or False. Note
9740 -- we know Constant_Condition_Warnings is set if we get here.
9743 and then not In_Instance
9744 then
9746 Error_Msg_N
9748 N);
9750 Error_Msg_N
9752 N);
9757 -- Skip second iteration if not warning on constant conditions or
9758 -- if the first iteration already generated a warning of some kind
9759 -- or if we are in any case assuming all values are valid (so that
9760 -- the first iteration took care of the valid case).
9768 ----------------------------
9769 -- Safe_In_Place_Array_Op --
9770 ----------------------------
9772 function Safe_In_Place_Array_Op
9776 is
9780 -- Operand is safe if it cannot overlap part of the target of the
9781 -- operation. If the operand and the target are identical, the operand
9782 -- is safe. The operand can be empty in the case of negation.
9785 -- Check that N is a stand-alone entity
9787 ------------------
9788 -- Is_Unaliased --
9789 ------------------
9792 begin
9793 return
9799 ---------------------
9800 -- Is_Safe_Operand --
9801 ---------------------
9804 begin
9815 return
9822 else
9827 -- Start of processing for Is_Safe_In_Place_Array_Op
9829 begin
9830 -- Skip this processing if the component size is different from system
9831 -- storage unit (since at least for NOT this would cause problems).
9836 -- Cannot do in place stuff on VM_Target since cannot pass addresses
9841 -- Cannot do in place stuff if non-standard Boolean representation
9848 else
9851 return
9857 -----------------------
9858 -- Tagged_Membership --
9859 -----------------------
9861 -- There are two different cases to consider depending on whether the right
9862 -- operand is a class-wide type or not. If not we just compare the actual
9863 -- tag of the left expr to the target type tag:
9864 --
9865 -- Left_Expr.Tag = Right_Type'Tag;
9866 --
9867 -- If it is a class-wide type we use the RT function CW_Membership which is
9868 -- usually implemented by looking in the ancestor tables contained in the
9869 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
9871 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
9872 -- function IW_Membership which is usually implemented by looking in the
9873 -- table of abstract interface types plus the ancestor table contained in
9874 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9876 procedure Tagged_Membership
9880 is
9890 begin
9893 -- Handle entities from the limited view
9902 Obj_Tag :=
9905 Selector_Name =>
9910 -- No need to issue a run-time check if we statically know that the
9911 -- result of this membership test is always true. For example,
9912 -- considering the following declarations:
9914 -- type Iface is interface;
9915 -- type T is tagged null record;
9916 -- type DT is new T and Iface with null record;
9918 -- Obj1 : T;
9919 -- Obj2 : DT;
9921 -- These membership tests are always true:
9923 -- Obj1 in T'Class
9924 -- Obj2 in T'Class;
9925 -- Obj2 in Iface'Class;
9927 -- We do not need to handle cases where the membership is illegal.
9928 -- For example:
9930 -- Obj1 in DT'Class; -- Compile time error
9931 -- Obj1 in Iface'Class; -- Compile time error
9936 and then Interface_Present_In_Ancestor
9939 then
9944 -- Ada 2005 (AI-251): Class-wide applied to interfaces
9948 -- Support to: "Iface_CW_Typ in Typ'Class"
9951 then
9952 -- Issue error if IW_Membership operation not available in a
9953 -- configurable run time setting.
9956 Error_Msg_CRT
9962 Result :=
9969 New_Reference_To (
9970 Node (First_Elmt
9972 Loc)));
9974 -- Ada 95: Normal case
9976 else
9979 Typ_Tag_Node =>
9980 New_Reference_To (
9981 Node (First_Elmt
9983 Loc),
9987 -- Generate the SCIL node for this class-wide membership test.
9988 -- Done here because the previous call to Build_CW_Membership
9989 -- relocates Obj_Tag.
10000 -- Right_Type is not a class-wide type
10002 else
10003 -- No need to check the tag of the object if Right_Typ is abstract
10008 else
10009 Result :=
10012 Right_Opnd =>
10013 New_Reference_To
10019 ------------------------------
10020 -- Unary_Op_Validity_Checks --
10021 ------------------------------
10024 begin